Imported Upstream version 8.4~betaupstream/8.4_beta

1456 files changed, 82717 insertions, 63099 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 00000000..1de1655d
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,8 @@
+((nil . ((eval . (setq default-directory (locate-dominating-file
+                                          buffer-file-name
+                                          ".dir-locals.el")
+                       tags-file-name (concat default-directory
+                                          "TAGS")
+                       camldebug-command-name (concat
+                                          default-directory "dev/ocamldebug-coq")
+)))))
\ No newline at end of file
diff --git a/.gitignore b/.gitignore
index 031b06b5..7fcd2580 100644
--- a/.gitignore
+++ b/.gitignore
@@ -29,49 +29,35 @@
 *.htoc
 *.ind
 *.lof
-*.stamp
 *.tacidx
 *.tacind
 *.v.tex
 *.v.pdf
 *.v.ps
 *.v.html
+*.stamp
 revision
 TAGS
+.DS_Store
+.pc
 bin/
+_build
+plugins/*/*_mod.ml
+myocamlbuild_config.ml
 config/Makefile
 config/coq_config.ml
-plugins/dp/dp_zenon.ml
 dev/ocamldebug-coq
-dev/ocamlweb-doc/lex.ml
-dev/ocamlweb-doc/syntax.ml
-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/undo.mli
-ide/utf8_convert.ml
-kernel/byterun/coq_jumptbl.h
+plugins/micromega/csdpcert
 kernel/byterun/dllcoqrun.so
-kernel/copcodes.ml
-scripts/tolink.ml
 states/initial.coq
+coqdoc.sty
 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
-toplevel/mltop.optml
-plugins/micromega/csdpcert
-toplevel/mltop.byteml
-coqdoc.sty
-ide/index_urls.txt
+test-suite/misc/universes/all_stdlib.v
+test-suite/misc/universes/universes.txt
+
+# documentation
+
 doc/faq/html/
 doc/refman/csdp.cache
 doc/refman/trace
@@ -100,8 +86,96 @@ 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
-.pc
+
+# .mll files
+
+dev/ocamlweb-doc/lex.ml
+ide/coq_lex.ml
+ide/config_lexer.ml
+ide/utf8_convert.ml
+ide/highlight.ml
+plugins/dp/dp_zenon.ml
+tools/gallina_lexer.ml
+tools/coqwc.ml
+tools/coqdep_lexer.ml
+tools/coqdoc/cpretty.ml
+lib/xml_lexer.ml
+
+# .mly files
+
+ide/config_parser.ml
+ide/config_parser.mli
+
+# .ml4 files
+
+ide/project_file.ml
+lib/pp.ml
+lib/compat.ml
+parsing/g_xml.ml
+parsing/g_prim.ml
+parsing/q_util.ml
+parsing/tacextend.ml
+parsing/q_constr.ml
+parsing/g_vernac.ml
+parsing/pcoq.ml
+parsing/g_constr.ml
+parsing/g_ltac.ml
+parsing/vernacextend.ml
+parsing/g_tactic.ml
+parsing/argextend.ml
+parsing/g_decl_mode.ml
+parsing/q_coqast.ml
+parsing/g_proofs.ml
+parsing/lexer.ml
+plugins/xml/proofTree2Xml.ml
+plugins/xml/acic2Xml.ml
+plugins/xml/xml.ml
+plugins/xml/dumptree.ml
+plugins/xml/xmlentries.ml
+plugins/extraction/g_extraction.ml
+plugins/rtauto/g_rtauto.ml
+plugins/romega/g_romega.ml
+plugins/setoid_ring/newring.ml
+plugins/firstorder/g_ground.ml
+plugins/dp/g_dp.ml
+plugins/cc/g_congruence.ml
+plugins/ring/g_ring.ml
+plugins/field/field.ml
+plugins/funind/g_indfun.ml
+plugins/omega/g_omega.ml
+plugins/quote/g_quote.ml
+plugins/nsatz/nsatz.ml
+plugins/micromega/g_micromega.ml
+plugins/subtac/g_subtac.ml
+plugins/fourier/g_fourier.ml
+plugins/decl_mode/g_decl_mode.ml
+tactics/tauto.ml
+tactics/eauto.ml
+tactics/hipattern.ml
+tactics/class_tactics.ml
+tactics/rewrite.ml
+tactics/eqdecide.ml
+tactics/extratactics.ml
+tactics/extraargs.ml
+tools/coq_tex.ml
+toplevel/mltop.ml
+toplevel/whelp.ml
+ide/coqide_main.ml
+ide/coqide_main_opt.ml
+
+# other auto-generated files
+
+ide/undo.mli
+toplevel/mltop.optml
+toplevel/mltop.byteml
+kernel/byterun/coq_jumptbl.h
+kernel/copcodes.ml
+scripts/tolink.ml
+theories/Numbers/Natural/BigN/NMake_gen.v
+ide/index_urls.txt
+
+# mlis documentation
+
+dev/ocamldoc/html/
+dev/ocamldoc/coq.*
+dev/ocamldoc/ocamldoc.sty
diff --git a/CHANGES b/CHANGES
index b8a5f9ea..74aefe49 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,134 +1,237 @@
-Changes from V8.3pl2 to V8.3pl3
-===============================
-
-General
-
-- #2411 (Axiom / Hypothesis / Variable allowed again during proofs)
-- #2603 (verify that all names of an inductive block aren't already used)
+Changes from V8.3 to V8.4
+=========================
 
-Modules
+Logic
 
-- #2608 (better handling of inlining and aliases, avoiding a Not_found)
-- #2168 (Print Assumption now support opaque modules)
-- #2609 (avoid adding twice a module in the environment in coqchk)
+- Standard eta-conversion now supported (dependent product only). (DOC TO DO)
+- Guard condition improvement: subterm property is propagated through beta-redex
+  blocked by pattern-matching, as in "(match v with C .. => fun x => u end) x";
+  this allows for instance to use "rewrite ... in ..." without breaking
+  the guard condition.
+
+Specification language and notations
+
+- Maximal implicit arguments can now be set locally by { }. The registration
+  traverses fixpoints and lambdas. Because there is conversion in types,
+  maximal implicit arguments are not taken into account in partial
+  applications (use eta expanded form with explicit { } instead).
+- Added support for recursive notations with binders (allows for instance
+  to write "exists x y z, P").
+- Structure/Record printing can be disable by "Unset Printing Records".
+  In addition, it can be controlled on type by type basis using
+  "Add Printing Record" or "Add Printing Constructor".
+- In a pattern containing a "match", a final "| _ => _" branch could be used
+  now instead of enumerating all remaining constructors. Moreover, the pattern
+  "match _ with _ => _ end" now allows to match any "match". A "in" annotation
+  can also be added to restrict to a precise inductive type.
+- Pattern-matching compilation algorithm: in "match x, y with ... end",
+  possible dependencies of x (or of the indices of its type) in the type
+  of y are now taken into account.
 
 Tactics
 
-- #2467, #2464 (fixes for fsetdec)
-- Document the "appcontext" variant of "context" that better handles
-  partial applications.
-
-Coqide
-
-- #2363 (fix the command separator for external commands)
-- #2499 (fix remove_current_view_page)
-- #2357 (allow the use of Abort)
+- New proof engine.
+- Scripts can now be structured thanks to bullets - * + and to subgoal
+  delimitation via { }. Note: for use with ProofGeneral, a cvs version of
+  ProofGeneral no older than mid-July 2011 is currently required. DOC TODO.
+- Support for tactical "info" is suspended.
+- Support for command "Show Script" is suspended.
+- New tactics constr_eq, is_evar and has_evar.
+- Removed the two-argument variant of "decide equality".
+- New experimental tactical "timeout <n> <tac>". Since <n> is a time
+  in second for the moment, this feature should rather be avoided
+  in scripts meant to be machine-independent.
+- Fix in "destruct": removal of unexpected local definitions in context might
+  result in some rare incompatibilities (solvable by adapting name hypotheses).
+- Introduction pattern "_" made more robust.
+- Tactic (and Eval command) vm_compute can now be interrupted via Ctrl-C.
+- Unification in "apply" supports unification of patterns of the form
+  ?f x y = g(x,y) (compatibility ensured by using
+  "Unset Tactic Pattern Unification"). It also supports (full) betaiota.
+- Tactic autorewrite does no longer instantiate pre-existing
+  existential variables (theoretical source of possible incompatibility).
+- Tactic "dependent rewrite" now supports equality in "sig".
+- Tactic omega now understands Zpred (wish #1912) and can prove any goal
+  from a context containing an arithmetical contradiction (wish #2236).
+- Using "auto with nocore" disables the use of the "core" database (wish #2188).
+  This pseudo-database "nocore" can also be used with trivial and eauto.
+- Tactics "set", "destruct" and "induction" accepts incomplete terms and
+  use the goal to complete the pattern assuming it is no ambiguous.
+- When used on arguments with a dependent type, tactics such as
+  "destruct", "induction", "case", "elim", etc. now try to abstract
+  automatically the dependencies over the arguments of the types
+  (based on initial ideas from Chung-Kil Hur, extension to nested
+   dependencies suggested by Dan Grayson)
+- Tactic "injection" now failing on an equality showing no constructors while
+  it was formerly generalizing again the goal over the given equality.
+- In Ltac, the "context [...]" syntax has now a variant "appcontext [...]"
+  allowing to match partial applications in larger applications.
+- When applying destruct or inversion on a fixpoint hiding an inductive
+  type, recursive calls to the fixpoint now remain folded by default (rare
+  source of incompatibility generally solvable by adding a call to simpl).
 
-Extraction
-
-- #2540 (global references should be indexed on their user parts)
-- #2556 (support of records with anonymous fields)
-- #2565 (typo in the documentation)
-- #2570 (avoid internal eta-reduction)
-- #2552 (For Haskell, type signature for __ and unsafeCoerce)
-- For Haskell, avoid some sources of useless unsafeCoerce
-- Forbid Prop-universe-polymorphism of inductive when extracting
-  to ocaml, otherwise things may fail badly (report by S. Glondu).
-
-Changes from V8.3pl1 to V8.3pl2
-===============================
-
-Coqdoc and documentation bugs
+Vernacular commands
 
-- #2470 (use "membership" instead of "appartness")
-- #2475 (documentation of the "f binders := t" notation for record fields)
-- Documentation of module String on coq.inria.fr/stdlib
+- It is now mandatory to have a space (or tabulation or newline or end-of-file)
+  after a "." ending a sentence.
+- In SearchAbout, the [ ] delimiters are now optional.
+- New command "Add/Remove Search Blacklist <substring> ..." :
+  a Search or SearchAbout or similar query will never mention lemmas
+  whose qualified names contain any of the declared substrings.
+  The default blacklisted substrings are "_admitted" "_subproof" "Private_". DOC TODO
+- When the output file of "Print Universes" ends in ".dot" or ".gv",
+  the universe graph is printed in the DOT language, and can be
+  processed by Graphviz tools.
+- New command "Print Sorted Universes".
+- The undocumented and obsolete option "Set/Unset Boxed Definitions" has
+  been removed, as well as syntaxes like "Boxed Fixpoint foo".
+- A new option "Set Default Timeout n / Unset Default Timeout".
+- Qed now uses information from the reduction tactics used in proof script
+  to avoid conversion at Qed time to go into a very long computation.
+- New command "Show Goal ident" to display the statement of a goal, even
+  a closed one (available from Proof General).
+
+Module System
+
+- During subtyping checks, an opaque constant in a module type could now
+  be implemented by anything of the right type, even if bodies differ.
+  Said otherwise, with respect to subtyping, an opaque constant behaves
+  just as a parameter. Coqchk was already implementing this, but not coqtop.
+- The inlining done during application of functors can now be controlled
+  more precisely, by the annotations (no inline) or (inline at level XX).
+  With the latter annotation, only functor parameters whose levels
+  are lower or equal than XX will be inlined.
+  The level of a parameter can be fixed by "Parameter Inline(30) foo".
+  When levels aren't given, the default value is 100. One can also use
+  the flag "Set Inline Level ..." to set a level. TODO: DOC!
+- Print Assumptions should now handle correctly opaque modules (#2168)
+- Print Module (Type) now tries to print more details, such as types and
+  bodies of the module elements. Note that Print Module Type could be
+  used on a module to display only its interface. The option
+  "Set Short Module Printing" could be used to switch back to the earlier
+  behavior were only field names were displayed.
 
-Tactics
+Libraries
 
-- #2493 (dependent pairs injection failing because of Type cumulativity missing)
-- Reduction "simpl" sometimes failing in presence of names redefined in modules
+- Extension of the abstract part of Numbers, which now provide axiomatizations
+  and results about many more integer functions, such as pow, gcd, lcm, sqrt, log2
+  and bitwise functions. These functions are implemented for nat N BigN Z BigZ.
+  See in particular file NPeano for new functions about nat.
+- The definition of types positive, N, Z is now in file BinNums.v
+- Major reorganization of ZArith. The initial file ZArith/BinInt.v now contains
+  an internal module Z implementing the Numbers interface for integers.
+  This module Z regroups:
+  * all functions over type Z : Z.add, Z.mul, ...
+  * the minimal proofs of specifications for these functions : Z.add_0_l, ...
+  * an instantation of all derived properties proved generically in Numbers :
+    Z.add_comm, Z.add_assoc, ...
+  A large part of ZArith is now simply compatibility notations, for instance
+  Zplus_comm is an alias for Z.add_comm. The direct use of module Z is now
+  recommended instead of relying on these compatibility notations.
+- Similar major reorganization of NArith, via a module N in NArith/BinNat.v
+- Concerning the positive datatype, BinPos.v is now in a specific directory
+  PArith, and contains an internal submodule Pos. We regroup there functions
+  such as Pos.add Pos.mul etc as well as many results about them. These results
+  are here proved directly (no Number interface for strictly positive numbers).
+- Note that in spite of the compatibility layers, all these reorganizations
+  may induce some marginal incompatibilies in scripts. In particular:
+  * the "?=" notation for positive now refers to a binary function Pos.compare,
+    instead of the infamous ternary Pcompare (now Pos.compare_cont).
+  * some hypothesis names generated by the system may changed (typically for
+    a "destruct Z_le_gt_dec") since naming is done after the short name of
+    the head predicate (here now "le" in module Z instead of "Zle", etc).
+  * the internals of Z.add has changed, now relying of Z.pos_sub.
+- Also note these new notations:
+  * "<?" "<=?" "=?" for boolean tests such as Z.ltb Z.leb Z.eqb.
+  * "÷" for the alternative integer division Z.quot implementing the Truncate
+    convention (former ZOdiv), while the notation for the Coq usual division
+    Z.div implementing the Flooring convention remains "/". Their corresponding
+    modulo functions are Z.rem (no notations) for Z.quot and Z.modulo (infix
+    "mod" notation) for Z.div.
+- Lemmas about conversions between these datatypes are also organized
+  in modules, see for instance modules Z2Nat, N2Z, etc.
+- When creating BigN, the macro-generated part NMake_gen is much smaller.
+  The generic part NMake has been reworked and improved. Some changes
+  may introduce incompatibilities. In particular, the order of the arguments
+  for BigN.shiftl and BigN.shiftr is now reversed: the number to shift now
+  comes first. By default, the power function now takes two BigN.
+- Creation of Vector, an independant library for list indiced by their length.
+  Vectors' names overwrite lists' one so you shouldn't "Import" the library.
+  All old names change: functions' name become the CaML one and for example
+  Vcons become Vector.cons. You can use notations by importing
+  Vector.VectorNotations.
+- Removal of TheoryList. Requiring List instead should work most of the time.
+- New syntax "rew Heq in H" and "rew <- Heq in H" for eq_rect and 
+  eq_rect_r (available by importing module EqNotations).
+- Wf.iter_nat is now Peano.nat_iter (with an implicit type argument)
 
-Extraction
+Internal infrastructure
 
-- #2359 (Some unnecessary unsafe casts are now avoided (bug in the type checker)).
-- #2469 (fix Extract Inlined Constant for Haskell and Scheme)
-- #2476 (Fix indentation of default pattern in haskell case)
-- #2477 (Avoid printing unused mutual fix components)
-- #2478 (Add missing parenthesis around emulated pattern-match)
-- #2482 (Extract Inductive on singleton inductives)
-- #2484 (Avoid an assert failure with -dont-load-proofs)
-- #2497 (malformed Haskell extraction of deeply-nested match expressions)
-- #2515 (Allow extracting Ascii.ascii to native Char in Haskell)
-- #2525 (Nicer error when a toplevel module has no body)
-- Fix printing of haskell modular names
-
-Miscellaneous bug fixes
-
-- #2487 (compilation with camlp5 in strict mode)
-- #2283, #2460 (new option "Set Default Timeout n / Unset Default Timeout")
-- #2524 (In win32, the exit code of coqc should be correct now)
-- Now, vm_compute is responsive to Ctrl-C interruption, as the rest of coqtop
-- Fixed uncaught exception when vmcast used in Check
-- coqdep complies with the -R visibility discipline
-- Fixing printing of f when defined using "Notation f x := ..."
-- Fixing Unset for options setting integer values
-- Excluding admitted subgoals from Search/SearchAbout
-
-Changes from V8.3 to V8.3pl1
-============================
-
-Type inference, notations and implicit arguments bug fixes
-
-- #2448 (alpha-renaming problems with notations internally using binders)
-- #2454 (pattern-matching sometimes not supporting type casts)
-- fixing combined use of non-implicit and explictly-declared implicit arguments
-  in inductive arities
-- restored support for using some ident with different scopes in notations
-
-Ltac and tactics bug fixes
-
-- #2414 (rewrite in not looking for eq_ind in the right module)
-- #2433 (new "is_evar"/"has_evar" to restore support for matching evars in Ltac)
-- #2453 (dependent destruction)
-- loop in dependent destruction
-- new "constr_eq" tactic for restoring support for term equality test in Ltac
-- setoid rewrite under cases and abstraction fixed
-
-Coqdoc and documentation bugs
-
-- #2418 (wrong URLs in documentation)
-- #2441 (coqdoc bug in Mergesort.v)
-- #2445 (correct support for "'" character in coqdoc links to notations)
-- fixed wrong use of "moduleid" instead of "module" in coqdoc html indexes
-- fixing parsing of Multiplication and Division signs (unicode 0xD7 and 0xF7)
-
-Compilation
-
-- #2432 (support for compilation with camlp5 6.02.0)
-- support for compilation with ocaml >= 3.09.3 restored
+- Opaque proofs are now loaded lazily by default. This allows to be almost as
+  fast as -dont-load-proofs, while being safer (no creation of axioms) and
+  avoiding feature restrictions (Print and Print Assumptions work ok).
+- Revised hash-consing code allowing more sharing of memory
+- Experimental support added for camlp4 (the one provided alongside ocaml),
+  simply pass option -usecamlp4 to ./configure. By default camlp5 is used.
+- Revised build system: no more stages in Makefile thanks to some recursive
+  aspect of recent gnu make, use of vo.itarget files containing .v to compile
+  for both make and ocamlbuild, etc.
+- Support of cross-compilation via mingw from unix toward Windows,
+  contact P. Letouzey for more informations.
+- new Makefile rules mli-doc to make html of mli in dev/doc/html and
+  full-stdlib to get a HUGE pdf with all the stdlib.
 
 Extraction
 
-- #2413 (prevent type-unsafe optimisations of pattern matching)
-- Identifiers of a development aimed to be extracted should
-  avoid containing "__", since the extraction make various use of
-  this sub-string, leading to potential name clashes. This was
-  already so in V8.3, but not announced, as mentionned by #2421.
-
-Miscellaneous bug fixes
+- By default, opaque terms are now truly considered opaque by extraction:
+  instead of accessing their body, they are now considered as axioms.
+  The previous behaviour can be reactivated via the option
+  "Set Extraction AccessOpaque".
+- The pretty-printer for Haskell now produces layout-independant code
+- A new command "Separate Extraction cst1 cst2 ..." that mixes a
+  minimal extracted environment a la "Recursive Extraction" and the
+  production of several files (one per coq source) a la "Extraction Library".
+  DOC TODO.
+- New option "Set/Unset Extraction KeepSingleton" for preventing the
+  extraction to optimize singleton container types. DOC TODO
+- The extraction now identifies and properly rejects a particular case of
+  universe polymorphism it cannot handle yet (the pair (I,I) being Prop).
+- Support of anonymous fields in record (#2555).
 
-- #2412 (anomaly Ploc.Exc when using Ltac Debug)
-- #2419 (redundant opp_compare removed)
-- #2427 (Module Functor claims Signature does not match)
-- #2431 (compliance of CoqIDE use of mutexes with FreeBSD)
-- #2434 (anomaly DuringSyntaxChecking with Local/Global prefixes)
-- a few improvements in efficiency
+CoqIDE
 
+- Coqide now runs coqtop as separated process, making it more robust:
+  coqtop subprocess can be interrupted, or even killed and relaunched
+  (cf button "Restart Coq", ex-"Go to Start"). For allowing such
+  interrupts, the Windows version of coqide now requires Windows >= XP
+  SP1.
+- The communication between CoqIDE and Coqtop is now done via a dialect
+  of XML (DOC TODO).
+- The backtrack engine of CoqIDE has been reworked, it now used the
+  "Backtrack" command similarly to ProofGeneral.
+- The Coqide parsing of sentences has be reworked and now supports
+  tactic delimitation via { }.
+- Coqide now accepts the Abort command (wish #2357).
+- Coqide can read coq_makefile files as "project file" and use it to
+  set automatically options to send to coqtop.
+- Preference files have moved to $XDG_CONFIG_HOME/coq and accelerators
+  are not stored as a list anymore.
 
-Extraction
+Tools
 
-- The pretty-printer for Haskell now produces layout-independant code
+- Coq now searches directories specified in COQPATH, $XDG_DATA_HOME/coq,
+  $XDG_DATA_DIRS/coq, and user-contribs before the standard library.
+- Coq rc file has moved to $XDG_CONFIG_HOME/coq.
+- coq_makefile major cleanup.
+  * mli/mlpack/mllib taken into account, ml not preproccessed anymore, ml4 work
+  * mlihtml generates doc of mli, install-doc install the html doc in DOCDIR
+    with the same policy as vo in COQLIB
+  * More variables are given by coqtop -config, others are defined only if the
+    users doesn't have defined them elsewhere. Consequently, generated makefile
+    should work directly on any architecture.
+  * Packagers can take advantage of $(DSTROOT) introduction. Installation can
+    be made in $XDG_DATA_HOME/coq.
+  * -arg option allows to send option as argument to coqc.
 
 Changes from V8.2 to V8.3
 =========================
@@ -159,7 +262,8 @@ 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 Iff Unfolding".)
+  "unfold iff, not in *; intuition", or, for iff only, by using
+  "Set Intuition Iff 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.
@@ -169,7 +273,7 @@ Automation tactics
   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 
+- New decision tactic "nsatz" to prove polynomial equations
   by computation of Groebner bases.
 
 Other tactics
@@ -181,9 +285,9 @@ Other tactics
 - 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 
+- 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 
+- 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.
@@ -282,7 +386,7 @@ Extraction
   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.  
+  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
@@ -300,11 +404,11 @@ Program
   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 
+- 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 
+- [fst] and [snd] have maximal implicit arguments in Program now (possible
   source of incompatibility).
 
 Type classes
@@ -315,7 +419,7 @@ Type classes
 - 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, 
+- Various bug fixes and improvements: support for defined fields,
   anonymous instances, declarations giving terms, better handling of
   sections and [Context].
 
@@ -367,7 +471,7 @@ Library
     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 
+  - 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;
@@ -462,22 +566,22 @@ Changes from V8.1 to V8.2
 
 Language
 
-- If a fixpoint is not written with an explicit { struct ... }, then 
-  all arguments are tried successively (from left to right) until one is 
+- If a fixpoint is not written with an explicit { struct ... }, then
+  all arguments are tried successively (from left to right) until one is
   found that satisfies the structural decreasing condition.
-- New experimental typeclass system giving ad-hoc polymorphism and 
+- New experimental typeclass system giving ad-hoc polymorphism and
   overloading based on dependent records and implicit arguments.
 - New syntax "let 'pat := b in c" for let-binding using irrefutable patterns.
-- New syntax "forall {A}, T" for specifying maximally inserted implicit 
+- New syntax "forall {A}, T" for specifying maximally inserted implicit
   arguments in terms.
 - Sort of Record/Structure, Inductive and CoInductive defaults to Type
   if omitted.
-- (Co)Inductive types can be defined as records 
+- (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
   statements.
 - Support for sort-polymorphism on constants denoting inductive types.
-- Several evolutions of the module system (handling of module aliases, 
+- Several evolutions of the module system (handling of module aliases,
   functorial module types, an Include feature, etc).
 - Prop now a subtype of Set (predicative and impredicative forms).
 - Recursive inductive types in Prop with a single constructor of which
@@ -495,18 +599,18 @@ Vernacular commands
 - Modification of the Scheme command so you can ask for the name to be
   automatically computed (e.g. Scheme Induction for nat Sort Set).
 - New command "Combined Scheme" to build combined mutual induction
-  principles from existing mutual induction principles. 
-- New command "Scheme Equality" to build a decidable (boolean) equality 
+  principles from existing mutual induction principles.
+- New command "Scheme Equality" to build a decidable (boolean) equality
   for simple inductive datatypes and a decision property over this equality
   (e.g.  Scheme Equality for nat).
-- Added option "Set Equality Scheme" to make automatic the declaration 
+- Added option "Set Equality Scheme" to make automatic the declaration
   of the boolean equality when possible.
-- Source of universe inconsistencies now printed when option 
+- Source of universe inconsistencies now printed when option
   "Set Printing Universes" is activated.
 - New option "Set Printing Existential Instances" for making the display of
   existential variable instances explicit.
-- Support for option "[id1 ... idn]", and "-[id1 ... idn]", for the 
-  "compute"/"cbv" reduction strategy, respectively meaning reduce only, or 
+- Support for option "[id1 ... idn]", and "-[id1 ... idn]", for the
+  "compute"/"cbv" reduction strategy, respectively meaning reduce only, or
   everything but, the constants id1 ... idn. "lazy" alone or followed by
   "[id1 ... idn]", and "-[id1 ... idn]" also supported, meaning apply
   all of beta-iota-zeta-delta, possibly restricting delta.
@@ -533,46 +637,46 @@ Libraries
   SetoidList, ListSet, Sorting, Zmisc. This may induce a few
   incompatibilities. In case of trouble while fixing existing development,
   it may help to simply declare Set as an alias for Type (see file
-  SetIsType). 
-- New arithmetical library in theories/Numbers. It contains: 
-  * an abstract modular development of natural and integer arithmetics 
+  SetIsType).
+- New arithmetical library in theories/Numbers. It contains:
+  * an abstract modular development of natural and integer arithmetics
     in Numbers/Natural/Abstract and Numbers/Integer/Abstract
-  * an implementation of efficient computational bounded and unbounded 
+  * an implementation of efficient computational bounded and unbounded
     integers that can be mapped to processor native arithmetics.
-    See Numbers/Cyclic/Int31 for 31-bit integers and Numbers/Natural/BigN 
+    See Numbers/Cyclic/Int31 for 31-bit integers and Numbers/Natural/BigN
     for unbounded natural numbers and Numbers/Integer/BigZ for unbounded
-    integers. 
+    integers.
   * some proofs that both older libraries Arith, ZArith and NArith and
     newer BigN and BigZ implement the abstract modular development.
-    This allows in particular BigN and BigZ to already come with a 
+    This allows in particular BigN and BigZ to already come with a
     large database of basic lemmas and some generic tactics (ring),
   This library has still an experimental status, as well as the
   processor-acceleration mechanism, but both its abstract and its
   concrete parts are already quite usable and could challenge the use
-  of nat, N and Z in actual developments. Moreover, an extension of 
+  of nat, N and Z in actual developments. Moreover, an extension of
   this framework to rational numbers is ongoing, and an efficient
-  Q structure is already provided (see Numbers/Rational/BigQ), but 
-  this part is currently incomplete (no abstract layer and generic 
+  Q structure is already provided (see Numbers/Rational/BigQ), but
+  this part is currently incomplete (no abstract layer and generic
   lemmas).
 - Many changes in FSets/FMaps. In practice, compatibility with earlier
   version should be fairly good, but some adaptations may be required.
   * Interfaces of unordered ("weak") and ordered sets have been factorized
     thanks to new features of Coq modules (in particular Include), see
     FSetInterface. Same for maps. Hints in these interfaces have been
-    reworked (they are now placed in a "set" database). 
+    reworked (they are now placed in a "set" database).
   * To allow full subtyping between weak and ordered sets, a field
     "eq_dec" has been added to OrderedType. The old version of OrderedType
-    is now called MiniOrderedType and functor MOT_to_OT allow to 
+    is now called MiniOrderedType and functor MOT_to_OT allow to
     convert to the new version. The interfaces and implementations
     of sets now contain also such a "eq_dec" field.
   * FSetDecide, contributed by Aaron Bohannon, contains a decision
-    procedure allowing to solve basic set-related goals (for instance, 
+    procedure allowing to solve basic set-related goals (for instance,
     is a point in a particular set ?). See FSetProperties for examples.
   * Functors of properties have been improved, especially the ones about
-    maps, that now propose some induction principles. Some properties 
-    of fold need less hypothesis. 
+    maps, that now propose some induction principles. Some properties
+    of fold need less hypothesis.
   * More uniformity in implementations of sets and maps: they all use
-    implicit arguments, and no longer export unnecessary scopes (see 
+    implicit arguments, and no longer export unnecessary scopes (see
     bug #1347)
   * Internal parts of the implementations based on AVL have evolved a
     lot. The main files FSetAVL and FMapAVL are now much more
@@ -586,31 +690,31 @@ Libraries
     structural yet efficient. The appendix files also contains
     alternative versions of these few functions, much closer to the
     initial Ocaml code and written via the Function framework.
-- Library IntMap, subsumed by FSets/FMaps, has been removed from 
+- Library IntMap, subsumed by FSets/FMaps, has been removed from
   Coq Standard Library and moved into a user contribution Cachan/IntMap
-- Better computational behavior of some constants (eq_nat_dec and 
-  le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare 
+- Better computational behavior of some constants (eq_nat_dec and
+  le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare
   transparent, ...) (exceptional source of incompatibilities).
 - Boolean operators moved from module Bool to module Datatypes (may need
   to rename qualified references in script and force notations || and &&
   to be at levels 50 and 40 respectively).
-- The constructors xI and xO of type positive now have postfix notations 
-  "~1" and "~0", allowing to write numbers in binary form easily, for instance 
+- The constructors xI and xO of type positive now have postfix notations
+  "~1" and "~0", allowing to write numbers in binary form easily, for instance
   6 is 1~1~0 and 4*p is p~0~0 (see BinPos.v).
-- Improvements to NArith (Nminus, Nmin, Nmax), and to QArith (in particular 
+- Improvements to NArith (Nminus, Nmin, Nmax), and to QArith (in particular
   a better power function).
-- Changes in ZArith: several additional lemmas (used in theories/Numbers), 
+- Changes in ZArith: several additional lemmas (used in theories/Numbers),
   especially in Zdiv, Znumtheory, Zpower. Moreover, many results in
   Zdiv have been generalized: the divisor may simply be non-null
   instead of strictly positive (see lemmas with name ending by
   "_full"). An alternative file ZOdiv proposes a different behavior
   (the one of Ocaml) when dividing by negative numbers.
-- Changes in Arith: EqNat and Wf_nat now exported from Arith, some 
+- Changes in Arith: EqNat and Wf_nat now exported from Arith, some
   constructions on nat that were outside Arith are now in (e.g. iter_nat).
-- In SetoidList, eqlistA now expresses that two lists have similar elements 
-  at the same position, while the predicate previously called eqlistA 
-  is now equivlistA (this one only states that the lists contain the same 
-  elements, nothing more). 
+- In SetoidList, eqlistA now expresses that two lists have similar elements
+  at the same position, while the predicate previously called eqlistA
+  is now equivlistA (this one only states that the lists contain the same
+  elements, nothing more).
 - Changes in Reals:
   * Most statement in "sigT" (including the
     completeness axiom) are now in "sig" (in case of incompatibility,
@@ -627,7 +731,7 @@ Libraries
 - Definition of pred and minus made compatible with the structural
   decreasing criterion for use in fixpoints.
 - Files Relations/Rstar.v and Relations/Newman.v moved out to the user
-  contribution repository (contribution CoC_History). New lemmas about 
+  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.
@@ -695,7 +799,7 @@ Tactics
 - New tactics "ediscriminate", "einjection", "esimplify_eq".
 - Tactics "discriminate", "injection", "simplify_eq" now support any
   term as argument. Clause "with" is also supported.
-- Unfoldable references can be given by notation's string rather than by name 
+- Unfoldable references can be given by notation's string rather than by name
   in unfold.
 - The "with" arguments are now typed using informations from the current goal:
   allows support for coercions and more inference of implicit arguments.
@@ -708,8 +812,8 @@ Tactics
   (possible source of parsing incompatibilities when destruct or induction is
    part of a let-in expression in Ltac; extra parentheses are then required).
 - New support for "as" clause in tactics "apply in" and "eapply in".
-- Some new intro patterns: 
-  * intro pattern "?A" genererates a fresh name based on A. 
+- Some new intro patterns:
+  * intro pattern "?A" genererates a fresh name based on A.
     Caveat about a slight loss of compatibility:
     Some intro patterns don't need space between them. In particular
     intros ?a?b used to be legal and equivalent to intros ? a ? b. Now it
@@ -718,31 +822,31 @@ Tactics
     for right-associative constructs like /\ or exists.
 - Several syntax extensions concerning "rewrite":
   * "rewrite A,B,C" can be used to rewrite A, then B, then C. These rewrites
-    occur only on the first subgoal: in particular, side-conditions of the 
+    occur only on the first subgoal: in particular, side-conditions of the
     "rewrite A" are not concerned by the "rewrite B,C".
-  * "rewrite A by tac" allows to apply tac on all side-conditions generated by 
+  * "rewrite A by tac" allows to apply tac on all side-conditions generated by
     the "rewrite A".
-  * "rewrite A at n" allows to select occurrences to rewrite: rewrite only 
+  * "rewrite A at n" allows to select occurrences to rewrite: rewrite only
     happen at the n-th exact occurrence of the first successful matching of
-    A in the goal. 
+    A in the goal.
   * "rewrite 3 A" or "rewrite 3!A" is equivalent to "rewrite A,A,A".
   * "rewrite !A" means rewriting A as long as possible (and at least once).
   * "rewrite 3?A" means rewriting A at most three times.
   * "rewrite ?A" means rewriting A as long as possible (possibly never).
-  * many of the above extensions can be combined with each other.  
+  * many of the above extensions can be combined with each other.
 - Introduction patterns better respect the structure of context in presence of
-  missing or extra names in nested disjunction-conjunction patterns [possible 
+  missing or extra names in nested disjunction-conjunction patterns [possible
   source of rare incompatibilities].
 - New syntax "rename a into b, c into d" for "rename a into b; rename c into d"
 - New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]"
-  to do induction-inversion on instantiated inductive families à la BasicElim.
-- Tactics "apply" and "apply in" now able to reason modulo unfolding of 
-  constants (possible source of incompatibility in situations where apply 
+  to do induction-inversion on instantiated inductive families à la BasicElim.
+- Tactics "apply" and "apply in" now able to reason modulo unfolding of
+  constants (possible source of incompatibility in situations where apply
   may fail, e.g. as argument of a try or a repeat and in a ltac function);
-  versions that do not unfold are renamed into "simple apply" and 
+  versions that do not unfold are renamed into "simple apply" and
   "simple apply in" (usable for compatibility or for automation).
-- Tactics "apply" and "apply in" now able to traverse conjunctions and to 
-  select the first matching lemma among the components of the conjunction; 
+- Tactics "apply" and "apply in" now able to traverse conjunctions and to
+  select the first matching lemma among the components of the conjunction;
   tactic "apply" also able to apply lemmas of conclusion an empty type.
 - Tactic "apply" now supports application of several lemmas in a row.
 - Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)".
@@ -752,69 +856,69 @@ Tactics
 - Tactic "generalize" now supports "at" options to specify occurrences
   and "as" options to name the quantified hypotheses.
 - New tactic "specialize H with a" or "specialize (H a)" allows to transform
-  in-place a universally-quantified hypothesis (H : forall x, T x) into its 
+  in-place a universally-quantified hypothesis (H : forall x, T x) into its
   instantiated form (H : T a). Nota: "specialize" was in fact there in earlier
   versions of Coq, but was undocumented, and had a slightly different behavior.
 - New tactic "contradict H" can be used to solve any kind of goal as long as
   the user can provide afterwards a proof of the negation of the hypothesis H.
   If H is already a negation, say ~T, then a proof of T is asked.
   If the current goal is a negation, say ~U, then U is saved in H afterwards,
-  hence this new tactic "contradict" extends earlier tactic "swap", which is 
+  hence this new tactic "contradict" extends earlier tactic "swap", which is
   now obsolete.
-- Tactics f_equal is now done in ML instead of Ltac: it now works on any 
+- Tactics f_equal is now done in ML instead of Ltac: it now works on any
   equality of functions, regardless of the arity of the function.
 - New options "before id", "at top", "at bottom" for tactics "move"/"intro".
-- Some more debug of reflexive omega (romega), and internal clarifications. 
+- Some more debug of reflexive omega (romega), and internal clarifications.
   Moreover, romega now has a variant "romega with *" that can be also used
   on non-Z goals (nat, N, positive) via a call to a translation tactic named
   zify (its purpose is to Z-ify your goal...). This zify may also be used
-  independantly of romega. 
-- Tactic "remember" now supports an "in" clause to remember only selected 
+  independantly of romega.
+- Tactic "remember" now supports an "in" clause to remember only selected
   occurrences of a term.
 - Tactic "pose proof" supports name overwriting in case of specialization of an
   hypothesis.
-- Semi-decision tactic "jp" for first-order intuitionistic logic moved to user 
+- Semi-decision tactic "jp" for first-order intuitionistic logic moved to user
   contributions (subsumed by "firstorder").
 
 Program
 
 - Moved useful tactics in theories/Program and documented them.
-- Add Program.Basics which contains standard definitions for functional 
+- Add Program.Basics which contains standard definitions for functional
   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 
+  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 
+- 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 
+- Program Lemma, Axiom etc... now permit to have obligations in the statement
   iff they can be automatically solved by the default tactic.
 - Renamed "Obligations Tactic" command to "Obligation Tactic".
 - New command "Preterm [ of id ]" to see the actual term fed to Coq for
   debugging purposes.
-- New option "Transparent Obligations" to control the declaration of 
-  obligations as transparent or opaque. All obligations are now transparent 
+- New option "Transparent Obligations" to control the declaration of
+  obligations as transparent or opaque. All obligations are now transparent
   by default, otherwise the system declares them opaque if possible.
-- Changed the notations "left" and "right" to "in_left" and "in_right" to hide 
-  the proofs in standard disjunctions, to avoid breaking existing scripts when 
+- Changed the notations "left" and "right" to "in_left" and "in_right" to hide
+  the proofs in standard disjunctions, to avoid breaking existing scripts when
   importing Program. Also, put them in program_scope.
 
 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.  
+  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 command " Print Classes " and " Print Instances some_class " to
-  print tables for typeclasses.  
+  print tables for typeclasses.
 - New default eauto hint database "typeclass_instances" used by the default
-  typeclass instance search tactic.  
-- New theories directory "theories/Classes" for standard typeclasses 
-  declarations. Module Classes.RelationClasses is a typeclass port of 
-  Relation_Definitions plus a generic development of algebra on 
+  typeclass instance search tactic.
+- New theories directory "theories/Classes" for standard typeclasses
+  declarations. Module Classes.RelationClasses is a typeclass port of
+  Relation_Definitions plus a generic development of algebra on
   n-ary heterogeneous predicates.
-  
+
 Setoid rewriting
 
 - Complete (and still experimental) rewrite of the tactic
@@ -826,19 +930,19 @@ Setoid rewriting
 
   - "-->", "++>" and "==>" are now right associative notations
   declared at level 55 in scope signature_scope.
-  Their introduction may break existing scripts that defined 
+  Their introduction may break existing scripts that defined
   them as notations with different levels.
-  
+
   - 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 
+  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
   at once. Use [setoid_rewrite H at 1] for (almost) the usual semantics.
   [setoid_rewrite] will also try to rewrite under binders now, and can
-  succeed on different terms than before. In particular, it will unify under 
+  succeed on different terms than before. In particular, it will unify under
   let-bound variables. When called through [rewrite], the semantics are
   unchanged though.
 
@@ -853,7 +957,7 @@ Setoid rewriting
 
   - Setoid_Theory is now an alias to Equivalence, scripts building objects
   of type Setoid_Theory need to unfold (or "red") the definitions
-  of Reflexive, Symmetric and Transitive in order to get the same goals 
+  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
@@ -861,7 +965,7 @@ Setoid rewriting
 
 - New standard library modules Classes.Morphisms declares
   standard morphisms on refl/sym/trans relations.
-  Classes.Morphisms_Prop declares morphisms on propositional 
+  Classes.Morphisms_Prop declares morphisms on propositional
   connectives and Classes.Morphisms_Relations on generalized predicate
   connectives. Classes.Equivalence declares notations and tactics
   related to equivalences and Classes.SetoidTactics defines the
@@ -873,30 +977,30 @@ Setoid rewriting
   and rewriting under binders. The tactic is also extensible entirely in Ltac.
   The documentation has been updated to cover these features.
 
-- [setoid_rewrite] and [rewrite] now support the [at] modifier to select 
+- [setoid_rewrite] and [rewrite] now support the [at] modifier to select
   occurrences to rewrite, and both use the [setoid_rewrite] code, even when
   rewriting with leibniz equality if occurrences are specified.
 
 Extraction
 
-- Improved behavior of the Caml extraction of modules: name clashes should 
-  not happen anymore. 
+- Improved behavior of the Caml extraction of modules: name clashes should
+  not happen anymore.
 - The command Extract Inductive has now a syntax for infix notations. This
-  allows in particular to map Coq lists and pairs onto Caml ones:  
+  allows in particular to map Coq lists and pairs onto Caml ones:
     Extract Inductive list => list [ "[]" "(::)" ].
     Extract Inductive prod => "(*)" [ "(,)" ].
-- In pattern matchings, a default pattern "| _ -> ..." is now used whenever 
+- In pattern matchings, a default pattern "| _ -> ..." is now used whenever
   possible if several branches are identical. For instance, functions
-  corresponding to decidability of equalities are now linear instead of 
+  corresponding to decidability of equalities are now linear instead of
   quadratic.
 - A new instruction Extraction Blacklist id1 .. idn allows to prevent filename
   conflits with existing code, for instance when extracting module List
-  to Ocaml. 
+  to Ocaml.
 
 CoqIDE
 
 - CoqIDE font defaults to monospace so as indentation to be meaningful.
-- CoqIDE supports nested goals and any other kind of declaration in the middle 
+- CoqIDE supports nested goals and any other kind of declaration in the middle
   of a proof.
 - Undoing non-tactic commands in CoqIDE works faster.
 - New CoqIDE menu for activating display of various implicit informations.
@@ -910,8 +1014,8 @@ 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".
-- Improved coqdoc and dump of globalization information to give more 
-  meta-information on identifiers. All categories of Coq definitions are 
+- 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.
   Support for hyperlinking and indexing developments in the tex output
   has been implemented as well.
@@ -947,8 +1051,8 @@ Tactics
   field on R manage power (may lead to incompatibilities with V8.1gamma).
 - Tactic field_simplify now applicable in hypotheses.
 - New field_simplify_eq for simplifying field equations into ring equations.
-- Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq 
-  all able to apply user-given equations to rewrite monoms on the fly 
+- Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq
+  all able to apply user-given equations to rewrite monoms on the fly
   (see documentation).
 
 Libraries
@@ -987,7 +1091,7 @@ Tactics
 - Support for argument lists of arbitrary length in Tactic Notation.
 - [rewrite ... in H] now fails if [H] is used either in an hypothesis
   or in the goal.
-- The semantics of [rewrite ... in *] has been slightly modified (see doc). 
+- The semantics of [rewrite ... in *] has been slightly modified (see doc).
 - Support for "as" clause in tactic injection.
 - New forward-reasoning tactic "apply in".
 - Ltac fresh operator now builds names from a concatenation of its arguments.
@@ -1012,7 +1116,7 @@ Logic
 Syntax
 
 - No more support for version 7 syntax and for translation to version 8 syntax.
-- In fixpoints, the { struct ... } annotation is not mandatory any more when 
+- In fixpoints, the { struct ... } annotation is not mandatory any more when
   only one of the arguments has an inductive type
 - Added disjunctive patterns in match-with patterns
 - Support for primitive interpretation of string literals
@@ -1037,7 +1141,7 @@ Ltac and tactic syntactic extensions
 - New semantics for "match t with": if a clause returns a
   tactic, it is now applied to the current goal. If it fails, the next
   clause or next matching subterm is tried (i.e. it behaves as "match
-  goal with" does). The keyword "lazymatch" can be used to delay the 
+  goal with" does). The keyword "lazymatch" can be used to delay the
   evaluation of tactics occurring in matching clauses.
 - Hint base names can be parametric in auto and trivial.
 - Occurrence values can be parametric in unfold, pattern, etc.
@@ -1054,14 +1158,14 @@ Tactics
 - New implementation (still experimental) of the ring tactic with a built-in
   notion of coefficients and a better usage of setoids.
 - New conversion tactic "vm_compute": evaluates the goal (or an hypothesis)
-  with a call-by-value strategy, using the compiled version of terms. 
-- When rewriting H where H is not directly a Coq equality, search first H for 
+  with a call-by-value strategy, using the compiled version of terms.
+- When rewriting H where H is not directly a Coq equality, search first H for
   a registered setoid equality before starting to reduce in H. This is unlikely
-  to break any script. Should this happen nonetheless, one can insert manually 
+  to break any script. Should this happen nonetheless, one can insert manually
   some "unfold ... in H" before rewriting.
 - Fixed various bugs about (setoid) rewrite ... in ... (in particular #1101)
-- "rewrite ... in" now accepts a clause as place where to rewrite instead of 
-  juste a simple hypothesis name. For instance: 
+- "rewrite ... in" now accepts a clause as place where to rewrite instead of
+  juste a simple hypothesis name. For instance:
    rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H
    rewrite H in * |-  will do try rewrite H in Hi for all hypothesis Hi <> H.
 - Added "dependent rewrite term" and "dependent rewrite term in hyp".
@@ -1072,19 +1176,19 @@ Tactics
   (it used to be a reference).
 - Omega now handles arbitrary precision integers.
 - Several bug fixes in Reflexive Omega (romega).
-- Idtac can now be left implicit in a [...|...] construct: for instance, 
+- Idtac can now be left implicit in a [...|...] construct: for instance,
   [ foo | | bar ] stands for [ foo | idtac | bar ].
 - Fixed a "fold" bug (non critical but possible source of incompatibilities).
-- Added classical_left and classical_right which transforms |- A \/ B into 
+- Added classical_left and classical_right which transforms |- A \/ B into
   ~B |- A and ~A |- B respectively.
 - Added command "Declare Implicit Tactic" to set up a default tactic to be
   used to solve unresolved subterms of term arguments of tactics.
-- Better support for coercions to Sortclass in tactics expecting type 
+- Better support for coercions to Sortclass in tactics expecting type
   arguments.
 - Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses.
 - New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns.
 - New introduction pattern "?" for letting Coq choose a name.
-- Introduction patterns now support side hypotheses (e.g. intros [|] on 
+- Introduction patterns now support side hypotheses (e.g. intros [|] on
   "(nat -> nat) -> nat" works).
 - New introduction patterns "->" and "<-" for immediate rewriting of
   introduced hypotheses.
@@ -1105,20 +1209,20 @@ Tactics
 - Generalization of induction "induction x1...xn using scheme" where
   scheme is an induction principle with complex predicates (like the
   ones generated by function induction).
-- Some small Ltac tactics has been added to the standard library 
+- Some small Ltac tactics has been added to the standard library
   (file Tactics.v):
   * f_equal : instead of using the different f_equalX lemmas
-  * case_eq : a "case" without loss of information. An equality 
+  * case_eq : a "case" without loss of information. An equality
      stating the current situation is generated in every sub-cases.
-  * swap : for a negated goal ~B and a negated hypothesis H:~A, 
-     swap H asks you to prove A from hypothesis B 
+  * swap : for a negated goal ~B and a negated hypothesis H:~A,
+     swap H asks you to prove A from hypothesis B
   * revert : revert H is generalize H; clear H.
 
 Extraction
- 
-- All type parts should now disappear instead of sometimes producing _ 
+
+- All type parts should now disappear instead of sometimes producing _
   (for instance in Map.empty).
-- Haskell extraction: types of functions are now printed, better 
+- Haskell extraction: types of functions are now printed, better
   unsafeCoerce mechanism, both for hugs and ghc.
 - Scheme extraction improved, see http://www.pps.jussieu.fr/~letouzey/scheme.
 - Many bug fixes.
@@ -1159,7 +1263,7 @@ Libraries
   digit 0; weaken premises in Z_lt_induction).
 - Restructuration of Eqdep_dec.v and Eqdep.v: more lemmas in Type.
 - Znumtheory now contains a gcd function that can compute within Coq.
-- More lemmas stated on Type in Wf.v, removal of redundant Acc_iter and 
+- More lemmas stated on Type in Wf.v, removal of redundant Acc_iter and
   Acc_iter2.
 - Change of the internal names of lemmas in OmegaLemmas.
 - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on
@@ -1171,17 +1275,17 @@ Libraries
   proof scripts, set it locally opaque for compatibility).
 - More on permutations of lists in List.v and Permutation.v.
 - List.v has been much expanded.
-- New file SetoidList.v now contains results about lists seen with 
+- New file SetoidList.v now contains results about lists seen with
   respect to a setoid equality.
-- Library NArith has been expanded, mostly with results coming from 
-  Intmap (for instance a bitwise xor), plus also a bridge between N and 
+- Library NArith has been expanded, mostly with results coming from
+  Intmap (for instance a bitwise xor), plus also a bridge between N and
   Bitvector.
-- Intmap has been reorganized. In particular its address type "addr" is 
-  now N. User contributions known to use Intmap have been adapted 
-  accordingly. If you're using this library please contact us. 
-  A wrapper FMapIntMap now presents Intmap as a particular implementation 
-  of FMaps. New developments are strongly encouraged to use either this 
-  wrapper or any other implementations of FMap instead of using directly 
+- Intmap has been reorganized. In particular its address type "addr" is
+  now N. User contributions known to use Intmap have been adapted
+  accordingly. If you're using this library please contact us.
+  A wrapper FMapIntMap now presents Intmap as a particular implementation
+  of FMaps. New developments are strongly encouraged to use either this
+  wrapper or any other implementations of FMap instead of using directly
   this obsolete Intmap.
 
 Tools
@@ -1212,7 +1316,7 @@ Vernacular commands
 
 New syntax
 
-- Semantics change of the if-then-else construction in new syntax: 
+- Semantics change of the if-then-else construction in new syntax:
   "if c then t1 else t2" now stands for
   "match c with c1 _ ... _ => t1 | c2 _ ... _ => t2 end"
   with no dependency of t1 and t2 in the arguments of the constructors;
@@ -1234,7 +1338,7 @@ Executables and tools
 
 - Added option -top to change the name of the toplevel module "Top"
 - Coqdoc updated to new syntax and now part of Coq sources
-- XML exportation tool now exports the structure of vernacular files 
+- XML exportation tool now exports the structure of vernacular files
   (cf chapter 13 in the reference manual)
 
 User contributions
@@ -1251,7 +1355,7 @@ Changes from V8.0beta old syntax to V8.0beta
 New concrete syntax
 
 - A completely new syntax for terms
-- A more uniform syntax for tactics and the tactic language 
+- A more uniform syntax for tactics and the tactic language
 - A few syntactic changes for vernacular commands
 - A smart automatic translator translating V8.0 files in old syntax to
   files valid for V8.0
@@ -1271,7 +1375,7 @@ Syntax extensions
 
 Revision of the standard library
 
-- Many lemmas and definitions names have been made more uniform mostly 
+- Many lemmas and definitions names have been made more uniform mostly
   in Arith, NArith, ZArith and Reals (e.g : "times" -> "Pmult",
   "times_sym" -> "Pmult_comm", "Zle_Zmult_pos_right" ->
   "Zmult_le_compat_r", "SUPERIEUR" -> "Gt", "ZERO" -> "Z0")
@@ -1319,7 +1423,7 @@ Known problems of the automatic translation
   new scheme for syntactic extensions (see translator documentation)
 - Unsafe for annotation Cases when constructors coercions are used or when
   annotations are eta-reduced predicates
- 
+
 
 Changes from V7.4 to V8.0beta old syntax
 ========================================
@@ -1387,7 +1491,7 @@ Grammar extensions
 Library
 
 - New file about the factorial function in Arith
-- An additional elimination Acc_iter for Acc, simplier than Acc_rect. 
+- An additional elimination Acc_iter for Acc, simplier than Acc_rect.
   This new elimination principle is used for definition well_founded_induction.
 - New library NArith on binary natural numbers
 - R is now of type Set
@@ -1399,7 +1503,7 @@ Library
   - Several lemmas moved from auxiliary.v and zarith_aux.v to
   fast_integer.v (theoretical source of incompatibilities)
   - Variables names of iff_trans changed (source of incompatibilities)
-  - ZArith lemmas named OMEGA something or fast_ something, and lemma new_var 
+  - ZArith lemmas named OMEGA something or fast_ something, and lemma new_var
     are now out of ZArith (except OMEGA2)
   - Redundant ZArith lemmas have been renamed: for the following pairs,
   use the second name (Zle_Zmult_right2, Zle_mult_simpl), (OMEGA2,
@@ -1454,10 +1558,10 @@ Tactics
 Extraction (See details in plugins/extraction/CHANGES)
 
 - The old commands: 	(Recursive) Extraction Module M.
-  are now:              (Recursive) Extraction Library M. 
-  To use these commands, M should come from a library M.v 
-- The other syntax Extraction & Recursive Extraction now accept 
-  module names as arguments. 
+  are now:              (Recursive) Extraction Library M.
+  To use these commands, M should come from a library M.v
+- The other syntax Extraction & Recursive Extraction now accept
+  module names as arguments.
 
 Bugs
 
@@ -1483,7 +1587,7 @@ Incompatibilities
   cause "Apply/Rewrite with" to fail if using the first name of a pair
   of redundant lemmas (this is solved by renaming the variables bound by
   "with"; 3 incompatibilities in Coq user contribs)
-- ML programs referring to constants from fast_integer.v must use 
+- ML programs referring to constants from fast_integer.v must use
   "Coqlib.gen_constant_modules Coqlib.zarith_base_modules" instead
 
 Changes from V7.3.1 to V7.4
@@ -1498,14 +1602,14 @@ Symbolic notations
 - Declarations with only implicit arguments now handled (e.g. the
   argument of nil can be set implicit; use !nil to refer to nil
   without arguments)
-- "Print Scope sc" and "Locate ntn" allows to know to what expression a 
+- "Print Scope sc" and "Locate ntn" allows to know to what expression a
   notation is bound
 - New defensive strategy for printing or not implicit arguments to ensure
   re-type-checkability of the printed term
 - In Grammar command, the only predefined non-terminal entries are ident,
   global, constr and pattern (e.g. nvar, numarg disappears); the only
   allowed grammar types are constr and pattern; ast and ast list are no
-  longer supported; some incompatibilities in Grammar: when a syntax is a 
+  longer supported; some incompatibilities in Grammar: when a syntax is a
   initial segment of an other one,  Grammar does not work, use Notation
 
 Library
@@ -1583,7 +1687,7 @@ Tactics
   it can also recognize 'False' in the hypothesis and use it to solve the
   goal.
 - Coercions now handled in "with" bindings
-- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses 
+- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses
    when an hypothesis x=t or x:=t or t=x exists
 - Fresh names for Assert and Pose now based on collision-avoiding
   Intro naming strategy (exceptional source of incompatibilities)
@@ -1594,7 +1698,7 @@ Tactics
 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, 
+- Concerning Ocaml, extracted code is now ensured to always type-check,
   thanks to automatic inserting of Obj.magic.
 - Experimental extraction of Coq new modules to Ocaml modules.
 
@@ -1624,7 +1728,7 @@ Incompatibilities
   longer supported, use TACTIC EXTEND and VERNAC COMMAND EXTEND on the
   ML-side instead
 - Transparency of le_lt_dec and co (leads to some simplification in
-  proofs; in some cases, incompatibilites is solved by declaring locally 
+  proofs; in some cases, incompatibilites is solved by declaring locally
   opaque the relevant constant)
 - Opaque Local do not now survive section closing (rename them into
   Remark/Lemma/... to get them still surviving the sections; this
@@ -1663,7 +1767,7 @@ Bug fixes
 Misc
 
   - Ocaml version >= 3.06 is needed to compile Coq from sources
-  - Simplification of fresh names creation strategy for Assert, Pose and 
+  - Simplification of fresh names creation strategy for Assert, Pose and
     LetTac (PR#192)
 
 Changes from V7.2 to V7.3
@@ -1693,7 +1797,7 @@ Tactics
 - Intuition does no longer unfold constants except "<->" and "~". It
   can be parameterized by a tactic. It also can introduce dependent
   product if needed (source of incompatibilities)
-- "Match Context" now matching more recent hypotheses first and failing only 
+- "Match Context" now matching more recent hypotheses first and failing only
   on user errors and Fail tactic (possible source of incompatibilities)
 - Tactic Definition's without arguments now allowed in Coq states
 - Better simplification and discrimination made by Inversion (source
@@ -1709,7 +1813,7 @@ Bugs
 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).  
+- Haskell extraction is now operational (tested & debugged).
 
 Standard library
 
@@ -1721,8 +1825,8 @@ Standard library
 
 Tools
 
-- new option -dump-glob to coqtop to dump globalizations (to be used by the 
-  new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc) 
+- new option -dump-glob to coqtop to dump globalizations (to be used by the
+  new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc)
 
 User Contributions
 
@@ -1731,7 +1835,7 @@ User Contributions
 - MapleMode (an interface to embed Maple simplification procedures over
   rational fractions in Coq)
   [David Delahaye, Micaela Mayero, Chalmers University]
-- Presburger: A formalization of Presburger's algorithm 
+- Presburger: A formalization of Presburger's algorithm
   [Laurent Thery, INRIA Sophia Antipolis]
 - Chinese has been rewritten using Z from ZArith as datatype
   ZChinese is the new version, Chinese the obsolete one
@@ -1767,7 +1871,7 @@ Language
   let-in style)
 - Coercions allowed in Cases patterns
 - New declaration "Canonical Structure id = t : I" to help resolution of
-  equations of the form (proj ?)=a; if proj(e)=a then a is canonically 
+  equations of the form (proj ?)=a; if proj(e)=a then a is canonically
   equipped with the remaining fields in e, i.e. ? is instantiated by e
 
 Tactics
@@ -1779,14 +1883,14 @@ Tactics
 
 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. 
-- More optimizations on extracted code. 
-- Extraction tests are now embedded in 14 user contributions. 
+- Syntax changes: there are no more options inside the extraction commands.
+  New commands for customization and options have been introduced instead.
+- More optimizations on extracted code.
+- Extraction tests are now embedded in 14 user contributions.
 
 Standard library
 
-- In [Relations], Rstar.v and Newman.v now axiom-free. 
+- In [Relations], Rstar.v and Newman.v now axiom-free.
 - In [Sets], Integers.v now based on nat
 - In [Arith], more lemmas in Min.v, new file Max.v, tail-recursive
   plus and mult added to Plus.v and Mult.v respectively
@@ -1862,7 +1966,7 @@ Language: new "let-in" construction
 
 - New construction for local definitions (let-in) with syntax [x:=u]t (*)(+)
 
-- Local definitions allowed in Record (a.k.a. record à la Randy Pollack)
+- Local definitions allowed in Record (a.k.a. record à la Randy Pollack)
 
 
 Language: long names
@@ -1948,7 +2052,7 @@ New tactics
   restrictions in the reference manual)
 
 - New tactic ROmega: an experimental alternative (based on reflexion) to Omega
-  [by P. Crégut]
+  [by P. Crégut]
 
 - New tactic language Ltac (see reference manual) (+)
 
@@ -1991,7 +2095,7 @@ Changes in existing tactics
   an elimination schema, use "Elim <hyp> using <name of the new schema>"
   (*)(+)
 
-- Simpl no longer unfolds the recursive calls of a mutually defined 
+- Simpl no longer unfolds the recursive calls of a mutually defined
   fixpoint (*)(+)
 
 - Intro now fails if the hypothesis name already exists (*)(+)
@@ -2041,7 +2145,7 @@ Concrete syntax of constructions
 Parsing and grammar extension
 -----------------------------
 
-- More constraints when writing ast 
+- More constraints when writing ast
 
   - "{...}" and the macros $LIST, $VAR, etc. now expect a metavariable
     (an identifier starting with $) (*)
@@ -2097,7 +2201,7 @@ Changes in existing commands
 ----------------------------
 
 - Generalization of the usage of qualified identifiers in tactics
-  and commands about globals, e.g. Decompose, Eval Delta; 
+  and commands about globals, e.g. Decompose, Eval Delta;
   Hints Unfold, Transparent, Require
 
 - Require synchronous with Reset; Require's scope stops at Section ending (*)
@@ -2157,7 +2261,7 @@ Extraction
 ----------
 
 - New algorithm for extraction able to deal with "Type" (+)
-  (by J.-C. Filliâtre and P. Letouzey)
+  (by J.-C. Filliâtre and P. Letouzey)
 
 
 Standard library
@@ -2184,7 +2288,7 @@ New user contributions
 
 - Basic notions of graph theory [GRAPHS-BASICS] (Jean Duprat, Lyon)
 
-- A library for floating-point numbers [Float] (Laurent Théry, Sylvie Boldo,
+- A library for floating-point numbers [Float] (Laurent Théry, Sylvie Boldo,
   Sophia-Antipolis)
 
 - Formalisation of CTL and TCTL temporal logic [CtlTctl] (Carlos
@@ -2196,15 +2300,15 @@ New user contributions
 - P-automaton and the ABR algorithm [PAutomata]
   (Christine Paulin, Emmanuel Freund, Orsay)
 
-- Semantics of a subset of the C language [MiniC] 
-  (Eduardo Giménez, Emmanuel Ledinot, Suresnes) 
+- Semantics of a subset of the C language [MiniC]
+  (Eduardo Giménez, Emmanuel Ledinot, Suresnes)
 
 - Correctness proofs of the following imperative algorithms:
-  Bresenham line drawing algorithm [Bresenham], Marché's minimal edition
-  distance algorithm [Diff] (Jean-Christophe Filliâtre, Orsay)
+  Bresenham line drawing algorithm [Bresenham], Marché's minimal edition
+  distance algorithm [Diff] (Jean-Christophe Filliâtre, Orsay)
 
 - Correctness proofs of Buchberger's algorithm [Buchberger] and RSA
-  cryptographic algorithm [Rsa] (Laurent Théry, Sophia-Antipolis)
+  cryptographic algorithm [Rsa] (Laurent Théry, Sophia-Antipolis)
 
 - Correctness proof of Stalmarck tautology checker algorithm
-  [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis)
+  [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis)
diff --git a/COMPATIBILITY b/COMPATIBILITY
index 4cc8b589..0849b64f 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -1,52 +1,6 @@
-Potential sources of incompatibilities between Coq V8.2 and V8.3
+Potential sources of incompatibilities between Coq V8.3 and V8.4
 ----------------------------------------------------------------
 
 (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.
-
-Type inference
-
-- Many changes in using classes.
-
-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.
-
-- Reorganisation of library (esp. FSets, Sorting, Numbers) may have
-  changed or removed names around.
-
-- Infix notation "++" has now to be set at level 60. [LinAlg]
-
-- When using the Programs library or any feature that uses it,
-  (lemmas about measure have a different form, ...).
-
-Tactics
-
-- 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).
-
-- More checks in some commands (e.g. in Hint) may lead to forbid some
-  meaningless part of them.
-
-- When rewriting using setoid equality, the default equality found
-  might be different.
+TO BE DONE
diff --git a/COPYRIGHT b/COPYRIGHT
index 4609c167..8d81d8c4 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -1,12 +1,12 @@
                      The Coq proof assistant
 
-Copyright 1999-2011 The Coq development team, INRIA, CNRS, University
+Copyright 1999-2010 The Coq development team, INRIA, CNRS, University
 Paris Sud, University Paris 7, Ecole Polytechnique.
 
 This product includes also software developed by
   Pierre Crégut, France Telecom R & D (plugins/omega and plugins/romega)
   Pierre Courtieu and Julien Forest, CNAM (plugins/funind)
-  Claudio Sacerdoti Coen, HELM, University of Bologna (plugins/xml)
+  Claudio Sacerdoti Coen, HELM, University of Bologna, (plugins/xml)
   Pierre Corbineau, Radbout University, Nijmegen (declarative mode)
   John Harrison, University of Cambridge (csdp wrapper)
 
diff --git a/CREDITS b/CREDITS
index d20fbce2..53bd9e93 100644
--- a/CREDITS
+++ b/CREDITS
@@ -16,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-2011,
+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.
diff --git a/INSTALL b/INSTALL
index b1cc3af1..e88dc319 100644
--- a/INSTALL
+++ b/INSTALL
@@ -15,8 +15,8 @@ WHAT DO YOU NEED ?
    ppc) and FreeBSD. Automated tests are run under many, many
    different architectures under GNU/Linux.
 
-   Naturally, Coq will run faster on an architecture where Objective Caml
-   can compile to native code, rather than only bytecode. At time of
+   Naturally, Coq will run faster on an architecture where OCaml can
+   compile to native code, rather than only bytecode. At time of
    writing, that is IA32, PowerPC, AMD64, Alpha, Sparc, Mips, IA64,
    HPPA and StrongArm. See
    http://caml.inria.fr/ocaml/portability.en.html for details.
@@ -39,16 +39,12 @@ WHAT DO YOU NEED ?
 
      urpmi coq
 
-   Should you need or prefer to compile Coq V8.3 yourself, you need:
+   Should you need or prefer to compile Coq V8.2 yourself, you need:
 
-     - Objective Caml version 3.10.2 or later
+     - Objective Caml version 3.10.0 or later
        (available at http://caml.inria.fr/)
 
-       For Objective Caml version >= 3.10.0, you also need to install
-       camlp5 (use "transitional" mode and choose a version compatible
-       with the corresponding version of Objective Caml, however
-       avoiding version 5.00)
-  
+     - Camlp5 (version <= 4.08, or 5.* transitional)
 
      - GNU Make version 3.81 or later
        (
@@ -75,6 +71,9 @@ WHAT DO YOU NEED ?
 
      - for Coqide, the Lablgtk development files, and the GTK libraries, see INSTALL.ide for more details
 
+   By FTP, Coq comes as a single compressed tar-file. You have
+   probably already decompressed it if you are reading this document.
+
 
 QUICK INSTALLATION PROCEDURE.
 =============================
@@ -88,7 +87,7 @@ QUICK INSTALLATION PROCEDURE.
 INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 =================================================
 
-1- Check that you have the Objective Caml compiler version 3.10.2 (or later)
+1- Check that you have the Objective Caml compiler version 3.10.0 (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. 
@@ -98,16 +97,23 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
    bigger), you will also need the "ocamlopt" (or its native code version
    "ocamlopt.opt") command.
 
-2- If using Ocaml >= 3.10, check that you have Camlp5 installed on your
-   computer and that the command "camlp5" lies in a directory which
+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 Camlp5 in transitional mode and in both bytecode and
-   native versions if your platform supports it).
+   (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.
 
-2- You will need about 400Mo free on your disk to compile Coq in full
-   with its standard library and documentation.
+3- The uncompression and un-tarring of the distribution file gave birth 
+   to a directory named "coq-8.xx". You can rename this directory and put 
+   it wherever you want. Just keep in mind that you will need some spare
+   space during the compilation (reckon on about 50 Mb of disk space
+   for the whole system in native-code compilation). Once installed, the
+   binaries take about 14 Mb, and the library about 9 Mb.
 
-3- First you need to configure the system. It is done automatically with
+4- First you need to configure the system. It is done automatically with
    the command:
 
 	./configure <options>
@@ -201,7 +207,7 @@ INSTALLATION PROCEDURE FOR ADVANCED USERS.
    binaries will reside in the subdirectory bin/.
 
    If you want to compile the sources for debugging (i.e. with the option
-   -g of the ocaml compiler) then add the -debug option at configuration
+   -g of the Caml compiler) then add the -debug option at configuration
    step :
 
 	./configure -debug <other options>
@@ -316,7 +322,7 @@ MOVING BINARIES OR LIBRARY.
 DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES.
 ======================================================
 
-   Some bytecode executables of Coq use the ocaml runtime, which dynamically
+   Some bytecode executables of Coq use the OCaml runtime, which dynamically
    loads a shared library (.so or .dll). When it is not installed properly, you
    can get an error message of this kind:
 
@@ -329,12 +335,12 @@ DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES.
        the command a limited number of times in a controlled environment (e.g.
        during compilation of binary packages);
      - install dllcoqrun.so in a location listed in the file ld.conf that is in
-       the directory of the standard library of Objective Caml;
+       the directory of the standard library of OCaml;
      - recompile your bytecode executables after reconfiguring the location of
        of the shared library:
          ./configure -coqrunbyteflags "-dllib -lcoqrun -dllpath <path>" ...
        where <path> is the directory where the dllcoqrun.so is installed;
-     - (not recommended) compile bytecode executables with a custom ocaml
+     - (not recommended) compile bytecode executables with a custom OCaml
        runtime by using:
          ./configure -custom ...
        be aware that stripping executables generated this way, or performing
diff --git a/INSTALL.ide b/INSTALL.ide
index e99002f0..300d17b1 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.10.2 with native threads support.
+	- OCaml >= 3.11 with native threads support.
 	- make world must succeed.
 	- The graphical toolkit GTK+ 2.x. See http://www.gtk.org.
 	  The official supported version is at least 2.10.x.
@@ -42,7 +42,7 @@ REQUIREMENT:
 
         - The OCaml bindings for GTK+ 2.x, lablgtk2.
 
-	  You need at least version 2.10.0.
+	  You need at least version 2.12.0.
 
 	  Your distribution may contain precompiled packages. For
           example, for Debian, run
@@ -104,17 +104,14 @@ INSTALLATION
 
 
 NOTES
-There are three configuration files located in your $(HOME) dir. 
+There are three configuration files located in your $(XDG_CONFIG_HOME)/coq dir.
  You may need to set HOME to some sensible value under Windows.
 
-- .coqiderc is generated by coqide itself. It may be edited by hand or 
+- coqiderc is generated by coqide itself. It may be edited by hand or 
   by using the Preference menu from coqide. It will be generated the first time
   you save your the preferences in Coqide.
 
-- .coqide-gtk2rc is a standard Gtk2 configuration file. A sample file can be
-  found in the coq lib "ide" subdir.
-
-- .coqide.keys is a standard Gtk2 accelerator dump. You may edit this file 
+- coqide.keys is a standard Gtk2 accelerator dump. You may edit this file 
   to change the default shortcuts for the menus.
 
 Read ide/FAQ for more informations.
@@ -127,8 +124,8 @@ TROUBLESHOOTING
     Some users may experiment problems with unwanted automatic
     templates while using Coqide. This is due to a change in the
     modifiers keys available through GTK. The straightest way to get
-    rid of the problem is to edit by hand your .coqiderc (either
-    /home/<user>/.coqiderc under Linux, or 
-    C:\Documents and Settings\<user>\.coqiderc under Windows) 
+    rid of the problem is to edit by hand your coqiderc (either
+    /home/<user>/.config/coq/coqiderc under Linux, or 
+    C:\Documents and Settings\<user>\.config\coq\coqiderc under Windows) 
     and replace any occurence of MOD4 by MOD1.
 
diff --git a/INSTALL.macosx b/INSTALL.macosx
index 43390616..cc1317b1 100644
--- a/INSTALL.macosx
+++ b/INSTALL.macosx
@@ -1,30 +1,20 @@
-INSTALLATION PROCEDURE FOR THE PRECOMPILED VERSION OF COQ SYSTEM UNDER MACOS X
-------------------------------------------------------------------------------
+INSTALLATION PROCEDURE FOR THE PRECOMPILED COQ V8.1 SYSTEM UNDER MACOS X
+------------------------------------------------------------------------
 
-Here comes an bundle version of CoqIdE that you can save anywhere you want on
-your disk.
+You can also use fink, or the MacOS X package prepared by the Coq
+team. To use the MacOS X package,:
 
-Its main limitation is that double clicking and drap&drop on the application
-icon of a .v file won't open the file ! You must use Menu/Ctrl-o to open a
-file. (GTK-OSX handles it but lablgtk don't as far as I know.)
+1) Download archive coq-8.1-macosx-ppc.dmg (for PowerPC-base computer)
+   or coq-8.1-macosx-i386.dmg (for Pentium-based computer).
 
-An other limitation is that Sortcut aren't MacOS like ! (The question is again
-how to make "" throw CaML.)
+2) Double-click on its icon; it mounts a disk volume named "Coq V8.1".
 
-Notice that "Compile" and "File"/"Export to" menu items should work (modulo
-(pdf)latex finding).
+3) Open volume "Coq 8.1" and double-click on coq-8.1.pkg to launch the
+   installer (you'll need administrator permissions).
 
-if you want to use coqide from your terminal add
- 
-alias coqide /YOUR_INSTALL_DIRECTORY/CoqIdEv8.3.app/Contents/MacOS/startcoqide 
+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.
 
-at your ~/.profile. ("YOUR_INSTALL_DIRECTORY" is often "Applications"). Options
-such as -I/-R should work on this setting.
-
-You could also add
-/YOUR_INSTALL_DIRECTORY/CoqIdEv8.3.app/Contents/Resources/bin/ at your path to
-use coqtop/coq-tex/coq... from any terminal but CAUTION coqide of that directory
-won't work.
-
-
-See up-to-date informations on http://coq.inria.fr/download.
+If you have any trouble with this installation, please contact:
+coq-bugs@pauillac.inria.fr.
diff --git a/Makefile b/Makefile
index 97afdfd6..876ac583 100644
--- a/Makefile
+++ b/Makefile
@@ -6,65 +6,38 @@
 #         #       GNU Lesser General Public License Version 2.1       #
 #######################################################################
 
-# $Id: Makefile 14090 2011-05-03 13:34:16Z pboutill $ 
-
 
 # Makefile for Coq
 #
-# To be used with GNU Make.
+# To be used with GNU Make >= 3.81.
 #
-# 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
+# This Makefile is now separated into Makefile.{common,build,doc}.
+# 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://miller.emu.id.au/pmiller/books/rmch/
 # before complaining.
 # 
 # When you are working in a subdir, you can compile without moving to the
 # upper directory using "make -C ..", and the output is still understood
 # by Emacs' next-error.
-###########################################################################
-
-
-# Specific command-line options to this Makefile
 #
-# make GOTO_STAGE=N        # perform only stage N (with N=1,2)
+# Specific command-line options to this Makefile:
+#
 # 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
+#
+# ----------------------------------------------------------------------
+# See dev/doc/build-system*.txt for more details/FAQ about this Makefile
+# ----------------------------------------------------------------------
 
 
-# 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*
+###########################################################################
+# File lists
+###########################################################################
 
 # !! Before using FIND_VCS_CLAUSE, please read how you should in the !!
 # !! FIND_VCS_CLAUSE section of dev/doc/build-system.dev.txt         !!
@@ -78,41 +51,63 @@ export FIND_VCS_CLAUSE:='(' \
   -name "$${GIT_DIR}" -o \
   -name '_build' \
 ')' -prune -o
-export PRUNE_CHECKER := -wholename ./checker/\* -prune -o
 
-FIND_PRINTF_P:=-print | sed 's|^\./||'
+define find
+ $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||')
+endef
+
+## Files in the source tree
+
+export YACCFILES:=$(call find, '*.mly')
+export LEXFILES := $(call find, '*.mll')
+export MLLIBFILES := $(call find, '*.mllib')
+export ML4FILES := $(call find, '*.ml4')
+export CFILES := $(call find, '*.c')
+
+# NB: The lists of currently existing .ml and .mli files will change
+# before and after a build or a make clean. Hence we do not export
+# these variables, but cleaned-up versions (see below MLFILES and co)
+
+EXISTINGML := $(call find, '*.ml')
+EXISTINGMLI := $(call find, '*.mli')
+
+## Files that will be generated
 
-export YACCFILES:=$(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.mly' ')' $(FIND_PRINTF_P))
-export LEXFILES := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.mll' ')' $(FIND_PRINTF_P))
 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_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) \
-  $(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' ')' -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
+export GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml))
+export GENML4FILES:= $(ML4FILES:.ml4=.ml)
+export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES) $(GENPLUGINSMOD)
+
+# NB: all files in $(GENFILES) can be created initially, while
+# .ml files in $(GENML4FILES) might need some intermediate building.
+# That's why we keep $(GENML4FILES) out of $(GENFILES)
+
+## More complex file lists
+
+define diff
+ $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f)))
+endef
+
+export MLSTATICFILES := \
+ $(call diff, $(EXISTINGML), $(GENMLFILES) $(GENML4FILES) $(GENPLUGINSMOD))
+export MLFILES := \
+ $(sort $(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(GENPLUGINSMOD))
+export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI))
+export MLWITHOUTMLI := $(call diff, $(MLFILES), $(MLIFILES:.mli=.ml))
 
 include Makefile.common
 
-NOARG: world
+###########################################################################
+# Starting rules
+###########################################################################
 
-.PHONY: NOARG help always tags otags
+NOARG: world
 
-always: ;
+.PHONY: NOARG help always
 
 help:
 	@echo "Please use either"
@@ -124,76 +119,44 @@ help:
 	@echo
 	@echo "For make to be verbose, add VERBOSE=1"
 
-ifdef COQ_CONFIGURED
-define stage-template
-	@echo '*****************************************************'
-	@echo '*****************************************************'
-	@echo '****************** Entering stage$(1) ******************'
-	@echo '*****************************************************'
-	@echo '*****************************************************'
-	+$(MAKE) $(MAKEFLGS) -f Makefile.stage$(1) "$@"
-endef
-else
-define stage-template
-	@echo "Please run ./configure first" >&2; exit 1
-endef
-endif
-
-UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.mli' -o -name '.\#*.ml4')
+UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.ml?')
 ifdef UNSAVED_FILES
-$(error You have unsaved changes in your editor (emacs?) [$(UNSAVED_FILES)]; cancel them or save before proceeding. \
-Or your editor crashed. Then, you may want to consider whether you want to restore the autosaves)
+$(error You have unsaved changes in your editor (emacs?) [$(UNSAVED_FILES)]; \
+cancel them or save before proceeding. Or your editor crashed. \
+Then, you may want to consider whether you want to restore the autosaves)
 #If you try to simply remove this explicit test, the compilation may
 #fail later. In particular, if a .#*.v file exists, coqdep fails to
 #run.
 endif
 
-ifdef GOTO_STAGE
-config/Makefile Makefile.common Makefile.build Makefile: ;
+# Apart from clean and tags, everything will be done in a sub-call to make
+# on Makefile.build. This way, we avoid doing here the -include of .d :
+# since they trigger some compilations, we do not want them for a mere clean
 
-%: always
-	$(call stage-template,$(GOTO_STAGE))
+ifdef COQ_CONFIGURED
+%:: always
+	$(MAKE) --warn-undefined-variable --no-builtin-rules -f Makefile.build "$@"
 else
-
-.PHONY: stage1 stage2 world revision
-
-stage1 $(STAGE1_TARGETS) : always
-	$(call stage-template,1)
-
-ifneq (,$(STAGE1_IMPLICITS))
-$(STAGE1_IMPLICITS) : always
-	$(call stage-template,1)
-endif
-
-stage2 $(STAGE2_TARGETS) : stage1
-	$(call stage-template,2)
-
-ifneq (,$(STAGE2_IMPLICITS))
-$(STAGE2_IMPLICITS) : stage1
-	$(call stage-template,2)
+%:: always
+	@echo "Please run ./configure first" >&2; exit 1
 endif
 
-# 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
-
+always : ;
 
-# This is to remove the built-in rule "%: %.o" :
-%: %.o
-# Otherwise, "make foo" recurses into stage1, trying to build foo.o .
+# To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles
 
-endif #GOTO_STAGE
+Makefile Makefile.build Makefile.common config/Makefile : ;
 
 ###########################################################################
 # Cleaning
 ###########################################################################
 
-.PHONY: clean objclean cruftclean indepclean archclean ml4clean clean-ide ml4depclean depclean distclean cleanconfig cleantheories docclean devdocclean
+.PHONY: clean cleankeepvo objclean cruftclean indepclean doclean archclean optclean clean-ide ml4clean ml4depclean depclean cleanconfig distclean voclean devdocclean
 
 clean: objclean cruftclean depclean docclean devdocclean
 
+cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean devdocclean
+
 objclean: archclean indepclean
 
 cruftclean: ml4clean
@@ -202,10 +165,8 @@ cruftclean: ml4clean
 
 indepclean:
 	rm -f $(GENFILES)
-	rm -f $(COQTOPBYTE) $(COQMKTOPBYTE) $(COQCBYTE) $(CHICKENBYTE)
+	rm -f $(COQTOPBYTE) $(COQMKTOPBYTE) $(COQCBYTE) $(CHICKENBYTE) bin/fake_ide
 	find . -name '*~' -o -name '*.cm[ioa]' | xargs rm -f
-	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
@@ -221,33 +182,34 @@ docclean:
 	doc/*/*.hatoc doc/*/*.haux doc/*/*.hcomind doc/*/*.herrind doc/*/*.hidx doc/*/*.hind \
 	doc/*/*.htacind doc/*/*.htoc doc/*/*.v.html
 	rm -f doc/stdlib/index-list.html doc/stdlib/index-body.html \
-	  doc/stdlib/Library.coqdoc.tex doc/stdlib/library.files \
-	  doc/stdlib/library.files.ls
-	rm -f doc/*/*.ps doc/*/*.pdf 
+	  doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \
+	  doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex
+	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/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/Reference-Manual.html
 	rm -f doc/coq.tex
-	rm -f doc/refman/styles.hva doc/refman/cover.html 
 
-archclean: clean-ide cleantheories
+archclean: clean-ide optclean voclean
+	rm -rf _build myocamlbuild_config.ml
+	rm -f $(ALLSTDLIB).*
+
+optclean:
 	rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT)
 	rm -f $(COQTOPOPT) $(COQMKTOPOPT) $(COQCOPT) $(CHICKENOPT)
-	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
+	find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f
 
 clean-ide:
 	rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
 	rm -f 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/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml
 	rm -f ide/utf8_convert.ml
 
 ml4clean:
-	rm -f $(ML4FILESML) $(ML4FILESML:.ml=.ml4-preprocessed)
+	rm -f $(GENML4FILES)
 
 ml4depclean:
 	find . -name '*.ml4.d' | xargs rm -f
@@ -261,19 +223,24 @@ cleanconfig:
 distclean: clean cleanconfig
 	$(MAKE) -C test-suite distclean
 
-cleantheories:
+voclean:
 	rm -f states/*.coq
-	find theories -name '*.vo' -o -name '*.glob' | xargs rm -f
+	find theories plugins test-suite -name '*.vo' -o -name '*.glob' | xargs rm -f
 
 devdocclean:
-	find . -name '*.dep.ps' -o -name '*.dot' -exec rm -f {} \;
+	find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f
+	rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc 
+	rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex 
+	rm -f $(OCAMLDOCDIR)/html/*.html
 
 ###########################################################################
 # Emacs tags
 ###########################################################################
 
+.PHONY: tags otags
+
 tags:
-	echo $(MLIFILES) $(MLFILES) $(ML4FILES) | sort -r | xargs \
+	echo $(MLIFILES) $(MLSTATICFILES) $(ML4FILES) | sort -r | xargs \
 	etags --language=none\
 	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
@@ -288,7 +255,7 @@ tags:
 
 
 otags: 
-	echo $(MLIFILES) $(MLFILES) | sort -r | xargs otags
+	echo $(MLIFILES) $(MLSTATICFILES) | sort -r | xargs otags
 	echo $(ML4FILES) | sort -r | xargs \
 	etags --append --language=none\
 	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
diff --git a/Makefile.build b/Makefile.build
index 717fcf20..59ee457c 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -1,4 +1,4 @@
-######################################################################
+#######################################################################
 #  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
 # <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              #
 #   \VV/  #############################################################
@@ -6,59 +6,79 @@
 #         #       GNU Lesser General Public License Version 2.1       #
 #######################################################################
 
-# $Id: Makefile.build 14090 2011-05-03 13:34:16Z pboutill $ 
-
+# This makefile is normally called by the main Makefile after setting
+# some variables.
 
-# Makefile for Coq
-#
-# To be used with GNU Make.
-#
-# 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
-# before complaining.
-# 
-# When you are working in a subdir, you can compile without moving to the
-# upper directory using "make -C ..", and the output is still understood
-# by Emacs' next-error.
 ###########################################################################
-
-include Makefile.common
-ifndef COQ_CONFIGURED
- $(error Please run ./configure first)
-endif
-
-.PHONY: NOARG
-
-NOARG: world
+# Starting rule
+###########################################################################
 
 # build and install the three subsystems: coq, coqide
 world: revision coq coqide
 install: install-coq install-coqide
 
+.PHONY: world install
+
+###########################################################################
+# Includes
+###########################################################################
+
+include Makefile.common
+include Makefile.doc
+
 ifeq ($(WITHDOC),all)
 world: doc
 install: install-doc
 endif
 
-#install-manpages: install-coq-manpages
+# All dependency includes must be declared secondary, otherwise make will
+# delete them if it decided to build them by dependency instead of because
+# of include, and they will then be automatically deleted, leading to an
+# infinite loop.
+
+ALLDEPS=$(addsuffix .d, \
+  $(ML4FILES) $(MLFILES) $(MLIFILES) $(CFILES) $(MLLIBFILES) $(VFILES))
+
+.SECONDARY: $(ALLDEPS) $(GENFILES) $(GENML4FILES)
+
+# NOTA: the -include below will lauch the build of all .d. Some of them
+# will _fail_ at first, this is to be expected (no grammar.cma initially).
+# These errors (see below "not ready yet") do not discourage make to
+# try again and finally succeed.
+
+-include $(ALLDEPS)
+
 
 ###########################################################################
 # Compilation options
 ###########################################################################
 
+# Variables meant to be modifiable via the command-line of make
+
+VERBOSE=
+NO_RECOMPILE_ML4=
+NO_RECOMPILE_LIB=
+NO_RECALC_DEPS=
+READABLE_ML4=	# non-empty means .ml of .ml4 will be ascii instead of binary
+VALIDATE=
+COQ_XML=	# is "-xml" when building XML library
+VM=		# is "-no-vm" to not use the vm"
+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)"
+
+COQOPTS=$(COQ_XML) $(VM)
+BOOTCOQTOP:=$(TIMECMD) $(BESTCOQTOP) -boot $(COQOPTS)
+BOOTCOQC:=$(BOOTCOQTOP) -compile
+
 # The SHOW and HIDE variables control whether make will echo complete commands 
 # or only abbreviated versions. 
 # Quiet mode is ON by default except if VERBOSE=1 option is given to make
 
-ifdef VERBOSE
- SHOW = @true ""
- HIDE = 
-else 
- SHOW = @echo ""
- HIDE = @
-endif
+SHOW := $(if $(VERBOSE),@true "",@echo "")
+HIDE := $(if $(VERBOSE),,@)
 
 LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) )
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
@@ -70,21 +90,30 @@ BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) $(USERFLAGS)
 OPTFLAGS=$(MLINCLUDES) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
 DEPFLAGS= -slash $(LOCALINCLUDES)
 
-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'
+define bestocaml
+$(if $(OPT),\
+$(OCAMLOPT) $(OPTFLAGS) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@,\
+$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(1) $(addsuffix .cma,$(2)) $^)
+endef
 
-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
-COQOPTS=$(COQ_XML) $(VM) $(UNBOXEDVALUES)
-TIMECMD=	# is "'time -p'" to get compilation time of .v
+CAMLP4DEPS=`sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*@\1@p' $<`
+ifeq ($(CAMLP4),camlp5)
+CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION)
+else
+CAMLP4USE=-D$(CAMLVERSION)
+endif
 
-# 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)"
+PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) # works also with new camlp4
+
+ifeq ($(CAMLP4),camlp5)
+SYSMOD:=str unix gramlib
+else
+SYSMOD:=str unix dynlink camlp4lib
+endif
+
+SYSCMA:=$(addsuffix .cma,$(SYSMOD))
+SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD))
 
-BOOTCOQTOP:=$(TIMECMD) $(BESTCOQTOP) -boot $(COQOPTS)
 
 ###########################################################################
 # Infrastructure for the rest of the Makefile
@@ -125,6 +154,13 @@ else
   D_DEPEND_AFTER_SRC:=|
 endif
 
+## When a rule redirects stdout of a command to the target file : cmd > $@
+## then the target file will be created even if cmd has failed.
+## Hence relaunching make will go further, as make thinks the target has been
+## done ok. To avoid this, we use the following macro:
+
+TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV})
+
 ###########################################################################
 # Compilation option for .c files 
 ###########################################################################
@@ -141,22 +177,19 @@ $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN)
 #coq_jumptbl.h is required only if you have GCC 2.0 or later
 kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h
 	sed -n -e '/^  /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \
-               -e '/^}/q' kernel/byterun/coq_instruct.h > \
-                          kernel/byterun/coq_jumptbl.h \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+               -e '/^}/q' $< $(TOTARGET)
 
 kernel/copcodes.ml: kernel/byterun/coq_instruct.h
-	sed -n -e '/^enum/p' -e 's/,//g' -e '/^  /p' \
-	kernel/byterun/coq_instruct.h | \
-	awk -f kernel/make-opcodes > kernel/copcodes.ml \
-	|| ( RV=$$?; rm -f "$@"; exit $${RV} )
-
+	sed -n -e '/^enum/p' -e 's/,//g' -e '/^  /p' $< | \
+	awk -f kernel/make-opcodes $(TOTARGET)
 
 ###########################################################################
 # Main targets (coqmktop, coqtop.opt, coqtop.byte)
 ###########################################################################
 
-coqbinaries:: ${COQBINARIES} ${CSDPCERT}
+.PHONY: coqbinaries coq coqlib coqlight states
+
+coqbinaries:: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE}
 
 coq: coqlib tools coqbinaries
 
@@ -166,14 +199,14 @@ coqlight: theories-light tools coqbinaries
 
 states:: states/initial.coq
 
-$(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN)
+$(COQTOPOPT): $(BESTCOQMKTOP) $(LINKCMX) $(LIBCOQRUN)
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) -o $@
+	$(HIDE)$(BESTCOQMKTOP) -boot -opt $(OPTFLAGS) -o $@
 	$(STRIP) $@
 
-$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN)
+$(COQTOPBYTE): $(BESTCOQMKTOP) $(LINKCMO) $(LIBCOQRUN)
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@
+	$(HIDE)$(BESTCOQMKTOP) -boot -top $(BYTEFLAGS) -o $@
 
 $(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP)
 	cd bin; ln -sf coqtop.$(BEST)$(EXE) coqtop$(EXE)
@@ -185,12 +218,12 @@ CHKOPTFLAGS:=$(CHKLIBS) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
 
 $(CHICKENOPT): checker/check.cmxa checker/main.ml
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa $^
+	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ $(SYSCMXA) $^
 	$(STRIP) $@
 
 $(CHICKENBYTE): checker/check.cma checker/main.ml
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $^
+	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(SYSCMA) $^
 
 $(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN)
 	cd bin && ln -sf coqchk.$(BEST)$(EXE) coqchk$(EXE)
@@ -199,13 +232,11 @@ $(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN)
 
 $(COQMKTOPBYTE): $(COQMKTOPCMO)
 	$(SHOW)'OCAMLC -o $@'	
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma\
-          $^ $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS)
 
-$(COQMKTOPOPT): $(COQMKTOPCMX)
+$(COQMKTOPOPT): $(COQMKTOPCMO:.cmo=.cmx)
 	$(SHOW)'OCAMLOPT -o $@'	
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa\
-          $^ $(OSDEPLIBS)
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS)
 	$(STRIP) $@
 
 $(COQMKTOP): $(ORDER_ONLY_SEP) $(BESTCOQMKTOP)
@@ -216,20 +247,19 @@ scripts/tolink.ml: Makefile.build Makefile.common
 	$(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@
 	$(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@
 	$(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@
-	$(HIDE)echo "let ide = \""$(IDEMOD)"\"" >> $@
 
 # coqc
 
-$(COQCBYTE): $(COQCCMO) $(COQTOPBYTE) $(BESTCOQTOP)
+$(COQCBYTE): $(COQCCMO) | $(COQTOPBYTE)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $(COQCCMO) $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS)
 
-$(COQCOPT): $(COQCCMX) $(COQTOPOPT) $(BESTCOQTOP)
+$(COQCOPT): $(COQCCMO:.cmo=.cmx) | $(COQTOPOPT)
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa $(COQCCMX) $(OSDEPLIBS)
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS)
 	$(STRIP) $@
 
-$(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC)
+$(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC) 
 	cd bin; ln -sf coqc.$(BEST)$(EXE) coqc$(EXE)
 
 # target for libraries
@@ -256,21 +286,16 @@ checker/check.cmxa: | checker/check.mllib.d
 # Csdp to micromega special targets
 ###########################################################################
 
-ifeq ($(BEST),opt)
-plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMX)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) nums.cmxa unix.cmxa -o $@ $^
-	$(STRIP) $@
-else
-plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) nums.cma unix.cma -o $@ $^
-endif
+plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,nums unix)
 
 ###########################################################################
 # CoqIde special targets
 ###########################################################################
 
+.PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files
+
 # target to build CoqIde
 coqide:: coqide-files coqide-binaries states
 
@@ -278,7 +303,7 @@ COQIDEFLAGS=-thread $(COQIDEINCLUDES)
 
 .SUFFIXES:.vo
 
-IDEFILES=ide/coq.png ide/.coqide-gtk2rc
+IDEFILES=ide/coq.png ide/coqide-gtk2rc ide/mac_default_accel_map
 
 coqide-binaries: coqide-$(HASCOQIDE)
 coqide-no:
@@ -286,75 +311,75 @@ coqide-byte: $(COQIDEBYTE) $(COQIDE)
 coqide-opt:  $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
 coqide-files: $(IDEFILES)
 
-$(COQIDEOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) ide/ide.cmxa
-	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -ide -opt $(OPTFLAGS) -o $@
+$(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) $(IDEOPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa\
+		 gtkThread.cmx str.cmxa $(LINKIDEOPT)
 	$(STRIP) $@
 
-$(COQIDEBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) ide/ide.cma
-	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -g -ide -top $(BYTEFLAGS) -o $@
+$(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\
+		str.cma $(COQRUNBYTEFLAGS) $(LINKIDE)
 
 $(COQIDE):
 	cd bin; ln -sf coqide.$(HASCOQIDE)$(EXE) coqide$(EXE)
 
-ide/%.cmo: ide/%.ml | ide/%.ml.d 
-	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
-
-ide/%.cmi: ide/%.mli | ide/%.mli.d
-	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
-
-ide/%.cmx: ide/%.ml | ide/%.ml.d
-	$(SHOW)'OCAMLOPT  $<'	
-	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
-
 # install targets
 
-FULLIDELIB=$(FULLCOQLIB)/ide
+.PHONY: install-coqide install-ide-no install-ide-byte install-ide-opt
+.PHONY: install-ide-files install-ide-info install-im
 
 install-coqide:: install-ide-$(HASCOQIDE) install-ide-files install-ide-info
 
 install-ide-no:
 
-install-ide-byte: 
+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"`
+	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
 	cd $(FULLBINDIR); ln -sf coqide.byte$(EXE) coqide$(EXE)
 
 install-ide-opt:
 	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQIDEBYTE) $(COQIDEOPT) $(FULLBINDIR)
+	$(INSTALLBIN) $(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"`
+	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
 	cd $(FULLBINDIR); ln -sf coqide.opt$(EXE) coqide$(EXE)
 
 install-ide-files:
-	$(MKDIR) $(FULLIDELIB)
-	$(INSTALLLIB) $(IDEFILES) $(FULLIDELIB)
+	$(MKDIR) $(FULLDATADIR)
+	$(INSTALLLIB) ide/coq.png $(FULLDATADIR)
+	$(MKDIR) $(FULLCONFIGDIR)
+	$(INSTALLLIB) ide/coqide-gtk2rc $(FULLCONFIGDIR)
+	if [ $(IDEOPTINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi
 
 install-ide-info:
-	$(MKDIR) $(FULLIDELIB)
-	$(INSTALLLIB) ide/FAQ $(FULLIDELIB)
+	$(MKDIR) $(FULLDOCDIR)
+	$(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde
 
 ###########################################################################
 # tests
 ###########################################################################
 
+.PHONY: validate check test-suite $(ALLSTDLIB).v
+
 VALIDOPTS=-silent -o -m
 
 validate:: $(BESTCHICKEN) $(ALLVO)
 	$(SHOW)'COQCHK <theories & plugins>'
 	$(HIDE)$(BESTCHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
 
+$(ALLSTDLIB).v:
+	$(SHOW)'MAKE $(notdir $@)'
+	$(HIDE)echo "Require $(ALLMODS)." > $@
+
 MAKE_TSOPTS=-C test-suite -s BEST=$(BEST) VERBOSE=$(VERBOSE)
 
 check:: validate test-suite
 
-test-suite: world
+test-suite: world $(ALLSTDLIB).v
 	$(MAKE) $(MAKE_TSOPTS) clean
 	$(MAKE) $(MAKE_TSOPTS) all
 	$(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi
@@ -363,6 +388,9 @@ test-suite: world
 # partial targets: 1) core ML parts
 ##################################################################
 
+.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
+.PHONY: highparsing toplevel hightactics
+
 lib: lib/lib.cma
 kernel: kernel/kernel.cma
 byterun: $(BYTERUN)
@@ -380,6 +408,10 @@ hightactics: tactics/hightactics.cma
 # 2) theories and plugins files
 ###########################################################################
 
+.PHONY: init theories theories-light
+.PHONY: logic arith bool narith zarith qarith lists strings sets
+.PHONY: fsets relations wellfounded reals setoids sorting numbers noreal
+
 init: $(INITVO)
 
 theories: $(THEORIESVO)
@@ -401,6 +433,11 @@ reals: $(REALSVO)
 setoids: $(SETOIDSVO)
 sorting: $(SORTINGVO)
 numbers: $(NUMBERSVO)
+unicode: $(UNICODEVO)
+classes: $(CLASSESVO)
+program: $(PROGRAMVO)
+structures: $(STRUCTURESVO)
+vectors: $(VECTORSVO)
 
 noreal: logic arith bool zarith qarith lists sets fsets relations \
 	wellfounded setoids sorting
@@ -409,6 +446,9 @@ noreal: logic arith bool zarith qarith lists sets fsets relations \
 # 3) plugins
 ###########################################################################
 
+.PHONY: plugins omega micromega ring setoid_ring nsatz dp xml extraction
+.PHONY: field fourier funind cc subtac rtauto pluginsopt
+
 plugins: $(PLUGINSVO)
 omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA)
 micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT)
@@ -425,6 +465,8 @@ cc: $(CCVO) $(CCCMA)
 subtac: $(SUBTACCMA)
 rtauto: $(RTAUTOVO) $(RTAUTOCMA)
 
+pluginsopt: $(PLUGINSOPT)
+
 ###########################################################################
 # rules to make theories, plugins and states
 ###########################################################################
@@ -436,97 +478,81 @@ 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) -nois -compile theories/Init/$*
+	$(HIDE)$(BOOTCOQC) theories/Init/$* -nois
 
 theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml
-	$(OCAML) $< > $@
+	$(OCAML) $< $(TOTARGET)
 
 ###########################################################################
 # tools
 ###########################################################################
 
+.PHONY: printers tools
+
 printers: $(DEBUGPRINTERS)
 
 tools:: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
 
-# coqdep_boot : a basic version of coqdep, with almost no dependencies
+# 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
+# Here it is important to mention .ml files instead of .cmo in order
+# to avoid using implicit rules and hence .ml.d files that would need
+# coqdep_boot.
+
+COQDEPBOOTSRC:= \
+  tools/coqdep_lexer.mli tools/coqdep_lexer.ml \
+  tools/coqdep_common.mli tools/coqdep_common.ml \
+  tools/coqdep_boot.ml
+
+$(COQDEPBOOT): $(COQDEPBOOTSRC)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, -I tools, unix)
 
 # the full coqdep
 
-ifeq ($(BEST),opt)
-$(COQDEP): $(COQDEPCMX)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa $^ $(OSDEPLIBS)
-	$(STRIP) $@
-else
-$(COQDEP): $(COQDEPCMO)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $^ $(OSDEPLIBS)
-endif
+$(COQDEP): $(COQDEPCMO:.cmo=$(BESTOBJ))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
-ifeq ($(BEST),opt)
-$(GALLINA): $(GALLINACMX)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(GALLINACMX)
-	$(STRIP) $@
-else
-$(GALLINA): $(GALLINACMO)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $^
-endif
+$(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,)
 
-ifeq ($(BEST),opt)
-$(COQMAKEFILE): tools/coq_makefile.cmx config/coq_config.cmx
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa config/coq_config.cmx tools/coq_makefile.cmx
-	$(STRIP) $@
-else
-$(COQMAKEFILE): config/coq_config.cmo tools/coq_makefile.cmo
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma $^
-endif
+$(COQMAKEFILE): $(addsuffix $(BESTOBJ),config/coq_config ide/minilib ide/project_file tools/coq_makefile)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,str unix)
 
-ifeq ($(BEST),opt)
-$(COQTEX): tools/coq_tex.cmx
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa $^
-	$(STRIP) $@
-else
-$(COQTEX): tools/coq_tex.cmo
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma $^
-endif
+$(COQTEX): tools/coq_tex$(BESTOBJ)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,str)
 
-ifeq ($(BEST),opt)
-$(COQWC): tools/coqwc.cmx
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ tools/coqwc.cmx
-	$(STRIP) $@
-else
-$(COQWC): tools/coqwc.cmo
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $^
-endif
+$(COQWC): tools/coqwc$(BESTOBJ)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,)
 
-ifeq ($(BEST),opt)
-$(COQDOC): $(COQDOCCMX)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa $(COQDOCCMX)
-	$(STRIP) $@
+$(COQDOC): $(COQDOCCMO:.cmo=$(BESTOBJ))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,str unix)
+
+# fake_ide : for debugging or test-suite purpose, a fake ide simulating
+# a connection to coqtop -ideslave
+
+$(FAKEIDE): lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) lib/xml_utils$(BESTOBJ) toplevel/ide_intf$(BESTOBJ) tools/fake_ide$(BESTOBJ)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,,unix)
+
+# Special rule for the compatibility-with-camlp5 extension for camlp4
+
+ifeq ($(CAMLP4),camlp4)
+tools/compat5.cmo: tools/compat5.mlp
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp "$(CAMLP4O) -impl" -impl $<
+tools/compat5b.cmo: tools/compat5b.mlp
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp "$(CAMLP4O) -impl" -impl $<
 else
-$(COQDOC): $(COQDOCCMO)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma unix.cma $^
+tools/compat5.cmo: tools/compat5.ml
+	$(OCAMLC) -c $<
+tools/compat5b.cmo: tools/compat5b.ml
+	$(OCAMLC) -c $<
 endif
 
 ###########################################################################
@@ -543,6 +569,8 @@ endif
 ifdef COQINSTALLPREFIX
 FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
@@ -550,12 +578,18 @@ FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 else
 FULLBINDIR=$(BINDIR)
 FULLCOQLIB=$(COQLIBINSTALL)
+FULLCONFIGDIR=$(CONFIGDIR)
+FULLDATADIR=$(DATADIR)
 FULLMANDIR=$(MANDIR)
 FULLEMACSLIB=$(EMACSLIB)
 FULLCOQDOCDIR=$(COQDOCDIR)
 FULLDOCDIR=$(DOCDIR)
 endif
 
+.PHONY: install-coq install-coqlight install-binaries install-byte install-opt
+.PHONY: install-tools install-library install-library-light
+.PHONY: install-coq-info install-coq-manpages install-emacs install-latex
+
 install-coq: install-binaries install-library install-coq-info
 install-coqlight: install-binaries install-library-light
 
@@ -579,6 +613,14 @@ install-tools::
 	$(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc
 	$(INSTALLBIN) $(TOOLS) $(FULLBINDIR)
 
+# The list of .cmi to install, including the ones obtained
+# from .mli without .ml, and the ones obtained from .ml without .mli
+
+INSTALLCMI = $(sort \
+	$(CONFIG:.cmo=.cmi) \
+	$(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \
+	$(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES)))))
+
 install-library:
 	$(MKDIR) $(FULLCOQLIB)
 	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT)
@@ -587,9 +629,7 @@ install-library:
 	$(MKDIR) $(FULLCOQLIB)/user-contrib
 	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
 	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG) $(LINKCMO) $(GRAMMARCMA)
-	# 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"`
+	$(INSTALLSH)  $(FULLCOQLIB) $(INSTALLCMI)
 ifeq ($(BEST),opt)
 	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
 	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a)
@@ -598,6 +638,7 @@ endif
 # it with libraries
 	-$(MKDIR) $(FULLCOQLIB)/plugins/micromega
 	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega
+	rm -f $(FULLCOQLIB)/revision
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
 
 install-library-light:
@@ -605,6 +646,7 @@ install-library-light:
 	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT)
 	$(MKDIR) $(FULLCOQLIB)/states
 	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
+	rm -f $(FULLCOQLIB)/revision
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
 
 install-coq-info: install-coq-manpages install-emacs install-latex
@@ -629,12 +671,47 @@ install-latex:
 # Documentation of the source code (using ocamldoc)
 ###########################################################################
 
-.PHONY: source-doc
+.PHONY: source-doc mli-doc ml-doc
+
+source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf
 
-source-doc:
-	if !(test -d $(SOURCEDOCDIR)); then mkdir $(SOURCEDOCDIR); fi
-	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLFILES)
+$(OCAMLDOCDIR)/coq.tex:: $(DOCMLIS:.mli=.cmi)
+	$(OCAMLDOC) -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+	$(DOCMLIS) -t "Coq mlis documentation" \
+	-intro $(OCAMLDOCDIR)/docintro -o $@
 
+mli-doc:: $(DOCMLIS:.mli=.cmi)
+	$(OCAMLDOC) -html -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+	$(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \
+	-t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \
+	-css-style style.css
+
+%_dep.png: %.dot
+	$(DOT) -Tpng $< -o $@
+
+%_types.dot: %.mli
+	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< 
+
+OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
+  $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib))))
+
+%.dot: | %.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
+ml-doc:
+	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLSTATICFILES)
+
+parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
+tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
+%.dot: %.mli
+	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< 
+
+$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex
+	(cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex)
 
 ###########################################################################
 ### Special rules
@@ -642,7 +719,7 @@ source-doc:
 
 dev/printers.cma: | dev/printers.mllib.d
 	$(SHOW)'Testing $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) unix.cma gramlib.cma $^ -o test-printer
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(SYSCMA) $^ -o test-printer
 	@rm -f test-printer
 	$(SHOW)'OCAMLC -a $@'   
 	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
@@ -650,35 +727,38 @@ dev/printers.cma: | dev/printers.mllib.d
 parsing/grammar.cma: | parsing/grammar.mllib.d
 	$(SHOW)'Testing $@'
 	@touch test.ml4
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $^ -impl" -impl test.ml4 -o test-grammar
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) -I $(CAMLLIB) $^ -impl" -impl test.ml4 -o test-grammar
 	@rm -f test-grammar test.*
 	$(SHOW)'OCAMLC -a $@'   
 	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
 
 # toplevel/mltop.ml4 (ifdef Byte)
 
-toplevel/mltop.cmo: toplevel/mltop.byteml | toplevel/mltop.ml4.ml.d toplevel/mltop.ml4.d
-	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c -impl $< -o $@
+## NB: mltop.ml correspond to the byte version (and hence need no special rules)
+## while the opt version is in mltop.optml. Since mltop.optml uses mltop.ml.d
+## as dependency file, be sure to import the same modules in the different sections
+## of the ml4
 
-toplevel/mltop.cmx: toplevel/mltop.optml | toplevel/mltop.ml4.ml.d toplevel/mltop.ml4.d
-	$(SHOW)'OCAMLOPT  $<'	
+toplevel/mltop.cmx: toplevel/mltop.optml | toplevel/mltop.ml.d toplevel/mltop.ml4.d
+	$(SHOW)'OCAMLOPT  $<'
 	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $< -o $@
 
-## This works dependency-wise because the dependencies of the
-## .{opt,byte}ml files are those we deduce from the .ml4 file.
-## In other words, the Byte-only code doesn't import a new module.
-toplevel/mltop.byteml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
-	$(SHOW)'CAMLP4O   $<'	
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` \
-	  -DByte -DHasDynlink -impl $< > $@ \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+toplevel/mltop.ml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
+	$(SHOW)'CAMLP4O   $<'
+	$(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) -DByte -DHasDynlink -impl $< -o $@
+
+toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
+	$(SHOW)'CAMLP4O   $<'
+	$(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) $(NATDYNLINKDEF) -impl $< -o $@
+
+ide/coqide_main.ml: ide/coqide_main.ml4
+	$(SHOW)'CAMLP4O   $<'
+	$(HIDE)$(CAMLP4O) $(CAMLP4USE) -impl $< -o $@
+
+ide/coqide_main_opt.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here
+	$(SHOW)'CAMLP4O   $<'
+	$(HIDE)$(CAMLP4O) $(CAMLP4USE) -D$(IDEOPTINT) -impl $< -o $@
 
-toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here 
-	$(SHOW)'CAMLP4O   $<'	
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` \
-	  $(NATDYNLINKDEF) -impl $< > $@ \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
 # pretty printing of the revision number when compiling a checked out
 # source tree
@@ -731,52 +811,46 @@ endif
 # Default rules
 ###########################################################################
 
-checker/%.cmo: checker/%.ml | checker/%.ml.d
-	$(SHOW)'OCAMLC    $<'
-	$(HIDE)$(OCAMLC) -c $(CHKBYTEFLAGS) $<
+## Three flavor of flags: checker/* ide/* and normal files
 
-checker/%.cmx: checker/%.ml | checker/%.ml.d
-	$(SHOW)'OCAMLOPT  $<'
-	$(HIDE)$(OCAMLOPT) -c $(CHKOPTFLAGS) $<
+COND_BYTEFLAGS= \
+ $(if $(filter checker/%,$<), $(CHKBYTEFLAGS), \
+   $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(BYTEFLAGS))
 
-checker/%.cmi: checker/%.mli | checker/%.mli.d
-	$(SHOW)'OCAMLC    $<'
-	$(HIDE)$(OCAMLC) -c $(CHKBYTEFLAGS) $<
+COND_OPTFLAGS= \
+ $(if $(filter checker/%,$<), $(CHKOPTFLAGS), \
+   $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(OPTFLAGS))
 
 %.o: %.c
 	$(SHOW)'OCAMLC    $<'
 	$(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<)
 
-ifdef KEEP_ML4_PREPROCESSED
-.PRECIOUS: %.ml4-preprocessed
-%.cmo: %.ml4-preprocessed | %.ml4.ml.d
+%.cmi: %.mli | %.mli.d
 	$(SHOW)'OCAMLC    $<'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c -impl $<
-
-%.cmx: %.ml4-preprocessed | %.ml4.ml.d
-	$(SHOW)'OCAMLOPT  $<'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $<
-else
-%.cmo: %.ml4 | %.ml4.ml.d %.ml4.d
-	$(SHOW)'OCAMLC4   $<'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4USE) $<` `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl" -c -impl $<
-
-%.cmx: %.ml4 | %.ml4.ml.d %.ml4.d
-	$(SHOW)'OCAMLOPT4 $<'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4USE) $<` `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl" -c -impl $<
-endif
+	$(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $<
 
 %.cmo: %.ml | %.ml.d
 	$(SHOW)'OCAMLC    $<'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c $<
+	$(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $<
 
-%.cmi: %.mli | %.mli.d
-	$(SHOW)'OCAMLC    $<'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c $<
+## NB: for the moment ocamlopt erases and recreates .cmi if there's no .mli around.
+## This can lead to nasty things with make -j. To avoid that:
+##  1) We make .cmx always depend on .cmi
+##  2) This .cmi will be created from the .mli, or trigger the compilation of the
+##    .cmo if there's no .mli (see rule below about MLWITHOUTMLI)
+##  3) We tell ocamlopt to use the .cmi as the interface source file. With this
+##     hack, everything goes as if there is a .mli, and the .cmi is preserved
+##     and the .cmx is checked with respect to this .cmi
+
+HACKMLI = $(if $(wildcard $<i),,-intf-suffix .cmi)
+
+$(MLWITHOUTMLI:.ml=.cmx): %.cmx: %.cmi  # for .ml with .mli this is already the case
+
+$(MLWITHOUTMLI:.ml=.cmi): %.cmi: %.cmo
 
 %.cmx: %.ml | %.ml.d
 	$(SHOW)'OCAMLOPT  $<'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c $<
+	$(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $<
 
 %.cmxs: %.cmxa
 	$(SHOW)'OCAMLOPT -shared -o $@'
@@ -803,17 +877,23 @@ plugins/%_mod.ml: plugins/%.mllib
 	$(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))
+# NB: compatibility modules for camlp4: 
+# - tools/compat5.cmo changes GEXTEND into EXTEND. Safe, always loaded
+# - tools/compat5b.cmo changes EXTEND into EXTEND Gram. Interact badly with
+#    syntax such that VERNAC EXTEND, we only load it for a few files via camlp4deps
 
-%.ml4-preprocessed: %.ml4 | %.ml4.d
+%.ml: %.ml4 | %.ml4.d tools/compat5.cmo tools/compat5b.cmo
 	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl $< > $@ \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+	$(HIDE)\
+	DEPS=$(CAMLP4DEPS); \
+	if ls $${DEPS} > /dev/null 2>&1; then \
+	$(CAMLP4O) $(PR_O) -I $(CAMLLIB) tools/compat5.cmo $${DEPS} $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@; \
+	else echo $< : Dependency $${DEPS} not ready yet; false; fi
 
 %.vo %.glob: %.v states/initial.coq $(INITPLUGINSBEST) $(VO_TOOLS_STRICT) | %.v.d  $(VO_TOOLS_ORDER_ONLY)
 	$(SHOW)'COQC      $<'
 	$(HIDE)rm -f $*.glob 
-	$(HIDE)$(BOOTCOQTOP) -compile $*
+	$(HIDE)$(BOOTCOQC) $*
 ifdef VALIDATE
 	$(SHOW)'COQCHK    $(call vo_to_mod,$@)'
 	$(HIDE)$(BESTCHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
@@ -826,69 +906,51 @@ endif
 
 # .ml4.d contains the dependencies to generate the .ml from the .ml4
 # NOT to generate object code.
-ifdef NO_RECOMPILE_ML4
-  SEP:=$(ORDER_ONLY_SEP)
-else
-  SEP:=
-endif
+
 %.ml4.d: $(D_DEPEND_BEFORE_SRC) %.ml4
 	$(SHOW)'CAMLP4DEPS $<'
-	$(HIDE)( printf "%s" '$*.cmo $*.cmx $*.ml4.ml.d $*.ml4-preprocessed: $(SEP)' && $(CAMLP4DEPS) "$<" ) > "$@" \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+	$(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(CAMLP4DEPS)" $(TOTARGET)
+
+# We now use coqdep_boot to wrap around ocamldep -modules, since it is aware
+# of .ml4 files
 
-%.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 $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl $< -o $*.ml \
-	  || ( RV=$$?; rm -f "$*.ml"; exit $${RV} )
-	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) $*.ml | sed '' > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} )
-	$(HIDE)echo "let keep_ocamldep_happy Do_not_compile_me = assert false" > $*.ml
-#End critical section
-
-checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC)
+OCAMLDEP_NG = $(COQDEPBOOT) -mldep $(OCAMLDEP)
+
+checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP) -slash $(LOCALCHKLIBS) "$<" | sed '' > "$@"
+	$(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET)
 
-checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC)
+checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP) -slash $(LOCALCHKLIBS) "$<" | sed '' > "$@"
+	$(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET)
 
-%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILESML)
+%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" | sed '' > "$@"
+	$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
 
-%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILESML)
+%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" | sed '' > "$@"
+	$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
 
-checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT)
+checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'COQDEP  $<'
-	$(HIDE)$(COQDEPBOOT) -slash -boot -I checker -c "$<" > "$@" \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+	$(HIDE)$(COQDEPBOOT) -slash -I checker -c "$<" $(TOTARGET)
 
-%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT)
+%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(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} )
+	$(HIDE)$(COQDEPBOOT) -slash -I kernel -I tools/coqdoc -c "$<" $(TOTARGET)
 
 %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
 	$(SHOW)'COQDEP    $<'
-	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) -slash -boot "$<" > "$@" \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) -slash "$<" $(TOTARGET)
+
+%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC)
+	$(SHOW)'CCDEP	$<'
+	$(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@
 
 %.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES)
 	$(SHOW)'CCDEP     $<'
-	$(HIDE)$(CC) -MM -MQ "$@" -MQ "$(<:.c=.o)" $(CFLAGS) -isystem $(CAMLHLIB) $< > $@ \
-	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
-
-.SECONDARY: $(GENFILES)
+	$(HIDE)$(CC) -MM -MQ "$@" -MQ "$(<:.c=.o)" $(CFLAGS) -isystem $(CAMLHLIB) $< $(TOTARGET)
 
 ###########################################################################
 # this sets up developper supporting stuff
@@ -900,28 +962,6 @@ devel: $(DEBUGPRINTERS)
 ###########################################################################
 
 
-%.types.dot: %.mli
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< 
-
-%.dep.ps: %.dot
-	$(DOT) $(DOTOPTS) -o $@ $<
-
-OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
-  `cat $| | tr ' ' '\n' | sed -n -e "/\.cmo/s/\.cmo/\.ml/p"`
-
-%.dot: | %.mllib.d
-	$(OCAMLDOC_MLLIBD)
-
-parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d
-	$(OCAMLDOC_MLLIBD)
-
-tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d
-	$(OCAMLDOC_MLLIBD)
-
-%.dot: %.mli
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< 
-
-
 # For emacs: 
 # Local Variables: 
 # mode: makefile 
diff --git a/Makefile.common b/Makefile.common
index 46bf2175..b560bae5 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -1,4 +1,3 @@
-
 #######################################################################
 #  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
 # <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              #
@@ -17,20 +16,31 @@ COQMKTOPBYTE:=bin/coqmktop.byte$(EXE)
 COQMKTOPOPT:=bin/coqmktop.opt$(EXE)
 BESTCOQMKTOP:=bin/coqmktop.$(BEST)$(EXE)
 COQMKTOP:=bin/coqmktop$(EXE) 
+
 COQCBYTE:=bin/coqc.byte$(EXE)
 COQCOPT:=bin/coqc.opt$(EXE)
 BESTCOQC:=bin/coqc.$(BEST)$(EXE)
 COQC:=bin/coqc$(EXE)
+
 COQTOPBYTE:=bin/coqtop.byte$(EXE)
 COQTOPOPT:=bin/coqtop.opt$(EXE)
 BESTCOQTOP:=bin/coqtop.$(BEST)$(EXE)
 COQTOPEXE:=bin/coqtop$(EXE)
+
 CHICKENBYTE:=bin/coqchk.byte$(EXE)
 CHICKENOPT:=bin/coqchk.opt$(EXE)
 BESTCHICKEN:=bin/coqchk.$(BEST)$(EXE)
 CHICKEN:=bin/coqchk$(EXE)
 
-ifneq ($(HASNATDYNLINK),false)
+FAKEIDE:=bin/fake_ide$(EXE)
+
+ifeq ($(CAMLP4),camlp4)
+CAMLP4MOD:=camlp4lib
+else
+CAMLP4MOD:=gramlib
+endif
+
+ifeq ($(HASNATDYNLINK)-$(BEST),true-opt)
   DYNLINKCMXA:=dynlink.cmxa
   NATDYNLINKDEF:=-DHasDynlink
   DEPNATDYN:=
@@ -50,26 +60,29 @@ COQIDEOPT:=bin/coqide.opt$(EXE)
 COQIDE:=bin/coqide$(EXE)
 
 ifeq ($(BEST),opt)
-COQBINARIES:= $(COQMKTOP) $(COQC) \
-  $(COQTOPBYTE) $(COQTOPOPT) $(COQTOPEXE) $(CHICKENBYTE) $(CHICKENOPT) $(CHICKEN)
+OPT:=opt
 else
-COQBINARIES:= $(COQMKTOP) $(COQC) \
-  $(COQTOPBYTE)              $(COQTOPEXE) $(CHICKENBYTE)               $(CHICKEN)
+OPT:=
 endif
-OTHERBINARIES:=$(COQMKTOPBYTE) $(COQCBYTE)
+
+BESTOBJ:=$(if $(OPT),.cmx,.cmo)
+
+COQBINARIES:= $(COQMKTOP) $(COQC) \
+  $(COQTOPBYTE) $(if $(OPT),$(COQTOPOPT)) $(COQTOPEXE) \
+  $(CHICKENBYTE) $(if $(OPT),$(CHICKENOPT)) $(CHICKEN)
 
 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		\
+  pretyping	interp		toplevel/utils	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)
+    rtauto 	nsatz           syntax          decl_mode)
 
 # Order is relevent here because kernel and checker contain files
 # with the same name
@@ -139,10 +152,6 @@ COQRUN := coqrun
 LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a
 DLLCOQRUN:=$(dir $(LIBCOQRUN))dll$(COQRUN)$(DLLEXT)
 
-CLIBS:=unix.cma
-
-CAMLP4OBJS:=gramlib.cma
-
 CONFIG:=config/coq_config.cmo
 
 BYTERUN:=$(addprefix kernel/byterun/, \
@@ -158,6 +167,8 @@ CORECMA:=lib/lib.cma kernel/kernel.cma library/library.cma \
         parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
         parsing/highparsing.cma tactics/hightactics.cma 
 
+GRAMMARCMA:=parsing/grammar.cma
+
 OMEGACMA:=plugins/omega/omega_plugin.cma
 ROMEGACMA:=plugins/romega/romega_plugin.cma
 MICROMEGACMA:=plugins/micromega/micromega_plugin.cma
@@ -182,8 +193,9 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \
         r_syntax_plugin.cma \
 	ascii_syntax_plugin.cma \
         string_syntax_plugin.cma )
+DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma
 
-PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) \
+PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \
         $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \
         $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \
         $(CCCMA)  $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \
@@ -204,24 +216,21 @@ else
  PLUGINSOPT:=
 endif
 
-ifeq ($(BEST),opt)
-  INITPLUGINSBEST:=$(INITPLUGINSOPT)
-else
-  INITPLUGINSBEST:=$(INITPLUGINS)
-endif
-
-CMA:=$(CLIBS) $(CAMLP4OBJS)
-CMXA:=$(CMA:.cma=.cmxa)
+INITPLUGINSBEST:=$(if $(OPT),$(INITPLUGINSOPT),$(INITPLUGINS))
 
 LINKCMO:=$(CONFIG) $(CORECMA) $(STATICPLUGINS)
 LINKCMX:=$(CONFIG:.cmo=.cmx) $(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa)
 
+IDEDEPS:=$(CONFIG) lib/flags.cmo lib/xml_lexer.cmo lib/xml_parser.cmo \
+  lib/xml_utils.cmo toplevel/ide_intf.cmo
 IDECMA:=ide/ide.cma
 
+LINKIDE:=$(IDEDEPS) $(IDECMA) ide/coqide_main.ml
+LINKIDEOPT:=$(IDEOPTDEPS) $(IDEDEPS:.cmo=.cmx) $(IDECMA:.cma=.cmxa) ide/coqide_main_opt.ml
+
 # modules known by the toplevel of Coq
 
-OBJSMOD:=Coq_config \
- $(foreach lib,$(CORECMA),$(shell cat $(lib:.cma=.mllib)))
+OBJSMOD:=Coq_config $(shell cat $(CORECMA:.cma=.mllib))
 
 IDEMOD:=$(shell cat ide/ide.mllib)
 
@@ -229,51 +238,25 @@ IDEMOD:=$(shell cat ide/ide.mllib)
 
 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/segmenttree.cmo lib/unicodetable.cmo lib/util.cmo lib/errors.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 \
+  mutils.cmo 	micromega.cmo \
   sos_types.cmo sos_lib.cmo sos.cmo 	csdpcert.cmo )
 
-CSDPCERTCMX:= $(CSDPCERTCMO:.cmo=.cmx)
-
 DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
 
-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)
+COQDEPCMO:=$(COQENVCMO) tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo
 
 COQDOCCMO:=$(CONFIG) $(addprefix tools/coqdoc/, \
   cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
-COQDOCCMX:=$(COQDOCCMO:.cmo=.cmx)
-
-# grammar modules with camlp4
-
-GRAMMARCMA:=parsing/grammar.cma
-
-GRAMMARML4:=lib/compat.ml4 lib/pp.ml4 parsing/q_util.ml4 parsing/pcoq.ml4 \
-  parsing/argextend.ml4 parsing/tacextend.ml4 parsing/vernacextend.ml4 \
-  parsing/g_prim.ml4 parsing/g_tactic.ml4 \
-  parsing/g_ltac.ml4 parsing/g_constr.ml4 \
-  parsing/lexer.ml4 parsing/q_coqast.ml4
-
-STAGE1_ML4:=$(GRAMMARML4) parsing/q_constr.ml4
-STAGE1:=parsing/grammar.cma parsing/q_constr.cmo
-
 
 ###########################################################################
 # vo files
@@ -291,10 +274,12 @@ STRUCTURESVO:=$(call cat_vo_itarget, theories/Structures)
 ARITHVO:=$(call cat_vo_itarget, theories/Arith)
 SORTINGVO:=$(call cat_vo_itarget, theories/Sorting)
 BOOLVO:=$(call cat_vo_itarget, theories/Bool)
+PARITHVO:=$(call cat_vo_itarget, theories/PArith)
 NARITHVO:=$(call cat_vo_itarget, theories/NArith)
 ZARITHVO:=$(call cat_vo_itarget, theories/ZArith)
 QARITHVO:=$(call cat_vo_itarget, theories/QArith)
 LISTSVO:=$(call cat_vo_itarget, theories/Lists)
+VECTORSVO:=$(call cat_vo_itarget, theories/Vectors)
 STRINGSVO:=$(call cat_vo_itarget, theories/Strings)
 SETSVO:=$(call cat_vo_itarget, theories/Sets)
 FSETSVO:=$(call cat_vo_itarget, theories/FSets)
@@ -309,10 +294,11 @@ CLASSESVO:=$(call cat_vo_itarget, theories/Classes)
 PROGRAMVO:=$(call cat_vo_itarget, theories/Program)
 
 THEORIESVO:=\
-  $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \
+  $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(PARITHVO) $(NARITHVO) $(ZARITHVO) \
   $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(MSETSVO) \
   $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
-  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO)
+  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO) \
+  $(VECTORSVO)
 
 THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(ARITHVO)
 
@@ -341,6 +327,7 @@ PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
 
 ALLVO:= $(THEORIESVO) $(PLUGINSVO)
 VFILES:= $(ALLVO:.vo=.v)
+ALLSTDLIB := test-suite/misc/universes/all_stdlib
 
 # convert a (stdlib) filename into a module name:
 # remove .vo, replace theories and plugins by Coq, and replace slashes by dots
@@ -351,7 +338,6 @@ ALLMODS:=$(call vo_to_mod,$(ALLVO))
 LIBFILES:=$(THEORIESVO) $(PLUGINSVO)
 LIBFILESLIGHT:=$(THEORIESLIGHTVO)
 
-
 ###########################################################################
 # Miscellaneous
 ###########################################################################
@@ -363,56 +349,20 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
 
 DATE=$(shell LANG=C date +"%B %Y")
 
-SOURCEDOCDIR=dev/source-doc
-
-CAML_OBJECT_PATTERNS:=%.cmo %.cmx %.o %.cmi %.cma %.cmxa %.a %.cmxs %.dep.ps %.dot
-
-### Targets forwarded by Makefile to a specific stage:
-
-## 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)
-
-STAGE1_IMPLICITS:=
-
-ifdef CM_STAGE1
- STAGE1_IMPLICITS+=$(CAML_OBJECT_PATTERNS)
-endif
-
-## Enumeration of targets that require being done at stage2
-
-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
-
-STAGE2_TARGETS:=$(COQBINARIES) lib kernel byterun library proofs tactics \
-  interp parsing pretyping highparsing toplevel hightactics \
-  coqide-binaries coqide-byte coqide-opt $(COQIDEOPT) $(COQIDEBYTE) $(COQIDE) \
-  $(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
+###########################################################################
+# Source documentation
+###########################################################################
 
-STAGE2_IMPLICITS:= %.vo %.glob states/% install-% %.ml4-preprocessed \
-  $(DOC_TARGET_PATTERNS)
+OCAMLDOCDIR=dev/ocamldoc
 
-ifndef CM_STAGE1
- STAGE2_IMPLICITS+=$(CAML_OBJECT_PATTERNS)
-endif
+DOCMLIS=$(wildcard ./lib/*.mli ./kernel/*.mli ./library/*.mli \
+	./pretyping/*.mli ./interp/*.mli \
+	./parsing/*.mli ./proofs/*.mli \
+	./tactics/*.mli ./toplevel/*.mli)
 
+# Defining options to generate dependencies graphs
+DOT=dot
+ODOCDOTOPTS=-dot -dot-reduce
 
 # For emacs: 
 # Local Variables: 
diff --git a/Makefile.doc b/Makefile.doc
index c81d779c..59eb2fe8 100644
--- a/Makefile.doc
+++ b/Makefile.doc
@@ -11,9 +11,12 @@
 ### General rules
 ######################################################################
 
-.PHONY: doc doc-html doc-pdf doc-ps refman tutorial stdlib faq rectutorial
+.PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial
+.PHONY: stdlib full-stdlib faq rectutorial
 
-doc: refman faq tutorial rectutorial stdlib ide/index_urls.txt
+INDEXURLS:=doc/refman/html/index_urls.txt
+
+doc: refman faq tutorial rectutorial stdlib $(INDEXURLS)
 
 doc-html:\
   doc/tutorial/Tutorial.v.html doc/refman/html/index.html \
@@ -36,6 +39,9 @@ tutorial: \
 stdlib: \
   doc/stdlib/html/index.html doc/stdlib/Library.ps doc/stdlib/Library.pdf
 
+full-stdlib: \
+  doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf
+
 faq: doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf
 
 rectutorial: doc/RecTutorial/RecTutorial.html \
@@ -101,7 +107,7 @@ doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex
 	$(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\
 	../tools/show_latex_messages -no-overfull Reference-Manual.log)
 
-doc/refman/Reference-Manual.pdf: $(REFMANFILES) doc/refman/Reference-Manual.tex
+doc/refman/Reference-Manual.pdf: doc/refman/Reference-Manual.dvi
 	(cd doc/refman;\
 	$(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\
 	../tools/show_latex_messages -no-overfull Reference-Manual.log)
@@ -117,14 +123,17 @@ doc/refman/cover.html: doc/common/styles/html/$(HTMLSTYLE)/cover.html
 doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva
 	$(INSTALLLIB) $< doc/refman
 
-doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
-                        doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html
+INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html
+ALLINDEXES:= doc/refman/html/index.html $(INDEXES)
+
+$(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
+	       doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html
 	- rm -rf doc/refman/html
 	$(MKDIR) doc/refman/html
 	$(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;\
@@ -133,6 +142,14 @@ refman-quick:
 	$(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex)
 
 ######################################################################
+# Index file for CoqIDE
+######################################################################
+
+$(INDEXURLS): $(INDEXES)
+	cat $< | grep li-indexenv | grep HREF | sed -e 's@.*<TT>\(.*\)</TT>.*, <A HREF="\(.*\)">.*@\1,\2@' > $@
+
+
+######################################################################
 # Tutorial
 ######################################################################
 
@@ -183,32 +200,40 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html
 ### Standard library (browsable html format)
 
 ifdef QUICK
-doc/stdlib/html/genindex.html:
+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) $(PLUGINSVO)
-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 \
-	  -R theories Coq -R plugins Coq $(THEORIESVO:.vo=.v)  $(PLUGINSVO:.vo=.v)
-	mv doc/stdlib/html/index.html doc/stdlib/html/genindex.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
+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)
 
 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)
+doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO)
+	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
+            -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@
 endif
-	$(COQDOC) -q -boot --gallina --body-only --latex --stdout \
-            -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@
 
 doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex
 	(cd doc/stdlib;\
@@ -221,6 +246,34 @@ doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Li
 	$(PDFLATEX) -interaction=batchmode Library;\
 	../tools/show_latex_messages -no-overfull Library.log)
 
+### Standard library (full version if you're crazy enouth to try)
+
+doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex
+	sed -e 's/Library.coqdoc/FullLibrary.coqdoc/g;s/\\begin{document}/\\newcommand{\\textlambda}{\\ensuremath{\\lambda}}\\newcommand{\\textPi}{\\ensuremath{\\Pi}}\\begin{document}/' $< > $@
+
+ifdef QUICK
+doc/stdlib/FullLibrary.coqdoc.tex:
+	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
+            -R theories Coq $(THEORIESVO:.vo=.v) > $@
+	sed -i "" -e 's///g' $@
+else
+doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO)
+	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
+            -R theories Coq $(THEORIESVO:.vo=.v) > $@
+	sed -i "" -e 's///g' $@
+endif
+
+doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex
+	(cd doc/stdlib;\
+	$(LATEX) -interaction=batchmode FullLibrary;\
+	$(LATEX) -interaction=batchmode FullLibrary > /dev/null;\
+	../tools/show_latex_messages -no-overfull FullLibrary.log)
+
+doc/stdlib/FullLibrary.pdf: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.dvi
+	(cd doc/stdlib;\
+	$(PDFLATEX) -interaction=batchmode FullLibrary;\
+	../tools/show_latex_messages -no-overfull FullLibrary.log)
+
 ######################################################################
 # Tutorial on inductive types
 ######################################################################
@@ -242,22 +295,12 @@ doc/RecTutorial/RecTutorial.html: doc/RecTutorial/RecTutorial.tex
 	(cd doc/RecTutorial; $(HEVEA) $(HEVEAOPTS) RecTutorial)
 
 ######################################################################
-# Index file for CoqIDE
-######################################################################
-
-# Not robust, improve...
-ide/index_urls.txt: doc/refman/html/index.html
-	@ 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
 ######################################################################
 
-.PHONY: install-doc install-doc-meta install-doc-html install-doc-printable install-doc-index-url
+.PHONY: install-doc install-doc-meta install-doc-html install-doc-printable install-doc-index-urls
 
-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-urls
 
 install-doc-meta:
 	$(MKDIR) $(FULLDOCDIR)
@@ -284,9 +327,9 @@ install-doc-printable:
 	$(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps
 	$(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps
 
-install-doc-index-url:
+install-doc-index-urls:
 	$(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf
-	$(INSTALLLIB) doc/refman/html/index_urls.txt \
+	$(INSTALLLIB) $(INDEXURLS) \
 		$(FULLDOCDIR)/html/refman 
 
 # For emacs:
diff --git a/Makefile.stage1 b/Makefile.stage1
deleted file mode 100644
index a60d388f..00000000
--- a/Makefile.stage1
+++ /dev/null
@@ -1,33 +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.build
-
-# All includes must be declared secondary, otherwise make will delete
-# them if it decided to build them by dependency instead of because of
-# include, and they will then be automatically deleted, leading to an
-# infinite loop.
--include $(ML4FILES:.ml4=.ml4.d)
-.SECONDARY: $(ML4FILES:.ml4=.ml4.d)
--include $(MLFILES:.ml=.ml.d)
-.SECONDARY: $(MLFILES:.ml=.ml.d)
--include $(MLIFILES:.mli=.mli.d)
-.SECONDARY: $(MLIFILES:.mli=.mli.d)
-##Depends upon the fact that all .ml4.d for stage1 files are empty
--include $(STAGE1_ML4:.ml4=.ml4.ml.d)
-.SECONDARY: $(STAGE1_ML4:.ml4=.ml4.ml.d)
--include  $(CFILES:.c=.c.d)
-.SECONDARY: $(CFILES:.c=.c.d)
-
-.PHONY: stage1
-stage1: $(STAGE1)
-
-# For emacs: 
-# Local Variables: 
-# mode: makefile 
-# End:
diff --git a/Makefile.stage2 b/Makefile.stage2
deleted file mode 100644
index 8f3d4e8b..00000000
--- a/Makefile.stage2
+++ /dev/null
@@ -1,27 +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.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: world
-
-# For emacs: 
-# Local Variables: 
-# mode: makefile 
-# End:
diff --git a/README b/README
index ccfe1ecc..4f4afa5b 100644
--- a/README
+++ b/README
@@ -27,7 +27,8 @@ CHANGES.
 AVAILABILITY.
 =============
 
-   Coq is available at http://coq.inria.fr/download.
+   Coq is available at http://coq.inria.fr, or, for older versions at
+   ftp://ftp.inria.fr/INRIA/LogiCal/coq.
 
 
 THE COQ CLUB.
@@ -37,7 +38,7 @@ THE COQ CLUB.
    discuss questions about the Coq system and related topics. The submission
    address is:
 
-	coq-club@inria.fr
+	coq-club@coq.inria.fr
 
    The topics to be discussed in the club should include:
 
@@ -52,10 +53,13 @@ THE COQ CLUB.
      * theoretical questions about typed lambda-calculi which are
        closely related to Coq.
 
-   To be added to, or removed from, the mailing list, go to
-   https://sympa-roc.inria.fr/wws/info/coq-club or write to
-   sympa@inria.fr with subject either "subscribe coq-club" or
-   "unsubscribe coq-club". List is moderated for non-subscribers.
+   To be added to, or removed from, the mailing list, please write to:
+
+	coq-club-request@coq.inria.fr
+
+   Please use also this address for any questions/suggestions about the
+   Coq Club. It might sometimes take a few days before your messages get
+   forwarded.
 
 
 BUGS REPORT.
@@ -63,8 +67,8 @@ BUGS REPORT.
 
    Send your bug reports by filling a form at
 
-        http://coq.inria.fr/bugs/
+        http://logical.saclay.inria.fr/coq-bugs
 
-   To be effective, bug reports should mention the Coq version (coqtop -v),
-   the configuration used, and include a complete source example
-   leading to the bug.
+   To be effective, bug reports should mention the Caml version used
+   to compile and run Coq, the Coq version (coqtop -v), the configuration
+   used, and include a complete source example leading to the bug.
diff --git a/README.win b/README.win
index dcbf37b5..5027016f 100644
--- a/README.win
+++ b/README.win
@@ -20,12 +20,12 @@ COMPILATION.
     distribution. If you really need to recompile under Windows, here
     are some indications:
 
-    1- Install ocaml for Windows (MinGW port), at least version 3.10.2.
+    1- Install ocaml for Windows (MinGW port).
        See: http://caml.inria.fr
 
     2- Install a shell environment with at least:
          - a C compiler (gcc),
-         - the GNU make utility (version >= 3.81)
+         - the GNU make utility
 
        The Cygwin environment is well suited for compiling Coq
        (official packages are made using Cygwin) See:
@@ -43,9 +43,9 @@ COMPILATION.
         make world
         make install
 
-    5- Though not necessary, you can find useful:
+    5- Though not nescessary, you can find useful:
          - Windows version of (X)Emacs: it is a powerful environment for
-           developers with colored syntax, modes for compilation and debug,
+           developpers with coloured syntax, modes for compilation and debug,
            and many more. It is free. See: http://www.gnu.org/software.
          - Windows subversion client (very useful if you have access to the Coq
            archive).
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
index 96776266..6c69011b 100644
--- a/_tags
+++ b/_tags
@@ -1,16 +1,18 @@
 
 ## tags for binaries
 
-<scripts/coqmktop.{native,byte}> : use_str, use_unix, use_gramlib
-<scripts/coqc.{native,byte}> : use_unix, use_gramlib
+<scripts/coqmktop.{native,byte}> : use_str, use_unix, use_dynlink, use_camlpX
+<scripts/coqc.{native,byte}> : use_unix, use_dynlink, use_camlpX
 <tools/coqdep_boot.{native,byte}> : use_unix
-<tools/coqdep.{native,byte}> : use_unix, use_gramlib
+<tools/coqdep.{native,byte}> : use_unix, use_dynlink, use_camlpX
 <tools/coq_tex.{native,byte}> : use_str
-<tools/coq_makefile.{native,byte}> : use_str
+<tools/coq_makefile.{native,byte}> : use_str, use_unix
 <tools/coqdoc/main.{native,byte}> : use_str
-<checker/main.{native,byte}> : use_str, use_unix, use_gramlib
+<ide/coqide_main.{native,byte}> : use_str, use_unix, thread, ide
+<checker/main.{native,byte}> : use_str, use_unix, use_dynlink, use_camlpX
 <plugins/micromega/csdpcert.{native,byte}> : use_nums, use_unix
 <tools/mkwinapp.{native,byte}> : use_unix
+<tools/fake_ide.{native,byte}> : use_unix
 
 ## tags for ide
 
@@ -22,30 +24,9 @@
 
 ## 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/mltop.ml4": is_mltop
 
 "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
@@ -55,8 +36,24 @@
 "tactics/hipattern.ml4": use_grammar, use_constr
 "tactics/rewrite.ml4": use_grammar
 
+"parsing/g_constr.ml4": use_compat5
+"parsing/g_ltac.ml4": use_compat5
+"parsing/g_prim.ml4": use_compat5
+"parsing/g_proofs.ml4": use_compat5
+"parsing/g_tactic.ml4": use_compat5
+"parsing/g_vernac.ml4": use_compat5
+"parsing/g_xml.ml4": use_compat5
+"parsing/pcoq.ml4": use_compat5
+"plugins/decl_mode/g_decl_mode.ml4": use_compat5
+"plugins/funind/g_indfun.ml4": use_compat5
+"plugins/subtac/g_subtac.ml4": use_compat5
+
+"parsing/argextend.ml4": use_compat5b
+"parsing/q_constr.ml4": use_compat5b
+"parsing/tacextend.ml4": use_compat5b
+"parsing/vernacextend.ml4": use_compat5b
+
 <plugins/**/*.ml4>: use_grammar
-"plugins/subtac/g_subtac.ml4": use_extend
 
 ## sub-directory inclusion
 
diff --git a/build b/build
index 69b47239..c4b90d86 100755
--- a/build
+++ b/build
@@ -5,6 +5,8 @@ OCAMLBUILD=ocamlbuild
 CFG=config/coq_config.ml
 MYCFG=myocamlbuild_config.ml
 
+export CAML_LD_LIBRARY_PATH=`pwd`/_build/kernel/byterun
+
 check_config() {
  [ -f $CFG ] || (echo "please run ./configure first"; exit 1)
  [ -L $MYCFG ] || ln -sf $CFG $MYCFG
diff --git a/checker/check.ml b/checker/check.ml
index 40119a7e..bb42b949 100644
--- a/checker/check.ml
+++ b/checker/check.ml
@@ -1,18 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: library.ml 9679 2007-02-24 15:22:07Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 
-let pr_id id = str (string_of_id id)
 let pr_dirpath dp = str (string_of_dirpath dp)
 let default_root_prefix = make_dirpath []
 let split_dirpath d =
@@ -42,7 +39,7 @@ type compilation_unit_name = dir_path
 
 type library_disk = {
   md_name : compilation_unit_name;
-  md_compiled : Safe_typing.compiled_library;
+  md_compiled : Safe_typing.LightenLibrary.lightened_compiled_library;
   md_objects : library_objects;
   md_deps : (compilation_unit_name * Digest.t) list;
   md_imports : compilation_unit_name list }
@@ -155,12 +152,6 @@ let find_logical_path phys_dir =
   | _,[] -> default_root_prefix
   | _,l -> anomaly ("Two logical paths are associated to "^phys_dir)
 
-let is_in_load_paths phys_dir =
-  let dir = canonical_path_name phys_dir in
-  let lp = get_load_paths () in
-  let check_p = fun p -> (String.compare dir p) == 0 in
-    List.exists check_p lp
-
 let remove_load_path dir =
   load_paths := list_filter2 (fun p d -> p <> dir) !load_paths
 
@@ -191,13 +182,9 @@ let add_load_path (phys_path,coq_path) =
 	  load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths)
       | _ -> anomaly ("Two logical paths are associated to "^phys_path)
 
-let physical_paths (dp,lp) = dp
-
 let load_paths_of_dir_path dir =
   fst (list_filter2 (fun p d -> d = dir) !load_paths)
 
-let get_full_load_paths () = List.combine (fst !load_paths) (snd !load_paths)
-
 (************************************************************************)
 (*s Locate absolute or partially qualified library names in the path *)
 
@@ -269,8 +256,8 @@ let try_locate_qualified_library qid =
 
 (*s Loading from disk to cache (preparation phase) *)
 
-let (raw_extern_library, raw_intern_library) =
-  System.raw_extern_intern Coq_config.vo_magic_number ".vo"
+let raw_intern_library =
+  snd (System.raw_extern_intern Coq_config.vo_magic_number ".vo")
 
 let with_magic_number_check f a =
   try f a
@@ -283,10 +270,10 @@ let with_magic_number_check f a =
 (************************************************************************)
 (* Internalise libraries *)
 
-let mk_library md f digest = {
+let mk_library md f table digest = {
   library_name = md.md_name;
   library_filename = f;
-  library_compiled = md.md_compiled;
+  library_compiled = Safe_typing.LightenLibrary.load table md.md_compiled;
   library_deps = md.md_deps;
   library_digest = digest }
 
@@ -300,20 +287,21 @@ 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,table,digest) =
     try
       let ch = with_magic_number_check raw_intern_library f in
       let (md:library_disk) = System.marshal_in ch in
       let digest = System.marshal_in ch in
+      let table = (System.marshal_in ch : Safe_typing.LightenLibrary.table) in
       close_in ch;
       if dir <> md.md_name then
         errorlabstrm "load_physical_library"
           (name_clash_message dir md.md_name f);
       Flags.if_verbose msgnl(str" done]");
-      md,digest
+      md,table,digest
     with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in
   depgraph := LibraryMap.add md.md_name md.md_deps !depgraph;
-  mk_library md f digest
+  mk_library md f table digest
 
 let get_deps (dir, f) =
   try LibraryMap.find dir !depgraph
diff --git a/checker/check_stat.ml b/checker/check_stat.ml
index 88f2374b..5f28269e 100644
--- a/checker/check_stat.ml
+++ b/checker/check_stat.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -37,7 +37,7 @@ let cst_filter f csts =
     (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 = not (constant_has_body cb)
 
 let pr_ax csts =
   let axs = cst_filter is_ax csts in
diff --git a/checker/check_stat.mli b/checker/check_stat.mli
index d39eb454..353edda6 100644
--- a/checker/check_stat.mli
+++ b/checker/check_stat.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/checker/checker.ml b/checker/checker.ml
index 76f81264..34ba7b01 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqtop.ml 10153 2007-09-28 18:00:45Z glondu $ *)
-
+open Compat
 open Pp
 open Util
 open System
@@ -32,11 +31,11 @@ let parse_dir s =
     decoupe_dirs [] 0
 let dirpath_of_string s =
   match parse_dir s with
-      [] -> invalid_arg "dirpath_of_string"
+      [] -> Check.default_root_prefix
     | dir -> make_dirpath (List.map id_of_string dir)
 let path_of_string s =
   match parse_dir s with
-      [] -> invalid_arg "dirpath_of_string"
+      [] -> invalid_arg "path_of_string"
     | l::dir -> {dirpath=dir; basename=l}
 
 let (/) = Filename.concat
@@ -73,17 +72,17 @@ let convert_string d =
     flush_all ();
     failwith "caught"
 
-let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
-  if exists_dir dir then
-    let dirs = all_subdirs dir in
-    let prefix = repr_dirpath coq_dirpath in
+let add_rec_path ~unix_path ~coq_root =
+  if exists_dir unix_path then
+    let dirs = all_subdirs ~unix_path in
+    let prefix = repr_dirpath coq_root in
     let convert_dirs (lp,cp) =
       (lp,make_dirpath (List.map convert_string (List.rev cp)@prefix)) in
     let dirs = map_succeed convert_dirs dirs in
     List.iter Check.add_load_path dirs;
-    Check.add_load_path (dir,coq_dirpath)
+    Check.add_load_path (unix_path, coq_root)
   else
-    msg_warning (str ("Cannot open " ^ dir))
+    msg_warning (str ("Cannot open " ^ unix_path))
 
 (* By the option -include -I or -R of the command line *)
 let includes = ref []
@@ -92,9 +91,6 @@ let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
 
 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
-  push_rec_include (d, p)
 let set_include d p =
   let p = dirpath_of_string p in
   push_include (d,p)
@@ -106,24 +102,27 @@ let set_rec_include d p =
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
+  let xdg_dirs = Envars.xdg_dirs in
+  let coqpath = Envars.coqpath in
   let plugins = coqlib/"plugins" in
-  (* first user-contrib *)
-  if Sys.file_exists user_contrib then
-    add_rec_path user_contrib Check.default_root_prefix;
+  (* NOTE: These directories are searched from last to first *)
+  (* first standard library *)
+  add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.make_dirpath[coq_root]);
   (* then plugins *)
-  add_rec_path plugins (Names.make_dirpath [coq_root]);
-  (* then standard library *)
-(*  List.iter
-    (fun (s,alias) ->
-      add_rec_path (coqlib/s) ([alias; coq_root]))
-    theories_dirs_map;*)
-  add_rec_path (coqlib/"theories") (Names.make_dirpath[coq_root]);
+  add_rec_path ~unix_path:plugins ~coq_root:(Names.make_dirpath [coq_root]);
+  (* then user-contrib *)
+  if Sys.file_exists user_contrib then
+    add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix;
+  (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
+  List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) xdg_dirs;
+  (* then directories in COQPATH *)
+  List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath;
   (* then current directory *)
-  add_path "." Check.default_root_prefix;
+  add_path ~unix_path:"." ~coq_root:Check.default_root_prefix;
   (* additional loadpath, given with -I -include -R options *)
   List.iter
-    (fun (s,alias,reci) ->
-      if reci then add_rec_path s alias else add_path s alias)
+    (fun (unix_path, coq_root, reci) ->
+      if reci then add_rec_path ~unix_path ~coq_root else add_path ~unix_path ~coq_root)
     (List.rev !includes);
   includes := []
 
@@ -168,43 +167,41 @@ let version () =
 
 let print_usage_channel co command =
   output_string co command;
-  output_string co "Coq options are:\n";
+  output_string co "coqchk options are:\n";
   output_string co
-"  -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 coqdir          (idem)
-
-  -admit module          load module and dependencies without checking
-  -norec module          check module but admit dependencies without checking
-
-  -where                 print Coq's standard library location and exit
-  -v                     print Coq version and exit
-  -boot                  boot mode
-  -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
-"
+"  -I dir -as coqdir      map physical dir to logical coqdir\
+\n  -I dir                 map directory dir to the empty logical path\
+\n  -include dir           (idem)\
+\n  -R dir -as coqdir      recursively map physical dir to logical coqdir\
+\n  -R dir coqdir          (idem)\
+\n\
+\n  -admit module          load module and dependencies without checking\
+\n  -norec module          check module but admit dependencies without checking\
+\n\
+\n  -where                 print coqchk's standard library location and exit\
+\n  -v                     print coqchk version and exit\
+\n  -boot                  boot mode\
+\n  -o, --output-context   print the list of assumptions\
+\n  -m, --memory           print the maximum heap size\
+\n  -silent                disable trace of constants being checked\
+\n\
+\n  -impredicative-set     set sort Set impredicative\
+\n\
+\n  -h, --help             print this list of options\
+\n"
 
 (* print the usage on standard error *)
 
 let print_usage = print_usage_channel stderr
 
 let print_usage_coqtop () =
-  print_usage "Usage: coqchk <options>\n\n"
+  print_usage "Usage: coqchk <options> modules\n\n"
 
 let usage () =
   print_usage_coqtop ();
   flush stderr;
   exit 1
 
-let warning s = msg_warning (str s)
-
 open Type_errors
 
 let anomaly_string () = str "Anomaly: "
@@ -239,14 +236,9 @@ let rec explain_exn = function
   | Anomaly (s,pps) ->
       hov 1 (anomaly_string () ++ where s ++ pps ++ report ())
   | Match_failure(filename,pos1,pos2) ->
-      hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++
-      if Sys.ocaml_version = "3.06" then
-		   (str " from character " ++ int pos1 ++
-                    str " to " ++ int pos2)
-		 else
-		   (str " at line " ++ int pos1 ++
-		    str " character " ++ int pos2)
-	           ++ report ())
+      hov 1 (anomaly_string () ++ str "Match failure in file " ++
+	     str (guill filename) ++ str " at line " ++ int pos1 ++
+	     str " character " ++ int pos2 ++ report ())
   | Not_found ->
       hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ())
   | Failure s ->
@@ -274,22 +266,17 @@ let rec explain_exn = function
 (*      let ctx = Check.get_env() in
       hov 0
         (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*)
-  | Stdpp.Exc_located (loc,exc) ->
+  | Loc.Exc_located (loc,exc) ->
       hov 0 ((if loc = dummy_loc then (mt ())
                else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
                ++ explain_exn exc)
   | Assert_failure (s,b,e) ->
       hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
-	       (if s <> "" then
-		 if Sys.ocaml_version = "3.06" then
-		   (str ("(file \"" ^ s ^ "\", characters ") ++
-		    int b ++ str "-" ++ int e ++ str ")")
-		 else
-		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
-		    str ", characters " ++ int e ++ str "-" ++
-		    int (e+6) ++ str ")")
-	       else
-		 (mt ())) ++
+	       (if s = "" then mt ()
+		else
+		  (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
+		   str ", characters " ++ int e ++ str "-" ++
+		   int (e+6) ++ str ")")) ++
 	       report ())
   | reraise ->
       hov 0 (anomaly_string () ++ str "Uncaught exception " ++
@@ -298,8 +285,15 @@ let rec explain_exn = function
 let parse_args argv =
   let rec parse = function
     | [] -> ()
-   | "-impredicative-set" :: rem ->
-       set_engagement Declarations.ImpredicativeSet; parse rem
+    | "-impredicative-set" :: rem ->
+      set_engagement Declarations.ImpredicativeSet; parse rem
+
+    | "-coqlib" :: s :: rem ->
+      if not (exists_dir s) then 
+	(msgnl (str ("Directory '"^s^"' does not exist")); exit 1);
+      Flags.coqlib := s;
+      Flags.coqlib_spec := true;
+      parse rem
 
     | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem
     | ("-I"|"-include") :: d :: "-as" :: [] -> usage ()
diff --git a/checker/closure.ml b/checker/closure.ml
index da25b3b3..033e2bd7 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml 9983 2007-07-12 17:15:22Z barras $ *)
-
 open Util
 open Pp
 open Term
@@ -54,6 +52,9 @@ type transparent_state = Idpred.t * Cpred.t
 let all_opaque = (Idpred.empty, Cpred.empty)
 let all_transparent = (Idpred.full, Cpred.full)
 
+let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
+
 module type RedFlagsSig = sig
   type reds
   type red_kind
@@ -65,11 +66,8 @@ module type RedFlagsSig = sig
   val fVAR : identifier -> red_kind
   val no_red : reds
   val red_add : reds -> red_kind -> reds
-  val red_sub : reds -> red_kind -> reds
-  val red_add_transparent : reds -> transparent_state -> reds
   val mkflags : red_kind list -> reds
   val red_set : reds -> red_kind -> bool
-  val red_get_const : reds -> bool * evaluable_global_reference list
 end
 
 module RedFlags = (struct
@@ -114,21 +112,6 @@ module RedFlags = (struct
 	let (l1,l2) = red.r_const in
 	{ red with r_const = Idpred.add id l1, l2 }
 
-  let red_sub red = function
-    | BETA -> { red with r_beta = false }
-    | DELTA -> { red with r_delta = false }
-    | CONST kn ->
- 	let (l1,l2) = red.r_const in
-	{ red with r_const = l1, Cpred.remove kn l2 }
-    | IOTA -> { red with r_iota = false }
-    | ZETA -> { red with r_zeta = false }
-    | VAR id ->
-	let (l1,l2) = red.r_const in
-	{ red with r_const = Idpred.remove id l1, l2 }
-
-  let red_add_transparent red tr =
-    { red with r_const = tr }
-
   let mkflags = List.fold_left red_add no_red
 
   let red_set red = function
@@ -146,160 +129,14 @@ module RedFlags = (struct
     | DELTA -> (* Used for Rel/Var defined in context *)
 	incr_cnt red.r_delta delta
 
-  let red_get_const red =
-    let p1,p2 = red.r_const in
-    let (b1,l1) = Idpred.elements p1 in
-    let (b2,l2) = Cpred.elements p2 in
-    if b1=b2 then
-      let l1' = List.map (fun x -> EvalVarRef x) l1 in
-      let l2' = List.map (fun x -> EvalConstRef x) l2 in
-      (b1, l1' @ l2')
-    else error "unrepresentable pair of predicate"
-
 end : RedFlagsSig)
 
 open RedFlags
 
 let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA]
 let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
-let betaiota = mkflags [fBETA;fIOTA]
-let beta = mkflags [fBETA]
 let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
-let unfold_red kn =
-  let flag = match kn with
-    | EvalVarRef id -> fVAR id
-    | EvalConstRef kn -> fCONST kn
-  in (* Remove fZETA for finer behaviour ? *)
-  mkflags [fBETA;flag;fIOTA;fZETA]
-
-(************************* Obsolète
-(* [r_const=(true,cl)] means all constants but those in [cl] *)
-(* [r_const=(false,cl)] means only those in [cl] *)
-type reds = {
-  r_beta : bool;
-  r_const : bool * constant_path list * identifier list;
-  r_zeta : bool;
-  r_evar : bool;
-  r_iota : bool }
-
-let betadeltaiota_red = {
-  r_beta = true;
-  r_const = true,[],[];
-  r_zeta = true;
-  r_evar = true;
-  r_iota = true }
-
-let betaiota_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = true }
-
-let beta_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = false }
-
-let no_red = {
-  r_beta = false;
-  r_const = false,[],[];
-  r_zeta = false;
-  r_evar = false;
-  r_iota = false }
-
-let betaiotazeta_red = {
-  r_beta = true;
-  r_const = false,[],[];
-  r_zeta = true;
-  r_evar = false;
-  r_iota = true }
-
-let unfold_red kn =
-  let c = match kn with
-    | EvalVarRef id -> false,[],[id]
-    | EvalConstRef kn -> false,[kn],[]
-  in {
-  r_beta = true;
-  r_const = c;
-  r_zeta = true;   (* false for finer behaviour ? *)
-  r_evar = false;
-  r_iota = true }
-
-(* Sets of reduction kinds.
-   Main rule: delta implies all consts (both global (= by
-   kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
-   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
-   a LetIn expression is Letin reduction *)
-
-type red_kind =
-    BETA | DELTA | ZETA | IOTA
-  | CONST of constant_path list | CONSTBUT of constant_path list
-  | VAR of identifier | VARBUT of identifier
-
-let rec red_add red = function
-  | BETA -> { red with r_beta = true }
-  | DELTA ->
-      (match red.r_const with
-	| _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags"
-	| _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true })
-  | CONST cl ->
-      (match red.r_const with
-	| true,_,_ -> error "Conflict in the reduction flags"
-	| _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 })
-  | CONSTBUT cl ->
-      (match red.r_const with
-	| false,_::_,_ | false,_,_::_ ->
-			   error "Conflict in the reduction flags"
-	| _,l1,l2 ->
-	    { red with r_const = true, list_union cl l1, l2;
-		r_zeta = true; r_evar = true })
-  | IOTA -> { red with r_iota = true }
-  | ZETA -> { red with r_zeta = true }
-  | VAR id ->
-      (match red.r_const with
-	| true,_,_ -> error "Conflict in the reduction flags"
-	| _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 })
-  | VARBUT cl ->
-      (match red.r_const with
-	| false,_::_,_ | false,_,_::_ ->
-			   error "Conflict in the reduction flags"
-	| _,l1,l2 ->
-	    { red with r_const = true, l1, list_union [cl] l2;
-		r_zeta = true; r_evar = true })
-
-let red_delta_set red =
-  let b,_,_ = red.r_const in b
-
-let red_local_const = red_delta_set
-
-(* to know if a redex is allowed, only a subset of red_kind is used ... *)
-let red_set red = function
-  | BETA -> incr_cnt red.r_beta beta
-  | CONST [kn] ->
-      let (b,l,_) = red.r_const in
-      let c = List.mem kn l in
-      incr_cnt ((b & not c) or (c & not b)) delta
-  | VAR id -> (* En attendant d'avoir des kn pour les Var *)
-     let (b,_,l) = red.r_const in
-      let c = List.mem id l in
-      incr_cnt ((b & not c) or (c & not b)) delta
-  | ZETA -> incr_cnt red.r_zeta zeta
-  | EVAR -> incr_cnt red.r_zeta evar
-  | IOTA -> incr_cnt red.r_iota iota
-  | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*)
-  (* Not for internal use *)
-  | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented"
-
-(* Gives the constant list *)
-let red_get_const red =
-  let b,l1,l2 = red.r_const in
-  let l1' = List.map (fun x -> EvalConstRef x) l1 in
-  let l2' = List.map (fun x -> EvalVarRef x) l2 in
-  b, l1' @ l2'
-fin obsolète **************)
+
 (* specification of the reduction function *)
 
 
@@ -336,8 +173,6 @@ type 'a infos = {
   i_vars : (identifier * constr) list;
   i_tab : (table_key, 'a) Hashtbl.t }
 
-let info_flags info = info.i_flags
-
 let ref_value_cache info ref =
   try
     Some (Hashtbl.find info.i_tab ref)
@@ -447,9 +282,6 @@ and fterm =
 
 let fterm_of v = v.term
 let set_norm v = v.norm <- Norm
-let is_val v = v.norm = Norm
-
-let mk_atom c = {norm=Norm;term=FAtom c}
 
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
@@ -472,7 +304,6 @@ type stack_member =
 
 and stack = stack_member list
 
-let empty_stack = []
 let append_stack v s =
   if Array.length v = 0 then s else
   match s with
@@ -486,52 +317,6 @@ let zshift n s =
     | (_,Zshift(k)::s) -> Zshift(n+k)::s
     | _ -> Zshift(n)::s
 
-let rec stack_args_size = function
-  | Zapp v :: s -> Array.length v + stack_args_size s
-  | Zshift(_)::s -> stack_args_size s
-  | Zupdate(_)::s -> stack_args_size s
-  | _ -> 0
-
-(* When used as an argument stack (only Zapp can appear) *)
-let rec decomp_stack = function
-  | Zapp v :: s ->
-      (match Array.length v with
-          0 -> decomp_stack s
-        | 1 -> Some (v.(0), s)
-        | _ ->
-            Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s)))
-  | _ -> None
-let array_of_stack s =
-  let rec stackrec = function
-  | [] -> []
-  | Zapp args :: s -> args :: (stackrec s)
-  | _ -> assert false
-  in Array.concat (stackrec s)
-let rec stack_assign s p c = match s with
-  | Zapp args :: s ->
-      let q = Array.length args in
-      if p >= q then
-	Zapp args :: stack_assign s (p-q) c
-      else
-        (let nargs = Array.copy args in
-         nargs.(p) <- c;
-         Zapp nargs :: s)
-  | _ -> s
-let rec stack_tail p s =
-  if p = 0 then s else
-    match s with
-      | Zapp args :: s ->
-	  let q = Array.length args in
-	  if p >= q then stack_tail (p-q) s
-	  else Zapp (Array.sub args p (q-p)) :: s
-      | _ -> failwith "stack_tail"
-let rec stack_nth s p = match s with
-  | Zapp args :: s ->
-      let q = Array.length args in
-      if p >= q then stack_nth s (p-q)
-      else args.(p)
-  | _ -> raise Not_found
-
 (* Lifting. Preserves sharing (useful only for cell with norm=Red).
    lft_fconstr always create a new cell, while lift_fconstr avoids it
    when the lift is 0. *)
@@ -643,7 +428,7 @@ let optimise_closure env c =
     let (c',(_,s)) = compact_constr (0,[]) c 1 in
     let env' =
       Array.map (fun i -> clos_rel env i) (Array.of_list s) in
-    (subs_cons (env', ESID 0),c')
+    (subs_cons (env', subs_id 0),c')
 
 let mk_lambda env t =
   let (env,t) = optimise_closure env t in
@@ -774,7 +559,7 @@ let term_of_fconstr =
       | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> Fix fx
       | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> CoFix cfx
       | _ -> to_constr term_of_fconstr_lift lfts v in
-  term_of_fconstr_lift ELID
+  term_of_fconstr_lift el_id
 
 
 
@@ -809,16 +594,6 @@ let fapp_stack (m,stk) = zip m stk
    (strip_update_shift, through get_arg). *)
 
 (* optimised for the case where there are no shifts... *)
-let strip_update_shift head stk =
-  assert (head.norm <> Red);
-  let rec strip_rec h depth = function
-    | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
-    | Zupdate(m)::s ->
-        strip_rec (update m (h.norm,h.term)) depth s
-    | stk -> (depth,stk) in
-  strip_rec head 0 stk
-
-(* optimised for the case where there are no shifts... *)
 let strip_update_shift_app head stk =
   assert (head.norm <> Red);
   let rec strip_rec rstk h depth = function
@@ -835,15 +610,15 @@ let strip_update_shift_app head stk =
 
 let get_nth_arg head n stk =
   assert (head.norm <> Red);
-  let rec strip_rec rstk h depth n = function
+  let rec strip_rec rstk h n = function
     | Zshift(k) as e :: s ->
-        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+        strip_rec (e::rstk) (lift_fconstr k h) n s
     | Zapp args::s' ->
         let q = Array.length args in
         if n >= q
         then
           strip_rec (Zapp args::rstk)
-            {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
+            {norm=h.norm;term=FApp(h,args)} (n-q) s'
         else
           let bef = Array.sub args 0 n in
           let aft = Array.sub args (n+1) (q-n-1) in
@@ -851,9 +626,9 @@ let get_nth_arg head n stk =
             List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
           (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) depth n s
+        strip_rec rstk (update m (h.norm,h.term)) n s
     | s -> (None, List.rev rstk @ s) in
-  strip_rec [] head 0 n stk
+  strip_rec [] 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 *)
@@ -876,6 +651,12 @@ let rec get_args n tys f e stk =
           get_args (n-na) etys f (subs_cons(l,e)) s
     | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
 
+(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
+let rec eta_expand_stack = function
+  | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+      e :: eta_expand_stack s
+  | [] ->
+      [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
 
 (* Iota reduction: extract the arguments to be passed to the Case
    branches *)
@@ -1025,7 +806,7 @@ let kh info v stk = fapp_stack(kni info v stk)
 let whd_val info v =
   with_stats (lazy (term_of_fconstr (kh info v [])))
 
-let inject = mk_clos (ESID 0)
+let inject = mk_clos (subs_id 0)
 
 let whd_stack infos m stk =
   let k = kni infos m stk in
diff --git a/checker/closure.mli b/checker/closure.mli
index 12cee770..707a51f9 100644
--- a/checker/closure.mli
+++ b/checker/closure.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli 9902 2007-06-21 17:01:21Z herbelin $ i*)
-
 (*i*)
 open Pp
 open Names
@@ -32,6 +30,9 @@ type transparent_state = Idpred.t * Cpred.t
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
 
+val is_transparent_variable : transparent_state -> variable -> bool
+val is_transparent_constant : transparent_state -> constant -> bool
+
 (* Sets of reduction kinds. *)
 module type RedFlagsSig = sig
   type reds
@@ -51,33 +52,20 @@ module type RedFlagsSig = sig
   (* Adds a reduction kind to a set *)
   val red_add : reds -> red_kind -> reds
 
-  (* Removes a reduction kind to a set *)
-  val red_sub : reds -> red_kind -> reds
-
-  (* Adds a reduction kind to a set *)
-  val red_add_transparent : reds -> transparent_state -> reds
-
   (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
   val mkflags : red_kind list -> reds
 
   (* Tests if a reduction kind is set *)
   val red_set : reds -> red_kind -> bool
-
-  (* Gives the constant list *)
-  val red_get_const : reds -> bool * evaluable_global_reference list
 end
 
 module RedFlags : RedFlagsSig
 open RedFlags
 
-val beta               : reds
-val betaiota           : reds
 val betadeltaiota      : reds
 val betaiotazeta       : reds
 val betadeltaiotanolet : reds
 
-val unfold_red : evaluable_global_reference -> reds
-
 (***********************************************************************)
 type table_key =
   | ConstKey of constant
@@ -86,7 +74,6 @@ type table_key =
 
 type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
-val info_flags: 'a infos -> reds
 val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos
 
 (************************************************************************)
@@ -132,23 +119,14 @@ type stack_member =
 
 and stack = stack_member list
 
-val empty_stack : stack
 val append_stack : fconstr array -> stack -> stack
-
-val decomp_stack : stack -> (fconstr * stack) option
-val array_of_stack : stack -> fconstr array
-val stack_assign : stack -> int -> fconstr -> stack
-val stack_args_size : stack -> int
-val stack_tail : int -> stack -> stack
-val stack_nth : stack -> int -> fconstr
+val eta_expand_stack : stack -> stack
 
 (* To lazy reduce a constr, create a [clos_infos] with
    [create_clos_infos], inject the term to reduce with [inject]; then use
    a reduction function *)
 
 val inject : constr -> fconstr
-(* mk_atom: prevents a term from being evaluated *)
-val mk_atom : constr -> fconstr
 
 val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
diff --git a/checker/declarations.ml b/checker/declarations.ml
index 0deb80a2..890996d1 100644
--- a/checker/declarations.ml
+++ b/checker/declarations.ml
@@ -20,7 +20,7 @@ type polymorphic_arity = {
   poly_level : Univ.universe;
 }
 let val_pol_arity =
-  val_tuple"polyorphic_arity"[|val_list(val_opt val_univ);val_univ|]
+  val_tuple ~name:"polyorphic_arity"[|val_list(val_opt val_univ);val_univ|]
 
 type constant_type =
   | NonPolymorphicType of constr
@@ -29,256 +29,164 @@ type constant_type =
 let val_cst_type =
   val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|]
 
-
-type substitution_domain =
-  | MBI of mod_bound_id
-  | MPI of module_path
-
-let val_subst_dom =
-  val_sum "substitution_domain" 0 [|[|val_uid|];[|val_mp|]|]
-
-module Umap = Map.Make(struct
-			 type t = substitution_domain
-			 let compare = Pervasives.compare
-		       end)
-
+(** Substitutions, code imported from kernel/mod_subst *)
 
 type delta_hint =
-    Inline of constr option
+  | Inline of int * 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
+module Deltamap = struct
+  type t = module_path MPmap.t * delta_hint KNmap.t
+  let empty = MPmap.empty, KNmap.empty
+  let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
+  let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
+  let remove_mp mp (mm,km) = (MPmap.remove mp mm, km)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_kn kn map = KNmap.find kn (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_kn kn map = KNmap.mem kn (snd map)
+  let fold_kn f map i = KNmap.fold f (snd map) i
+  let fold fmp fkn (mm,km) i =
+    MPmap.fold fmp mm (KNmap.fold fkn km i)
+  let join map1 map2 = fold add_mp add_kn map1 map2
+end
+
+type delta_resolver = Deltamap.t
 
 let empty_delta_resolver = Deltamap.empty
 
+module MBImap = Map.Make
+  (struct
+    type t = mod_bound_id
+    let compare = Pervasives.compare
+   end)
+
+module Umap = struct
+  type 'a t = 'a MPmap.t * 'a MBImap.t
+  let empty = MPmap.empty, MBImap.empty
+  let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2
+  let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2)
+  let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_mbi mbi map = MBImap.find mbi (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_mbi mbi map = MBImap.mem mbi (snd map)
+  let iter_mbi f map = MBImap.iter f (snd map)
+  let fold fmp fmbi (m1,m2) i =
+    MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
+  let join map1 map2 = fold add_mp add_mbi map1 map2
+end
+
 type substitution = (module_path * delta_resolver) Umap.t
 type 'a subst_fun = substitution -> 'a -> 'a
 
-let val_res_dom =
-  val_sum "delta_key" 0 [|[|val_kn|];[|val_mp|]|]
+let empty_subst = Umap.empty
 
-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 is_empty_subst = Umap.is_empty
 
-let val_subst =
-  val_map ~name:"substitution"
-    val_subst_dom (val_tuple "substition range" [|val_mp;val_res|])
+let val_delta_hint =
+  val_sum "delta_hint" 0
+    [|[|val_int; val_opt val_constr|];[|val_kn|]|]
 
+let val_res =
+  val_tuple ~name:"delta_resolver"
+    [|val_map ~name:"delta_resolver" val_mp val_mp;
+      val_map ~name:"delta_resolver" val_kn val_delta_hint|]
 
-let fold_subst fb fp =
-  Umap.fold
-    (fun k (mp,_) acc ->
-      match k with
-        | MBI mbid -> fb mbid mp acc
-        | MPI mp1 -> fp mp1 mp acc)
+let val_mp_res = val_tuple [|val_mp;val_res|]
 
-let empty_subst = Umap.empty
+let val_subst =
+  val_tuple ~name:"substitution"
+    [|val_map ~name:"substitution" val_mp val_mp_res;
+      val_map ~name:"substitution" val_uid val_mp_res|]
 
-let add_mbid mbid mp =
-  Umap.add (MBI mbid) (mp,empty_delta_resolver)
-let add_mp mp1 mp2  =
-  Umap.add (MPI mp1) (mp2,empty_delta_resolver)
+let add_mbid mbid mp = Umap.add_mbi mbid (mp,empty_delta_resolver)
+let add_mp mp1 mp2 = Umap.add_mp mp1 (mp2,empty_delta_resolver)
 
 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 mp_in_delta mp =
+  Deltamap.mem_mp mp
 
-let rec find_prefix resolve mp = 
+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"	
+    | MPdot(mp,l) as mp_sup ->
+	(try Deltamap.find_mp mp_sup resolve
+	 with Not_found -> MPdot(sub_mp mp,l))
+    | p -> Deltamap.find_mp p resolve
   in
-    try 
-      sub_mp mp
-    with
-	Not_found -> mp
-	  
+  try sub_mp mp with Not_found -> mp
+
+(** Nota: the following function is slightly different in mod_subst
+    PL: Is it on purpose ? *)
+
 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
-	      
+  try
+    match Deltamap.find_kn kn resolve with
+      | Equiv kn1 -> kn1
+      | Inline _ -> raise Not_found
+  with Not_found ->
+    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 gen_of_delta resolve x kn fix_can =
+  try
+    let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then x else fix_can new_kn
+  with _ -> x
 
 let 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
-	
+  gen_of_delta resolve con kn (constant_of_kn_equiv 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 kn, kn' = canonical_con con, user_con con in
+  gen_of_delta resolve con kn (constant_of_kn_equiv 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
-
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
 
+let mind_of_delta2 resolve mind =
+  let kn, kn' = canonical_mind mind, user_mind mind in
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
 
-let inline_of_delta resolver = 
-  let extract key hint l =
-    match key,hint with 
-      |KN kn, Inline _ -> kn::l
-      | _,_ -> l
-  in
-    Deltamap.fold extract resolver []
+let find_inline_of_delta kn resolve =
+  match Deltamap.find_kn kn resolve with
+    | Inline (_,o) -> o
+    | _ -> raise Not_found
 
-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
+  try find_inline_of_delta kn2 resolve
+  with Not_found ->
+    try find_inline_of_delta kn1 resolve
+    with Not_found -> None
 
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
-    | MPfile sid -> 
-        let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
-         mp',resolve
+    | MPfile sid -> Umap.find_mp mp sub
     | MPbound bid ->
 	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
+	  try Umap.find_mbi bid sub
+	  with Not_found -> Umap.find_mp mp sub
 	end
     | MPdot (mp1,l) as mp2 ->
 	begin
-	  try
-	    let mp',resolve = Umap.find (MPI mp2) sub in
-              mp',resolve
+	  try Umap.find_mp mp2 sub
 	  with Not_found ->
 	    let mp1',resolve = aux mp1 in
-	      MPdot (mp1',l),resolve
+	    MPdot (mp1',l),resolve
 	end
  in
-  try
-    Some (aux mp)
-  with Not_found -> None
+ try Some (aux mp) with Not_found -> None
 
 let subst_mp sub mp =
  match subst_mp0 sub mp with
@@ -305,127 +213,58 @@ type sideconstantsubst =
   | User
   | Canonical
 
+
+let gen_subst_mp f sub mp1 mp2 =
+  match subst_mp0 sub mp1, subst_mp0 sub mp2 with
+    | None, None -> raise No_subst
+    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
+    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
+    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
+
 let subst_ind sub mind =
-  let kn1,kn2 = user_mind mind,canonical_mind mind in
+  let 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 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 rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+  try
+    let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
+    match side with
+      | User -> mind_of_delta resolve mind'
+      | Canonical -> mind_of_delta2 resolve mind'
+  with No_subst -> mind
 
 let subst_con0 sub con =
   let kn1,kn2 = user_con con,canonical_con con in
   let mp1,dir,l = repr_kn kn1 in
   let mp2,_,_ = repr_kn kn2 in
-    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 
+  let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
+  let dup con = con, Const con in
+  let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
+  match constant_of_delta_with_inline resolve con' with
+    | Some t -> con', t
+    | None ->
+      let con'' = match side with
+	| User -> constant_of_delta resolve con'
+	| Canonical -> constant_of_delta2 resolve con'
       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)
-
+      if con'' == con then raise No_subst else dup con''
 
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match c with
-      | Const kn ->
-	  (match f' kn with
-	       None -> c
-	     | Some const ->const)
+      | Const kn -> (try snd (f' kn) with No_subst -> c)
       | Ind (kn,i) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	      Ind (kn',i))
+	  let kn' = f kn in
+	  if kn'==kn then c else Ind (kn',i)
       | Construct ((kn,i),j) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	       Construct ((kn',i),j))
+	  let kn' = f kn in
+	  if kn'==kn then c else Construct ((kn',i),j)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
-              (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
+	    let kn' = f kn in
+	    if kn'==kn then ci.ci_ind else kn',i
+	  in
 	  let p' = func p in
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
@@ -476,8 +315,9 @@ let rec map_kn f f' c =
 	    else CoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-let subst_mps sub =
-  map_kn (subst_mind0 sub) (subst_con0 sub)
+let subst_mps sub c =
+  if is_empty_subst sub then c
+  else map_kn (subst_ind sub) (subst_con0 sub) c
 
 
 type 'a lazy_subst =
@@ -507,125 +347,113 @@ let rec mp_in_mp mp mp1 =
     | _ 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 =
-    if mp_in_key mp key then
-      Deltamap.add key hint resolv
-    else 
-      resolv
+  let mp_prefix mkey mequ rslv =
+    if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv
+  in
+  let kn_prefix kn hint rslv =
+    match hint with
+      | Inline _ -> rslv
+      | Equiv _ ->
+	if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv
   in
-    Deltamap.fold prefixmp resolver empty_delta_resolver
+  Deltamap.fold mp_prefix kn_prefix 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
+  let mp_apply_subst mkey mequ rslv =
+    Deltamap.add_mp (subst_mp subst mkey) mequ rslv
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  let kn_apply_subst kkey hint rslv =
+    Deltamap.add_kn (subst_kn subst kkey) hint rslv
+  in
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
 
-let subst_mp_delta sub mp key=
+let subst_mp_delta sub mp mkey =
  match subst_mp0 sub mp with
     None -> empty_delta_resolver,mp
-  | Some (mp',resolve) -> 
+  | 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
+      (subst_dom_delta_resolver
+	 (map_mp mp1 mkey) resolve1),mp1
+
+let gen_subst_delta_resolver dom subst resolver =
+  let mp_apply_subst mkey mequ rslv =
+    let mkey' = if dom then subst_mp subst mkey else mkey in
+    let rslv',mequ' = subst_mp_delta subst mequ mkey in
+    Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv)
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  let kn_apply_subst kkey hint rslv =
+    let kkey' = if dom then subst_kn subst kkey else kkey in
+    let hint' = match hint with
+      | Equiv kequ -> Equiv (subst_kn_delta subst kequ)
+      | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t))
+      | Inline (_,None) -> hint
+    in
+    Deltamap.add_kn kkey' hint' rslv
+  in
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
+
+let subst_codom_delta_resolver = gen_subst_delta_resolver false
+let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
 
-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
-      Deltamap.fold apply_res resolver1 empty_delta_resolver
+  let mp_apply_rslv mkey mequ rslv =
+    if Deltamap.mem_mp mkey resolver2 then rslv
+    else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+  in
+  let kn_apply_rslv kkey hint rslv =
+    if Deltamap.mem_kn kkey resolver2 then rslv
+    else
+      let hint' = match hint with
+	| Equiv kequ -> Equiv (solve_delta_kn resolver2 kequ)
+	| _ -> hint
+      in
+      Deltamap.add_kn kkey hint' rslv
+  in
+  Deltamap.fold mp_apply_rslv kn_apply_rslv 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
+    Deltamap.join (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
+  let mp_prefixmp kmp (mp_to,reso) sub =
+    if mp_in_mp mp kmp && mp <> kmp then
+      let new_key = replace_mp_in_mp mp k kmp in
+      Umap.add_mp new_key (mp_to,reso) sub
+    else sub
+  in
+  let mbi_prefixmp mbi _ sub = sub
   in
-    Umap.fold prefixmp subst empty_subst
+  Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst
 
-let join (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst key (mp,resolve) res =
+let join subst1 subst2 =
+  let apply_subst mpk add (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 =
+	| None -> mp, None
+	| Some (mp',resolve') ->  mp', Some resolve' in
+    let resolve'' =
       match resolve' with
-          Some res -> 
-	    add_delta_resolver 
+        | Some res ->
+	    add_delta_resolver
 	      (subst_dom_codom_delta_resolver subst2 resolve) res
-	| None -> 
+	| 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 prefixed_subst = substition_prefixed_by mpk mp' subst2 in
+    Umap.join prefixed_subst (add (mp',resolve'') res)
+  in
+  let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in
+  let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in
+  let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in
+  Umap.join subst2 subst
 
 let force fsubst r =
   match !r with
@@ -650,25 +478,67 @@ let val_cstr_subst = val_substituted val_constr
 
 let subst_constr_subst = subst_substituted
 
+(** Beware! In .vo files, lazy_constr are stored as integers
+   used as indexes for a separate table. The actual lazy_constr is restored
+   later, by [Safe_typing.LightenLibrary.load]. This allows us
+   to use here a different definition of lazy_constr than coqtop:
+   since the checker will inspect all proofs parts, even opaque
+   ones, no need to use Lazy.t here *)
+
+type lazy_constr = constr_substituted
+let subst_lazy_constr = subst_substituted
+let force_lazy_constr = force_constr
+let lazy_constr_from_val c = c
+let val_lazy_constr = val_cstr_subst
+
+(** Inlining level of parameters at functor applications.
+    This is ignored by the checker. *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
+let val_cst_def =
+  val_sum "constant_def" 0
+    [|[|val_opt val_int|]; [|val_cstr_subst|]; [|val_lazy_constr|]|]
+
+let subst_constant_def sub = function
+  | Undef inl -> Undef inl
+  | Def c -> Def (subst_constr_subst sub c)
+  | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
+
 type constant_body = {
     const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : to_patch_substituted;
-   (* const_type_code : Cemitcodes.to_patch; *)
-    const_constraints : Univ.constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : Univ.constraints }
 
-let val_cb = val_tuple "constant_body"
+let body_of_constant cb = match cb.const_body with
+  | Undef _ -> None
+  | Def c -> Some c
+  | OpaqueDef c -> Some c
+
+let constant_has_body cb = match cb.const_body with
+  | Undef _ -> false
+  | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+  | OpaqueDef _ -> true
+  | Def _ | Undef _ -> false
+
+let val_cb = val_tuple ~name:"constant_body"
   [|val_nctxt;
-    val_opt val_cstr_subst;
+    val_cst_def;
     val_cst_type;
     no_val;
-    val_cstrs;
-    val_bool;
-    val_bool |]
-
+    val_cstrs|]
 
 let subst_rel_declaration sub (id,copt,t as x) =
   let copt' = Option.smartmap (subst_mps sub) copt in
@@ -679,14 +549,14 @@ let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
 
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 let val_recarg = val_sum "recarg" 1 (* Norec *)
-  [|[|val_int|] (* Mrec *);[|val_ind|] (* Imbr *)|]
+  [|[|val_ind|] (* Mrec *);[|val_ind|] (* Imbr *)|]
 
 let subst_recarg sub r = match r with
-  | Norec | Mrec _  -> r
-  | Imbr (kn,i) -> let kn' = subst_ind sub kn in
+  | Norec  -> r
+  | (Mrec(kn,i)|Imbr (kn,i)) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
 type wf_paths = recarg Rtree.t
@@ -724,7 +594,7 @@ type monomorphic_inductive_arity = {
   mind_sort : sorts;
 }
 let val_mono_ind_arity =
-  val_tuple"monomorphic_inductive_arity"[|val_constr;val_sort|]
+  val_tuple ~name:"monomorphic_inductive_arity"[|val_constr;val_sort|]
 
 type inductive_arity =
 | Monomorphic of monomorphic_inductive_arity
@@ -784,7 +654,7 @@ type one_inductive_body = {
     mind_reloc_tbl :  reloc_table;
   }
 
-let val_one_ind = val_tuple "one_inductive_body"
+let val_one_ind = val_tuple ~name:"one_inductive_body"
   [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr;
     val_int;val_int;val_list val_sortfam;val_array val_constr;val_array val_int;
     val_wfp;val_int;val_int;no_val|]
@@ -820,7 +690,7 @@ type mutual_inductive_body = {
     mind_constraints : Univ.constraints;
 
   }
-let val_ind_pack = val_tuple "mutual_inductive_body"
+let val_ind_pack = val_tuple ~name:"mutual_inductive_body"
   [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt;
     val_int; val_int; val_rctxt;val_cstrs|]
 
@@ -832,13 +702,10 @@ let subst_arity sub = function
 (* 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_body = subst_constant_def sub cb.const_body;
     const_type = subst_arity sub cb.const_type;
     const_body_code = (*Cemitcodes.subst_to_patch_subst sub*) cb.const_body_code;
-    (*const_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_constraints = cb.const_constraints}
 
 let subst_arity sub = function
 | Monomorphic s ->
@@ -923,7 +790,7 @@ let rec val_sfb o = val_sum "struct_field_body" 0
     [|val_module|];   (* SFBmodule *)
     [|val_modtype|]   (* SFBmodtype *)
   |] o
-and val_sb o = val_list (val_tuple"label*sfb"[|val_id;val_sfb|]) o
+and val_sb o = val_list (val_tuple ~name:"label*sfb"[|val_id;val_sfb|]) o
 and val_seb o = val_sum "struct_expr_body" 0
   [|[|val_mp|];                      (* SEBident *)
     [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *)
@@ -934,10 +801,10 @@ and val_seb o = val_sum "struct_expr_body" 0
 and val_with o = val_sum "with_declaration_body" 0
   [|[|val_list val_id;val_mp|];
     [|val_list val_id;val_cb|]|] o
-and val_module o = val_tuple "module_body"
+and val_module o = val_tuple ~name:"module_body"
   [|val_mp;val_opt val_seb;val_seb;
     val_opt val_seb;val_cstrs;val_res;no_val|] o
-and val_modtype o = val_tuple "module_type_body"
+and val_modtype o = val_tuple ~name:"module_type_body"
   [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o
 
 
diff --git a/checker/declarations.mli b/checker/declarations.mli
index b39fd6f2..90beb326 100644
--- a/checker/declarations.mli
+++ b/checker/declarations.mli
@@ -29,26 +29,53 @@ type constr_substituted
 val force_constr : constr_substituted -> constr
 val from_val : constr -> constr_substituted
 
+(** Beware! In .vo files, lazy_constr are stored as integers
+   used as indexes for a separate table. The actual lazy_constr is restored
+   later, by [Safe_typing.LightenLibrary.load]. This allows us
+   to use here a different definition of lazy_constr than coqtop:
+   since the checker will inspect all proofs parts, even opaque
+   ones, no need to use Lazy.t here *)
+
+type lazy_constr
+val force_lazy_constr : lazy_constr -> constr
+val lazy_constr_from_val : constr_substituted -> lazy_constr
+
+(** Inlining level of parameters at functor applications.
+    This is ignored by the checker. *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
 type constant_body = {
     const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : to_patch_substituted;
-    const_constraints : Univ.constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : Univ.constraints }
+
+val body_of_constant : constant_body -> constr_substituted option
+val constant_has_body : constant_body -> bool
+val is_opaque : constant_body -> bool
 
 (* Mutual inductives *)
 
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 
 type wf_paths = recarg Rtree.t
 
 val mk_norec : wf_paths
 val mk_paths : recarg -> wf_paths list array -> wf_paths
+val dest_recarg : wf_paths -> recarg
 val dest_subterms : wf_paths -> wf_paths list array
 
 type monomorphic_inductive_arity = {
@@ -186,11 +213,6 @@ and module_type_body =
 
 (* Substitutions *)
 
-val fold_subst :
-  (mod_bound_id -> module_path -> 'a -> 'a) ->
-  (module_path -> module_path -> 'a -> 'a) ->
-  substitution -> 'a -> 'a
-
 type 'a subst_fun = substitution -> 'a -> 'a
 
 val empty_subst : substitution
@@ -211,6 +233,6 @@ val subst_module : substitution -> module_body -> module_body
 val join : substitution -> substitution -> substitution
 
 (* Validation *)
-val val_eng : Obj.t -> unit
-val val_module : Obj.t -> unit
-val val_modtype : Obj.t -> unit
+val val_eng : Validate.func
+val val_module : Validate.func
+val val_modtype : Validate.func
diff --git a/checker/environ.ml b/checker/environ.ml
index f7dd46f8..99b36457 100644
--- a/checker/environ.ml
+++ b/checker/environ.ml
@@ -98,7 +98,7 @@ let named_type id env =
 
 (* Universe constraints *)
 let add_constraints c env =
-  if c == Constraint.empty then
+  if c == empty_constraint then
     env
   else
     let s = env.env_stratification in
@@ -121,25 +121,16 @@ let add_constant kn cs env =
 	env_constants = new_constants } in
   { env with env_globals = new_globals }
 
-(* constant_type gives the type of a constant *)
-let constant_type env kn =
-  let cb = lookup_constant kn env in
-  cb.const_type
-
 type const_evaluation_result = NoBody | Opaque
 
 exception NotEvaluableConst of const_evaluation_result
 
 let constant_value env kn =
   let cb = lookup_constant kn env in
-  if cb.const_opaque then raise (NotEvaluableConst Opaque);
   match cb.const_body with
-    | Some l_body -> force_constr l_body
-    | None -> raise (NotEvaluableConst NoBody)
-
-let constant_opt_value env cst =
-  try Some (constant_value env cst)
-  with NotEvaluableConst _ -> None
+    | Def l_body -> force_constr l_body
+    | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+    | Undef _ -> raise (NotEvaluableConst NoBody)
 
 (* A global const is evaluable if it is defined and not opaque *)
 let evaluable_constant cst env =
diff --git a/checker/environ.mli b/checker/environ.mli
index ea446cdb..628febbb 100644
--- a/checker/environ.mli
+++ b/checker/environ.mli
@@ -50,11 +50,9 @@ val add_constraints : Univ.constraints -> env -> env
 (* Constants *)
 val lookup_constant : constant -> env -> Declarations.constant_body
 val add_constant : constant -> Declarations.constant_body -> env -> env
-val constant_type : env -> constant -> Declarations.constant_type
 type const_evaluation_result = NoBody | Opaque
 exception NotEvaluableConst of const_evaluation_result
 val constant_value : env -> constant -> constr
-val constant_opt_value : env -> constant -> constr option
 val evaluable_constant : constant -> env -> bool
 
 (* Inductives *)
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
index 277fed30..1e773df6 100644
--- a/checker/indtypes.ml
+++ b/checker/indtypes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml 10296 2007-11-07 11:02:42Z barras $ *)
-
 open Util
 open Names
 open Univ
@@ -178,7 +176,7 @@ let check_predicativity env s small level =
       Type u, _ ->
         let u' = fresh_local_univ () in
         let cst =
-          merge_constraints (enforce_geq u' u Constraint.empty)
+          merge_constraints (enforce_geq u' u empty_constraint)
             (universes env) in
         if not (check_geq cst u' level) then
           failwith "impredicative Type inductive type"
@@ -394,7 +392,7 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
 
 (* The recursive function that checks positivity and builds the list
    of recursive arguments *)
-let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
+let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc =
   let lparams = rel_context_length hyps in
   (* check the inductive types occur positively in [c] *)
   let rec check_pos (env, n, ntypes, ra_env as ienv) c =
@@ -496,7 +494,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
           with IllFormedInd err ->
             explain_ind_err (ntypes-i) env lparams c err)
       indlc
-  in mk_paths (Mrec i) irecargs
+  in mk_paths (Mrec ind) irecargs
 
 let check_subtree (t1:'a) (t2:'a) =
   if not (Rtree.compare_rtree (fun t1 t2 ->
@@ -507,16 +505,17 @@ let check_subtree (t1:'a) (t2:'a) =
     failwith "bad recursive trees"
 (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*)
 
-let check_positivity env_ar params nrecp inds =
+let check_positivity env_ar mind params nrecp inds =
   let ntypes = Array.length inds in
-  let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in
+  let rc =
+    Array.mapi (fun j t -> (Mrec(mind,j),t)) (Rtree.mk_rec_calls ntypes) in
   let lra_ind = List.rev (Array.to_list rc) in
   let lparams = rel_context_length params in
   let check_one i mip =
     let ra_env =
       list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
-      check_positivity_one ienv params nrecp i mip.mind_nf_lc
+      check_positivity_one ienv params nrecp (mind,i) mip.mind_nf_lc
   in
   let irecargs = Array.mapi check_one inds in
   let wfp = Rtree.mk_rec irecargs in
@@ -549,7 +548,7 @@ let check_inductive env kn mib =
   (*  - check constructor types *)
   Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets;
   (* check mind_nparams_rec: positivity condition *)
-  check_positivity env_ar params mib.mind_nparams_rec mib.mind_packets;
+  check_positivity env_ar kn params mib.mind_nparams_rec mib.mind_packets;
   (* check mind_equiv... *)
   (* Now we can add the inductive *)
   add_mind kn mib env
diff --git a/checker/indtypes.mli b/checker/indtypes.mli
index bca0a643..4c2b078c 100644
--- a/checker/indtypes.mli
+++ b/checker/indtypes.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli 9831 2007-05-17 18:55:42Z herbelin $ i*)
-
 (*i*)
 open Names
 open Univ
diff --git a/checker/inductive.ml b/checker/inductive.ml
index b9964fe6..7a04cbfa 100644
--- a/checker/inductive.ml
+++ b/checker/inductive.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml 10172 2007-10-04 13:02:03Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -83,8 +81,6 @@ let instantiate_params full t args sign =
   if rem_args <> [] then fail();
   substl subs ty
 
-let instantiate_partial_params = instantiate_params false
-
 let full_inductive_instantiate mib params sign =
   let dummy = Prop Null in
   let t = mkArity (sign,dummy) in
@@ -100,10 +96,6 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
 
 (* Functions to build standard types related to inductive *)
 
-
-let number_of_inductives mib = Array.length mib.mind_packets
-let number_of_constructors mip = Array.length mip.mind_consnames
-
 (*
 Computing the actual sort of an applied or partially applied inductive type:
 
@@ -346,14 +338,14 @@ let type_case_branches env (ind,largs) (p,pj) c =
 
 
 (************************************************************************)
-(* Checking the case annotation is relevent *)
+(* Checking the case annotation is relevant *)
 
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
     not (eq_ind indsp ci.ci_ind) or
     (mib.mind_nparams <> ci.ci_npar) or
-    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
+    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -404,8 +396,10 @@ type subterm_spec =
   | Dead_code
   | Not_subterm
 
-let spec_of_tree t =
-  if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t)
+let spec_of_tree t = lazy
+  (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec
+   then Not_subterm
+   else Subterm(Strict,Lazy.force t))
 
 let subterm_spec_glb =
   let glb2 s1 s2 =
@@ -440,7 +434,7 @@ let make_renv env minds recarg (kn,tyi) =
     rel_min = recarg+2;
     inds = minds;
     recvec = mind_recvec;
-    genv = [Lazy.lazy_from_val (Subterm(Large,mind_recvec.(tyi)))] }
+    genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
 
 let push_var renv (x,ty,spec) =
   { renv with
@@ -459,10 +453,6 @@ let subterm_var p renv =
   try Lazy.force (List.nth renv.genv (p-1))
   with Failure _ | Invalid_argument _ -> Not_subterm
 
-(* Add a variable and mark it as strictly smaller with information [spec]. *)
-let add_subterm renv (x,a,spec) =
-  push_var renv (x,a,lazy (spec_of_tree (Lazy.force spec)))
-
 let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
   { renv with
@@ -478,6 +468,15 @@ let push_fix_renv renv (_,v,_ as recdef) =
     genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
 
 
+(* Definition and manipulation of the stack *)
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
+
+let push_stack_closures renv l stack = 
+  List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack
+
+let push_stack_args l stack = 
+  List.fold_right (fun h b -> (SArg h)::b) l stack
+
 (******************************)
 (* Computing the recursive subterms of a term (propagation of size
    information through Cases). *)
@@ -497,60 +496,38 @@ let lookup_subterms env ind =
   let (_,mip) = lookup_mind_specif env ind in
   mip.mind_recargs
 
-(*********************************)
-
-let match_trees t1 t2 =
-  let v1 = dest_subterms t1 in
-  let v2 = dest_subterms t2 in
-  array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+let match_inductive ind ra =
+  match ra with
+    | (Mrec i | Imbr i) -> eq_ind ind i
+    | Norec -> false
 
-(* In {match c as z in ind y_s return P with |C_i x_s => t end}
-   [branches_specif renv c_spec ind] returns an array of x_s specs given
-   c_spec the spec of c. *)
-let branches_specif renv c_spec ind =
-  let (_,mip) = lookup_mind_specif renv.env ind in
+(* In {match c as z in ci y_s return P with |C_i x_s => t end}
+   [branches_specif renv c_spec ci] returns an array of x_s specs knowing
+   c_spec. *)
+let branches_specif renv c_spec ci =
   let car = 
     (* We fetch the regular tree associated to the inductive of the match.
        This is just to get the number of constructors (and constructor
        arities) that fit the match branches without forcing c_spec.
        Note that c_spec might be more precise than [v] below, because of
        nested inductive types. *)
+    let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in
     let v = dest_subterms mip.mind_recargs in
       Array.map List.length v in
     Array.mapi
       (fun i nca -> (* i+1-th cstructor has arity nca *)
 	 let lvra = lazy 
 	   (match Lazy.force c_spec with
-		Subterm (_,t) when match_trees mip.mind_recargs t ->
+		Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
 		  let vra = Array.of_list (dest_subterms t).(i) in
 		  assert (nca = Array.length vra);
-		  Array.map spec_of_tree vra
+		  Array.map
+		    (fun t -> Lazy.force (spec_of_tree (lazy t)))
+		    vra
 	      | Dead_code -> Array.create nca Dead_code
 	      | _ -> Array.create nca Not_subterm) in
 	 list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
-      car
-
-(* Propagation of size information through Cases: if the matched
-   object is a recursive subterm then compute the information
-   associated to its own subterms.
-   Rq: if branch is not eta-long, then the recursive information
-   is not propagated to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr =
-  let vlrec = branches_specif renv c_spec ind in
-  let rec push_branch_args renv lrec c =
-    match lrec with
-        ra::lr ->
-          let c' = whd_betadeltaiota renv.env c in
-          (match c' with
-              Lambda(x,a,b) ->
-                let renv' = push_var renv (x,a,ra) in
-                push_branch_args renv' lr b
-            | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
-                (renv,c'))
-      | [] -> (renv, c) in
-  assert (Array.length vlrec = Array.length lbr);
-  array_map2 (push_branch_args renv) vlrec lbr
- 
+      car 
 
 (* [subterm_specif renv t] computes the recursive structure of [t] and
    compare its size with the size of the initial recursive argument of
@@ -558,78 +535,88 @@ let case_branches_specif renv c_spec ind lbr =
    about variables.
 *)
 
-let rec subterm_specif renv t =
+
+let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
-  match f with
-    | Rel k -> subterm_var k renv
-
-    | Case (ci,_,c,lbr) ->
-        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
-   furthermore when f is applied to a term which is strictly less than
-   n, one may assume that x itself is strictly less than n
-*)
-        let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
-        let oind =
-          let env' = push_rel_context ctxt renv.env in
-          try Some(fst(find_inductive env' clfix))
-          with Not_found -> None in
-        (match oind with
-            None -> Not_subterm (* happens if fix is polymorphic *)
-          | Some ind ->
-              let nbfix = Array.length typarray in
-              let recargs = lookup_subterms renv.env ind in
-              (* pushing the fixpoints *)
-              let renv' = push_fix_renv renv recdef in
-              let renv' =
-                (* Why Strict here ? To be general, it could also be
-                   Large... *)
-                assign_var_spec renv'
-		  (nbfix-i, Lazy.lazy_from_val (Subterm(Strict,recargs))) in
-              let decrArg = recindxs.(i) in
-              let theBody = bodies.(i)   in
-              let nbOfAbst = decrArg+1 in
-              let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
-              (* pushing the fix parameters *)
-              let renv'' = push_ctxt_renv renv' sign in
-              let renv'' =
-                if List.length l < nbOfAbst then renv''
-                else
-                  let theDecrArg  = List.nth l decrArg in
-	          let arg_spec    = lazy_subterm_specif renv theDecrArg in
-                  assign_var_spec renv'' (1, arg_spec) in
-	      subterm_specif renv'' strippedBody)
-
-    | Lambda (x,a,b) ->
-        assert (l=[]);
-        subterm_specif (push_var_renv renv (x,a)) b
-
-    (* Metas and evars are considered OK *)
-    | (Meta _|Evar _) -> Dead_code
-
-    (* Other terms are not subterms *)
-    | _ -> Not_subterm
-
-and lazy_subterm_specif renv t =
-  lazy (subterm_specif renv t)
-
-and case_subterm_specif renv ci c lbr =
-  if Array.length lbr = 0 then [||]
-  else
-    let c_spec = lazy_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 =
-  match subterm_specif renv c with
+    match f with
+      | Rel k -> subterm_var k renv
+
+      | Case (ci,_,c,lbr) ->
+	  let stack' = push_stack_closures renv l stack in
+          let cases_spec = branches_specif renv 
+	    (lazy_subterm_specif renv [] c) ci in
+          let stl  =
+            Array.mapi (fun i br' ->
+			  let stack_br = push_stack_args (cases_spec.(i)) stack' in
+			    subterm_specif renv stack_br br')
+              lbr in
+            subterm_spec_glb stl
+
+      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+	  (* when proving that the fixpoint f(x)=e is less than n, it is enough
+	     to prove that e is less than n assuming f is less than n
+	     furthermore when f is applied to a term which is strictly less than
+	     n, one may assume that x itself is strictly less than n
+	  *)
+          let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+          let oind =
+            let env' = push_rel_context ctxt renv.env in
+              try Some(fst(find_inductive env' clfix))
+              with Not_found -> None in
+            (match oind with
+		 None -> Not_subterm (* happens if fix is polymorphic *)
+               | Some ind ->
+		   let nbfix = Array.length typarray in
+		   let recargs = lookup_subterms renv.env ind in
+		     (* pushing the fixpoints *)
+		   let renv' = push_fix_renv renv recdef in
+		   let renv' =
+                     (* Why Strict here ? To be general, it could also be
+			Large... *)
+                     assign_var_spec renv'
+		       (nbfix-i, lazy (Subterm(Strict,recargs))) in
+		   let decrArg = recindxs.(i) in
+		   let theBody = bodies.(i)   in
+		   let nbOfAbst = decrArg+1 in
+		   let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+		     (* pushing the fix parameters *)
+		   let stack' = push_stack_closures renv l stack in
+		   let renv'' = push_ctxt_renv renv' sign in
+		   let renv'' =
+                     if List.length stack' < nbOfAbst then renv''
+                     else
+		       let decrArg = List.nth stack' decrArg in
+                       let arg_spec = stack_element_specif decrArg in
+			 assign_var_spec renv'' (1, arg_spec) in
+		     subterm_specif renv'' [] strippedBody)
+
+      | Lambda (x,a,b) ->
+          assert (l=[]);
+	  let spec,stack' = extract_stack renv a stack in
+	    subterm_specif (push_var renv (x,a,spec)) stack' b
+
+      (* Metas and evars are considered OK *)
+      | (Meta _|Evar _) -> Dead_code
+
+      (* Other terms are not subterms *)
+      | _ -> Not_subterm
+
+and lazy_subterm_specif renv stack t =
+  lazy (subterm_specif renv stack t)
+
+and stack_element_specif = function
+  |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h
+  |SArg x -> x
+
+and extract_stack renv a = function
+  | [] -> Lazy.lazy_from_val Not_subterm , []
+  | h::t -> stack_element_specif h, t
+
+
+(* Check size x is a correct size for recursive calls. *)
+let check_is_subterm x =
+  match Lazy.force x with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
 
@@ -637,7 +624,7 @@ let check_is_subterm renv c =
 
 exception FixGuardError of env * guard_error
 
-let error_illegal_rec_call renv fx arg =
+let error_illegal_rec_call renv fx (arg_renv,arg) =
   let (_,le_vars,lt_vars) =
     List.fold_left
       (fun (i,le,lt) sbt ->
@@ -647,7 +634,8 @@ let error_illegal_rec_call renv fx arg =
           | _ -> (i+1, le ,lt))
       (1,[],[]) renv.genv in
   raise (FixGuardError (renv.env,
-                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+                        RecursionOnIllegalTerm(fx,(arg_renv.env, arg),
+					       le_vars,lt_vars)))
 
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
@@ -659,48 +647,57 @@ let check_one_fix renv recpos def =
   let nfi = Array.length recpos in
 
   (* Checks if [t] only make valid recursive calls *)
-  let rec check_rec_call renv t =
+  let rec check_rec_call renv stack t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
-      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
+      let (f,l) = decompose_app (whd_betaiotazeta t) in
       match f with
         | Rel p ->
             (* Test if [p] is a fixpoint (recursive call) *)
 	    if renv.rel_min <= p & p < renv.rel_min+nfi then
               begin
-                List.iter (check_rec_call renv) l;
+                List.iter (check_rec_call renv []) l;
                 (* the position of the invoked fixpoint: *)
 	        let glob = renv.rel_min+nfi-1-p in
                 (* the decreasing arg of the rec call: *)
 	        let np = recpos.(glob) in
-                if List.length l <= np then error_partial_apply renv glob
+		let stack' = push_stack_closures renv l stack in
+                if List.length stack' <= np then error_partial_apply renv glob
                 else
                   (* Check the decreasing arg is smaller *)
-                  let z = List.nth l np in
-	          if not (check_is_subterm renv z) then
-                    error_illegal_rec_call renv glob z
+                  let z = List.nth stack' np in
+	          if not (check_is_subterm (stack_element_specif z)) then
+                    begin match z with
+		      |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') 
+		      |SArg _ -> error_partial_apply renv glob
+		    end
               end
             else
               begin
                 match pi2 (lookup_rel p renv.env) with
                 | None ->
-                    List.iter (check_rec_call renv) l
+                    List.iter (check_rec_call renv []) l
                 | Some c ->
-                    try List.iter (check_rec_call renv) l
-                    with FixGuardError _ -> check_rec_call renv (applist(c,l))
+                    try List.iter (check_rec_call renv []) l
+                    with FixGuardError _ ->
+                      check_rec_call renv stack (applist(lift p c,l))
               end
-
+		
         | Case (ci,p,c_0,lrest) ->
-            List.iter (check_rec_call renv) (c_0::p::l);
+            List.iter (check_rec_call renv []) (c_0::p::l);
             (* compute the recarg information for the arguments of
                each branch *)
-            let lbr = case_subterm_specif renv ci c_0 lrest in
-            Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+            let case_spec = branches_specif renv 
+	      (lazy_subterm_specif renv [] c_0) ci in
+	    let stack' = push_stack_closures renv l stack in
+              Array.iteri (fun k br' -> 
+			     let stack_br = push_stack_args case_spec.(k) stack' in
+			     check_rec_call renv stack_br br') lrest
 
         (* Enables to traverse Fixpoint definitions in a more intelligent
            way, ie, the rule :
-           if - g = Fix g/p := [y1:T1]...[yp:Tp]e &
+           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
@@ -710,81 +707,80 @@ let check_one_fix renv recpos def =
                 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;
+            List.iter (check_rec_call renv []) l;
+            Array.iter (check_rec_call renv []) typarray;
             let decrArg = recindxs.(i) in
             let renv' = push_fix_renv renv recdef in
-            if (List.length l < (decrArg+1)) then
-	      Array.iter (check_rec_call renv') bodies
-            else
+	    let stack' = push_stack_closures renv l stack in
               Array.iteri
                 (fun j body ->
-                  if i=j then
-                    let theDecrArg  = List.nth l decrArg in
-	            let arg_spec = lazy_subterm_specif renv theDecrArg in
-	            check_nested_fix_body renv' (decrArg+1) arg_spec body
-                  else check_rec_call renv' body)
+                   if i=j && (List.length stack' > decrArg) then
+		     let recArg = List.nth stack' decrArg in
+	             let arg_sp = stack_element_specif recArg in
+	             check_nested_fix_body renv' (decrArg+1) arg_sp body
+                   else check_rec_call renv' [] body)
                 bodies
 
         | Const kn ->
             if evaluable_constant kn renv.env then
-              try List.iter (check_rec_call renv) l
+              try List.iter (check_rec_call renv []) l
               with (FixGuardError _ ) ->
-	        check_rec_call renv(applist(constant_value renv.env kn, l))
-	    else List.iter (check_rec_call renv) l
-
-        (* The cases below simply check recursively the condition on the
-           subterms *)
-        | Cast (a,_, b) ->
-            List.iter (check_rec_call renv) (a::b::l)
+		let value = (applist(constant_value renv.env kn, l)) in
+	        check_rec_call renv stack value
+	    else List.iter (check_rec_call renv []) l
 
         | Lambda (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = []);
+	    check_rec_call renv [] a ;
+	    let spec, stack' = extract_stack renv a stack in
+	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = [] && stack = []);
+            check_rec_call renv [] a;
+            check_rec_call (push_var_renv renv (x,a)) [] b
 
         | CoFix (i,(_,typarray,bodies as recdef)) ->
-            List.iter (check_rec_call renv) l;
-	    Array.iter (check_rec_call renv) typarray;
+            List.iter (check_rec_call renv []) l;
+	    Array.iter (check_rec_call renv []) typarray;
 	    let renv' = push_fix_renv renv recdef in
-	    Array.iter (check_rec_call renv') bodies
+	    Array.iter (check_rec_call renv' []) bodies
 
-        | (Ind _ | Construct _ | Sort _) ->
-            List.iter (check_rec_call renv) l
+        | (Ind _ | Construct _) ->
+            List.iter (check_rec_call renv []) l
 
         | Var id ->
             begin
               match pi2 (lookup_named id renv.env) with
               | None ->
-                  List.iter (check_rec_call renv) l
+                  List.iter (check_rec_call renv []) l
               | Some c ->
-                  try List.iter (check_rec_call renv) l
-                  with (FixGuardError _) -> check_rec_call renv (applist(c,l))
+                  try List.iter (check_rec_call renv []) l
+                  with (FixGuardError _) -> 
+		    check_rec_call renv stack (applist(c,l))
             end
 
+	| Sort _ -> assert (l = [])
+
         (* l is not checked because it is considered as the meta's context *)
         | (Evar _ | Meta _) -> ()
 
-        | (App _|LetIn _) -> assert false (* beta zeta reduction *)
+        | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
 
   and check_nested_fix_body renv decr recArgsDecrArg body =
     if decr = 0 then
-      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
     else
       match body with
 	| Lambda (x,a,b) ->
-	    check_rec_call renv a;
+	    check_rec_call renv [] a;
             let renv' = push_var_renv renv (x,a) in
-	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+	      check_nested_fix_body renv' (decr-1) recArgsDecrArg b
 	| _ -> anomaly "Not enough abstractions in fix body"
-
+	    
   in
-  check_rec_call renv def
+  check_rec_call renv [] def
 
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
diff --git a/checker/inductive.mli b/checker/inductive.mli
index e658a798..2cf7c70d 100644
--- a/checker/inductive.mli
+++ b/checker/inductive.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli 9420 2006-12-08 15:34:09Z barras $ i*)
-
 (*i*)
 open Names
 open Term
@@ -80,6 +78,7 @@ type guard_env =
     genv    : subterm_spec Lazy.t list;
   }
 
-val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
-  constr array -> (guard_env * constr) array
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
+val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
+val branches_specif : guard_env -> subterm_spec Lazy.t -> case_info ->
+  subterm_spec Lazy.t list array
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
index 95387cac..9942816d 100644
--- a/checker/mod_checking.ml
+++ b/checker/mod_checking.ml
@@ -21,8 +21,8 @@ let refresh_arity ar =
       Sort (Type u) when not (Univ.is_univ_variable u) ->
         let u' = Univ.fresh_local_univ() in
         mkArity (ctxt,Type u'),
-        Univ.enforce_geq u' u Univ.Constraint.empty
-    | _ -> ar, Univ.Constraint.empty
+        Univ.enforce_geq u' u Univ.empty_constraint
+    | _ -> ar, Univ.empty_constraint
 
 let check_constant_declaration env kn cb =
   Flags.if_verbose msgnl (str "  checking cst: " ++ prcon kn);
@@ -33,7 +33,7 @@ let check_constant_declaration env kn cb =
         let ty, cu = refresh_arity ty in
         let envty = add_constraints cu env' in
         let _ = infer_type envty ty in
-        (match cb.const_body with
+        (match body_of_constant cb with
           | Some bd ->
               let j = infer env' (force_constr bd) in
               conv_leq envty j ty
@@ -58,13 +58,6 @@ 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
-  |  []  -> (e,[],[])
-  |  h::t ->
-       let e',h1',h2' = f e h in
-       let e'',t1',t2' = list_fold_map2 f e' t in
-	 e'',h1'::t1',h2'::t2'
-
 let check_definition_sub env cb1 cb2 =
   let check_type env t1 t2 =
 
@@ -117,14 +110,19 @@ let check_definition_sub env cb1 cb2 =
   let typ1 = Typeops.type_of_constant_type env cb1.const_type in
   let typ2 = Typeops.type_of_constant_type env cb2.const_type in
   check_type env typ1 typ2;
-  (match cb2 with
-    | {const_body=Some lc2;const_opaque=false} ->
-	let c2 = force_constr lc2 in
-	let c1 = match cb1.const_body with
-	  | Some lc1 -> force_constr lc1
-	  | None -> assert false in
-	Reduction.conv env c1 c2
-    | _ -> ())
+  (* In the spirit of subtyping.check_constant, we accept
+     any implementations of parameters and opaques terms,
+     as long as they have the right type *)
+  (match cb2.const_body with
+    | Undef _ | OpaqueDef _ -> ()
+    | Def lc2 ->
+	(match cb1.const_body with
+	  | Def lc1 ->
+	    let c1 = force_constr lc1 in
+            let c2 = force_constr lc2 in
+	    Reduction.conv env c1 c2
+	  (* Coq only places transparent cb in With_definition_body *)
+	  | _ -> assert false))
 
 let lookup_modtype mp env =
   try Environ.lookup_modtype mp env
@@ -259,14 +257,14 @@ and check_module env mp mb =
 	  {typ_mp=mp;
 	   typ_expr=sign;
 	   typ_expr_alg=None;
-	   typ_constraints=Univ.Constraint.empty;
+	   typ_constraints=Univ.empty_constraint;
 	   typ_delta = mb.mod_delta;}
 	and mtb2 =
 	  {typ_mp=mp;
 	   typ_expr=mb.mod_type;
 	   typ_expr_alg=None;
-	   typ_constraints=Univ.Constraint.empty;
-	   typ_delta = mb.mod_delta;};
+	   typ_constraints=Univ.empty_constraint;
+	   typ_delta = mb.mod_delta;}
 	in
 	let env = add_module (module_body_of_type mp mtb1) env in
 	check_subtypes env mtb1 mtb2
diff --git a/parsing/g_intsyntax.mli b/checker/mod_checking.mli
index de85b6af..8021ed0f 100644
--- a/parsing/g_intsyntax.mli
+++ b/checker/mod_checking.mli
@@ -1,13 +1,9 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-
-(*i $$ i*)
-
-
-(* digit based syntax for int31 and bigint *)
+val check_module : Environ.env -> Names.module_path -> Declarations.module_body -> unit
diff --git a/checker/modops.ml b/checker/modops.ml
index 38aeaee2..2dc5d062 100644
--- a/checker/modops.ml
+++ b/checker/modops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml 9872 2007-05-30 16:01:18Z soubiran $ i*)
-
 (*i*)
 open Util
 open Pp
@@ -25,8 +23,6 @@ let error_not_a_functor _ = error "Application of not a functor"
 
 let error_incompatible_modtypes _ _ = error "Incompatible module types"
 
-let error_not_equal _ _ = error "Not equal modules"
-
 let error_not_match l _ =
   error ("Signature components for label "^string_of_label l^" do not match")
 
@@ -61,11 +57,6 @@ let destr_functor env mtb =
       	    (arg_id,arg_t,body_t)
   | _ -> error_not_a_functor mtb
 
-
-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;
@@ -75,14 +66,6 @@ let module_body_of_type mp mtb =
     mod_delta = mtb.typ_delta;
     mod_retroknowledge = []}
 
-let check_modpath_equiv env mp1 mp2 = 
-  if mp1=mp2 then () else
- (*   let mb1=lookup_module  mp1 env in
-    let mb2=lookup_module mp2 env in
-      if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2)
-      then ()
-      else*) error_not_equal mp1 mp2
-
 let rec add_signature mp sign resolver env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
@@ -112,23 +95,16 @@ and add_module mb env =
 
 
 let strengthen_const mp_from l cb resolver =
-  match cb.const_opaque, cb.const_body with
-  | false, Some _ -> cb
-  | true, Some _ 
-  | _, None ->
+  match cb.const_body with
+    | Def _ -> cb
+    | _ ->
       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;
-	}
-	  
+      (* let con =  constant_of_delta resolver con in*)
+      { cb with const_body = Def (Declarations.from_val (Const con)) }
 
 let rec strengthen_mod mp_from mp_to mb =
   if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then
-    mb 
+    mb
   else
     match mb.mod_type with
      | SEBstruct (sign) -> 
@@ -154,34 +130,33 @@ and strengthen_sig mp_from sign mp_to resolver =
 	resolve_out,item'::rest'
     | (_,SFBmind _ as item):: rest ->
 	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item::rest'
+	  resolve_out,item::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
 	let mp_to' = MPdot(mp_to,l) in
 	let mb_out = strengthen_mod mp_from' mp_to' mb in
 	let item' = l,SFBmodule (mb_out) in
 	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out, item'::rest'
-    | (l,SFBmodtype mty as item) :: rest ->
+	resolve_out (*add_delta_resolver resolve_out mb.mod_delta*),
+	item':: rest'
+    | (l,SFBmodtype mty as item) :: rest -> 
 	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out, item::rest'
+	resolve_out,item::rest'
 
 let strengthen mtb mp =
     match mtb.typ_expr with
-      | SEBstruct (sign) ->
+      | SEBstruct (sign) -> 
 	  let resolve_out,sign_out =
-	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta
-	  in
-	  {mtb with
-	    typ_expr = SEBstruct(sign_out);
-	    typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta
+	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
+	    {mtb with
+	       typ_expr = SEBstruct(sign_out);
+	       typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta
 		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)}
       | SEBfunctor _ -> mtb
       | _ -> anomaly "Modops:the evaluation of the structure failed "
 
 let subst_and_strengthen mb mp =
-  strengthen_mod mb.mod_mp mp
-    (subst_module (map_mp mb.mod_mp mp) mb)
+  strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb)
 
 
 let module_type_of_module mp mb =
diff --git a/checker/modops.mli b/checker/modops.mli
index 2f9f2e8c..5ed7b0ce 100644
--- a/checker/modops.mli
+++ b/checker/modops.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli 9821 2007-05-11 17:00:58Z aspiwack $ i*)
-
 (*i*)
 open Util
 open Names
@@ -33,8 +31,6 @@ val add_signature : module_path -> structure_body -> delta_resolver -> env -> en
 (* adds a module and its components, but not the constraints *)
 val add_module : module_body ->  env -> env
 
-val check_modpath_equiv : env -> module_path -> module_path -> unit
-
 val strengthen : module_type_body -> module_path -> module_type_body
 
 val subst_and_strengthen : module_body -> module_path -> module_body
diff --git a/checker/reduction.ml b/checker/reduction.ml
index ba8ceeef..3aeaa102 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
-
 open Util
 open Names
 open Term
@@ -80,11 +78,11 @@ let pure_stack lfts stk =
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
 
-let whd_betaiotazeta env x =
+let whd_betaiotazeta x =
   match x with
     | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> x
-    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
+    | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x)
 
 let whd_betadeltaiota env t =
   match t with
@@ -107,15 +105,6 @@ 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                               *)
 (********************************************************************)
@@ -219,7 +208,7 @@ let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 =
 and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
   Util.check_for_interrupt ();
   (* First head reduce both terms *)
-  let rec  whd_both (t1,stk1) (t2,stk2) =
+  let rec whd_both (t1,stk1) (t2,stk2) =
     let st1' = whd_stack infos t1 stk1 in
     let st2' = whd_stack infos t2 stk2 in
     (* Now, whd_stack on term2 might have modified st1 (due to sharing),
@@ -279,20 +268,10 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
 		    | None -> raise NotConvertible) in
           eqappr univ cv_pb infos app1 app2)
 
-    (* only one constant, defined var or defined rel *)
-    | (FFlex fl1, _)      ->
-        (match unfold_reference infos fl1 with
-           | Some def1 ->
-	       eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2
-           | None -> raise NotConvertible)
-    | (_, FFlex fl2)      ->
-        (match unfold_reference infos fl2 with
-           | Some def2 ->
-	       eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2)
-           | None -> raise NotConvertible)
-
     (* other constructors *)
     | (FLambda _, FLambda _) ->
+        (* Inconsistency: we tolerate that v1, v2 contain shift and update but
+           we throw them away *)
         assert (is_empty_stack v1 && is_empty_stack v2);
         let (_,ty1,bd1) = destFLambda mk_clos hd1 in
         let (_,ty2,bd2) = destFLambda mk_clos hd2 in
@@ -305,6 +284,32 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
         ccnv univ CONV infos el1 el2 c1 c'1;
         ccnv univ cv_pb infos (el_lift el1) (el_lift el2) c2 c'2
 
+    (* Eta-expansion on the fly *)
+    | (FLambda _, _) ->
+        if v1 <> [] then
+          anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
+        eqappr univ CONV infos
+          (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2))
+    | (_, FLambda _) ->
+        if v2 <> [] then
+          anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
+        eqappr univ CONV infos
+          (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[]))
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 ->
+	       eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 ->
+	       eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2)
+           | None -> raise NotConvertible)
+
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
      | (FInd ind1, FInd ind2) ->
@@ -367,37 +372,18 @@ and convert_vect univ infos lft1 lft2 v1 v2 =
 let clos_fconv cv_pb env t1 t2 =
   let infos = create_clos_infos betaiotazeta env in
   let univ = universes env in
-  ccnv univ cv_pb infos ELID ELID (inject t1) (inject t2)
+  ccnv univ cv_pb infos el_id el_id (inject t1) (inject t2)
 
 let fconv cv_pb env t1 t2 =
   if eq_constr t1 t2 then ()
   else clos_fconv cv_pb env t1 t2
 
-let conv_cmp = fconv
 let conv = fconv CONV
 let conv_leq = fconv CUMUL
 
-let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i
-    (fun i _ t1 t2 ->
-      (try conv_leq env t1 t2
-      with (NotConvertible|Invalid_argument _) ->
-        raise (NotConvertibleVect i));
-      ())
-    ()
-    v1
-    v2
-
-(* option for conversion *)
-
-let vm_conv = ref fconv
-let set_vm_conv f = vm_conv := f
-let vm_conv cv_pb env t1 t2 =
-  try
-    !vm_conv cv_pb env t1 t2
-  with Not_found | Invalid_argument _ ->
-      (* If compilation fails, fall-back to closure conversion *)
-      clos_fconv cv_pb env t1 t2
+(* option for conversion : no compilation for the checker *)
+
+let vm_conv = fconv
 
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
@@ -452,9 +438,3 @@ let dest_arity env c =
     | Sort s -> l,s
     | _ -> error "not an arity"
 
-let is_arity env c =
-  try
-    let _ = dest_arity env c in
-    true
-  with UserError _ -> false
-
diff --git a/checker/reduction.mli b/checker/reduction.mli
index 8e69da44..6695fd03 100644
--- a/checker/reduction.mli
+++ b/checker/reduction.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
-
 (*i*)
 open Term
 open Environ
@@ -16,7 +14,7 @@ open Environ
 (************************************************************************)
 (*s Reduction functions *)
 
-val whd_betaiotazeta        : env -> constr -> constr
+val whd_betaiotazeta        : constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
 val whd_betadeltaiota_nolet : env -> constr -> constr
 
@@ -31,7 +29,6 @@ type conv_pb = CONV | CUMUL
 
 val conv           : constr conversion_function
 val conv_leq       : constr conversion_function
-val conv_leq_vecti : constr array conversion_function
 
 val vm_conv : conv_pb -> constr conversion_function
 
@@ -40,9 +37,6 @@ val vm_conv : conv_pb -> constr conversion_function
 (* Builds an application node, reducing beta redexes it may produce. *)
 val beta_appvect : constr -> constr array -> constr
 
-(* 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
 
@@ -54,4 +48,3 @@ val dest_prod       : env -> constr -> rel_context * constr
 val dest_prod_assum : env -> constr -> rel_context * constr
 
 val dest_arity : env -> constr -> arity
-val is_arity   : env -> constr -> bool
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
index a669c5e8..bc067dc5 100644
--- a/checker/safe_typing.ml
+++ b/checker/safe_typing.ml
@@ -1,19 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml 10275 2007-10-30 11:01:24Z barras $ *)
-
 open Pp
 open Util
 open Names
 open Declarations
 open Environ
-open Mod_checking
 
 (************************************************************************)
 (*
@@ -21,7 +18,6 @@ open Mod_checking
  *)
 
 let genv = ref empty_env
-let reset () = genv := empty_env
 let get_env () = !genv
 
 let set_engagement c =
@@ -63,51 +59,116 @@ let check_imports f caller env needed =
   List.iter check needed
 
 
-
-(* Remove the body of opaque constants in modules *)
-(* also remove mod_expr ? Good idea!*)
-let rec lighten_module mb =
-  { mb with
-    mod_expr = Option.map lighten_modexpr mb.mod_expr;
-    mod_type = lighten_modexpr mb.mod_type }
-
-and lighten_struct struc =
-  let lighten_body (l,body) = (l,match body with
-    | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
-    | (SFBconst _ | SFBmind _ ) as x -> x
-    | SFBmodule m -> SFBmodule (lighten_module m)
-    | SFBmodtype m -> SFBmodtype
-	({m with
-	    typ_expr = lighten_modexpr m.typ_expr}))
-  in
-    List.map lighten_body struc
-
-and lighten_modexpr = function
-  | SEBfunctor (mbid,mty,mexpr) ->
-      SEBfunctor (mbid,
-		    ({mty with
-			typ_expr = lighten_modexpr mty.typ_expr}),
-		  lighten_modexpr mexpr)
-  | SEBident mp as x -> x
-  | SEBstruct ( 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)
-
-let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
-
-
 type compiled_library =
     dir_path *
     module_body *
     (dir_path * Digest.t) list *
     engagement option
 
+ (* Store the body of modules' opaque constants inside a table.  
+
+    This module is used during the serialization and deserialization
+    of vo files. 
+
+    By adding an indirection to the opaque constant definitions, we
+    gain the ability not to load them. As these constant definitions
+    are usually big terms, we save a deserialization time as well as
+    some memory space. *)
+module LightenLibrary : sig
+  type table 
+  type lightened_compiled_library 
+  val load : table -> lightened_compiled_library -> compiled_library
+end = struct
+
+  (* The table is implemented as an array of [constr_substituted].
+     Keys are hence integers. To avoid changing the [compiled_library]
+     type, we brutally encode integers into [lazy_constr]. This isn't
+     pretty, but shouldn't be dangerous since the produced structure
+     [lightened_compiled_library] is abstract and only meant for writing
+     to .vo via Marshal (which doesn't care about types).
+  *)
+  type table = constr_substituted array
+  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
+
+  (* To avoid any future misuse of the lightened library that could 
+     interpret encoded keys as real [constr_substituted], we hide 
+     these kind of values behind an abstract datatype. *)
+  type lightened_compiled_library = compiled_library
+
+  (* Map a [compiled_library] to another one by just updating 
+     the opaque term [t] to [on_opaque_const_body t]. *)
+  let traverse_library on_opaque_const_body =
+    let rec traverse_module mb =
+      match mb.mod_expr with 
+	  None -> 
+	    { mb with
+		mod_expr = None;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }
+	| Some impl when impl == mb.mod_type-> 
+	    let mtb =  traverse_modexpr mb.mod_type in 
+	      { mb with
+		  mod_expr = Some mtb;
+		  mod_type = mtb;
+	      }    
+	| Some impl -> 
+	    { mb with
+		mod_expr = Option.map traverse_modexpr mb.mod_expr;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }    
+    and traverse_struct struc =
+      let traverse_body (l,body) = (l,match body with
+	| (SFBconst cb) when is_opaque cb ->
+	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
+	| (SFBconst _ | SFBmind _ ) as x -> 
+	  x
+	| SFBmodule m -> 
+	  SFBmodule (traverse_module m)
+	| SFBmodtype m -> 
+	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
+      in
+      List.map traverse_body struc
+	
+    and traverse_modexpr = function
+      | SEBfunctor (mbid,mty,mexpr) ->
+	SEBfunctor (mbid,
+		    ({mty with
+		      typ_expr = traverse_modexpr mty.typ_expr}),
+		    traverse_modexpr mexpr)
+      | SEBident mp as x -> x
+      | SEBstruct (struc) ->
+	SEBstruct  (traverse_struct struc)
+      | SEBapply (mexpr,marg,u) ->
+	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
+      | SEBwith (seb,wdcl) ->
+	SEBwith (traverse_modexpr seb,wdcl)
+    in
+    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
+
+  (* Loading is also a traversing that decodes the embedded keys that
+     are inside the [lightened_library]. If the [load_proof] flag is
+     set, we lookup inside the table to graft the
+     [constr_substituted]. Otherwise, we set the [const_body] field
+     to [None]. 
+  *)
+  let load table lightened_library =
+    let decode_key = function
+      | Undef _ | Def _ -> assert false
+      | OpaqueDef k ->
+          let k = key_of_lazy_constr k in
+	  let body =
+	    try table.(k)
+	    with _ -> error "Error while retrieving an opaque body"
+	  in
+	  OpaqueDef (lazy_constr_from_val body)
+    in
+    traverse_library decode_key lightened_library
+
+end
+
 open Validate
-let val_deps = val_list (val_tuple"dep"[|val_dp;no_val|])
-let val_vo = val_tuple "vo" [|val_dp;val_module;val_deps;val_opt val_eng|]
+let val_deps = val_list (val_tuple ~name:"dep"[|val_dp;no_val|])
+let val_vo = val_tuple ~name:"vo" [|val_dp;val_module;val_deps;val_opt val_eng|]
 
 (* This function should append a certificate to the .vo file.
    The digest must be part of the certicate to rule out attackers
@@ -124,15 +185,15 @@ let import file (dp,mb,depends,engmt as vo) digest =
   let env = !genv in
   check_imports msg_warning dp env depends;
   check_engagement env engmt;
-  check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb;
+  Mod_checking.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 =
-(*  if !Flags.debug then Validate.apply !Flags.debug val_vo vo;*)
+let unsafe_import file (dp,mb,depends,engmt as vo) digest =
+  if !Flags.debug then ignore vo; (*Validate.apply !Flags.debug val_vo vo;*)
   let env = !genv in
   check_imports (errorlabstrm"unsafe_import") dp env depends;
   check_engagement env engmt;
diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli
index 00aa1a84..cd2c06d2 100644
--- a/checker/safe_typing.mli
+++ b/checker/safe_typing.mli
@@ -1,20 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli 9821 2007-05-11 17:00:58Z aspiwack $ i*)
-
 (*i*)
 open Names
 open Term
 open Environ
 (*i*)
 
-val reset : unit -> unit
 val get_env : unit -> env
 
 (* exporting and importing modules *)
@@ -25,3 +22,19 @@ val import         :
   System.physical_path -> compiled_library -> Digest.t -> unit
 val unsafe_import  :
   System.physical_path -> compiled_library -> Digest.t -> unit
+
+(** Store the body of modules' opaque constants inside a table. 
+
+    This module is used during the serialization and deserialization
+    of vo files. 
+*)
+module LightenLibrary :
+sig
+  type table 
+  type lightened_compiled_library 
+
+  (** [load table lcl] builds a compiled library from a
+      lightened library [lcl] by remplacing every index by its related
+      opaque terms inside [table]. *)
+  val load : table -> lightened_compiled_library -> compiled_library
+end
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
index 4f113cf9..0c97254b 100644
--- a/checker/subtyping.ml
+++ b/checker/subtyping.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml 10664 2008-03-14 11:27:37Z soubiran $ i*)
-
 (*i*)
 open Util
 open Names
@@ -239,22 +237,29 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
     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
-               | _ -> ())
+	let cb1 = subst_const_body subst1 cb1 in
+	let cb2 = subst_const_body subst2 cb2 in
+	(*Start by checking types*)
+	let typ1 = Typeops.type_of_constant_type env cb1.const_type in
+	let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+	check_type env typ1 typ2;
+	(* Now we check the bodies:
+	 - A transparent constant can only be implemented by a compatible
+	   transparent constant.
+         - In the signature, an opaque is handled just as a parameter:
+           anything of the right type can implement it, even if bodies differ.
+	*)
+	(match cb2.const_body with
+	  | Undef _ | OpaqueDef _ -> ()
+	  | Def lc2 ->
+	    (match cb1.const_body with
+	      | Undef _ | OpaqueDef _ -> error ()
+	      | Def lc1 ->
+	        (* NB: cb1 might have been strengthened and appear as transparent.
+	           Anyway [check_conv] will handle that afterwards. *)
+		let c1 = force_constr lc1 in
+		let c2 = force_constr lc2 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 " ^
@@ -262,7 +267,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
 		      "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 () ;
+      if constant_has_body cb2 then error () ;
       let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
        check_conv conv_leq env arity1 typ2
@@ -273,7 +278,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
        "constructor and give a definition to map the old name to the new " ^
        "name."));
       assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if cb2.const_body <> None then error () ;
+      if constant_has_body cb2 then error () ;
       let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
        check_conv conv env ty1 ty2
@@ -281,7 +286,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
 
 let rec check_modules  env msb1 msb2 subst1 subst2 =
   let mty1 = module_type_of_module None msb1 in
-  let mty2 =  module_type_of_module None msb2 in
+  let mty2 = module_type_of_module None msb2 in
     check_modtypes env mty1 mty2 subst1 subst2 false;
  
 
@@ -363,11 +368,5 @@ and check_modtypes  env mtb1 mtb2 subst1 subst2 equiv =
      else check_structure  env mtb1' mtb2' equiv subst1 subst2
 
 let check_subtypes env sup super =
-  (*if sup<>super then*)
   check_modtypes env (strengthen 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 empty_subst 
-    (map_mp super.typ_mp sup.typ_mp) true
+      (map_mp super.typ_mp sup.typ_mp) false
diff --git a/checker/subtyping.mli b/checker/subtyping.mli
index d9cbe5ad..ecdf5577 100644
--- a/checker/subtyping.mli
+++ b/checker/subtyping.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
 (*i*)
 open Univ
 open Term
@@ -19,6 +17,5 @@ open Environ
     known by [env] *)
 
 val check_subtypes : env -> module_type_body -> module_type_body -> unit
-val check_equal : env -> module_type_body -> module_type_body -> unit
 
 
diff --git a/checker/term.ml b/checker/term.ml
index 61369586..ab40b6fa 100644
--- a/checker/term.ml
+++ b/checker/term.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml 10098 2007-08-27 11:41:08Z herbelin $ *)
-
 (* This module instantiates the structure of generic deBruijn terms to Coq *)
 
 open Util
@@ -31,15 +29,15 @@ type case_printing =
   { ind_nargs : int; (* length of the arity of the inductive type *)
     style     : case_style }
 type case_info =
-  { ci_ind        : inductive;
-    ci_npar       : int;
-    ci_cstr_nargs : int array; (* number of real args of each constructor *)
-    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  { ci_ind         : inductive;
+    ci_npar        : int;
+    ci_cstr_ndecls : int array; (* number of pattern var of each constructor *)
+    ci_pp_info     : case_printing (* not interpreted by the kernel *)
   }
 let val_ci =
   let val_cstyle = val_enum "case_style" 5 in
-  let val_cprint = val_tuple "case_printing" [|val_int;val_cstyle|] in
-  val_tuple "case_info" [|val_ind;val_int;val_array val_int;val_cprint|]
+  let val_cprint = val_tuple ~name:"case_printing" [|val_int;val_cstyle|] in
+  val_tuple ~name:"case_info" [|val_ind;val_int;val_array val_int;val_cprint|]
 
 (* Sorts. *)
 
@@ -73,13 +71,14 @@ type 'constr pfixpoint =
 type 'constr pcofixpoint =
     int * 'constr prec_declaration
 
-let val_evar f = val_tuple "pexistential" [|val_int;val_array f|]
+let val_evar f = val_tuple ~name:"pexistential" [|val_int;val_array f|]
 let val_prec f =
-  val_tuple "prec_declaration"[|val_array val_name; val_array f; val_array f|]
+  val_tuple ~name:"prec_declaration"
+    [|val_array val_name; val_array f; val_array f|]
 let val_fix f =
-  val_tuple"pfixpoint"
-    [|val_tuple"fix2"[|val_array val_int;val_int|];val_prec f|]
-let val_cofix f = val_tuple"pcofixpoint"[|val_int;val_prec f|]
+  val_tuple ~name:"pfixpoint"
+    [|val_tuple~name:"fix2"[|val_array val_int;val_int|];val_prec f|]
+let val_cofix f = val_tuple ~name:"pcofixpoint"[|val_int;val_prec f|]
 
 type cast_kind = VMcast | DEFAULTcast
 let val_cast = val_enum "cast_kind" 2
@@ -262,7 +261,7 @@ let rec exliftn el c = match c with
 (* Lifting the binding depth across k bindings *)
 
 let liftn k n =
-  match el_liftn (pred n) (el_shft k ELID) with
+  match el_liftn (pred n) (el_shft k el_id) with
     | ELID -> (fun c -> c)
     | el -> exliftn el
 
@@ -313,22 +312,15 @@ let subst1 lam = substl [lam]
 (***************************************************************************)
 
 let val_ndecl =
-  val_tuple"named_declaration"[|val_id;val_opt val_constr;val_constr|]
+  val_tuple ~name:"named_declaration"[|val_id;val_opt val_constr;val_constr|]
 let val_rdecl =
-  val_tuple"rel_declaration"[|val_name;val_opt val_constr;val_constr|]
+  val_tuple ~name:"rel_declaration"[|val_name;val_opt val_constr;val_constr|]
 let val_nctxt = val_list val_ndecl
 let val_rctxt = val_list val_rdecl
 
 type named_declaration = identifier * constr option * constr
 type rel_declaration = name * constr option * constr
 
-let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty)
-let map_rel_declaration = map_named_declaration
-
-let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
-let fold_rel_declaration = fold_named_declaration
-
-
 type named_context = named_declaration list
 let empty_named_context = []
 let fold_named_context f l ~init = List.fold_right f l init
@@ -439,7 +431,6 @@ let decompose_prod_n_assum n =
 (***************************)
 
 type arity = rel_context * sorts
-let val_arity = val_tuple"arity"[|val_rctxt;val_constr|]
 
 let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign
 
diff --git a/checker/term.mli b/checker/term.mli
index 1367e581..0340c79b 100644
--- a/checker/term.mli
+++ b/checker/term.mli
@@ -12,7 +12,7 @@ type case_printing = { ind_nargs : int; style : case_style; }
 type case_info = {
   ci_ind : inductive;
   ci_npar : int;
-  ci_cstr_nargs : int array;
+  ci_cstr_ndecls : int array;
   ci_pp_info : case_printing;
 }
 type contents = Pos | Null
@@ -73,14 +73,6 @@ val subst1 : constr -> constr -> constr
 
 type named_declaration = identifier * constr option * constr
 type rel_declaration = name * constr option * constr
-val map_named_declaration :
-  (constr -> constr) -> named_declaration -> named_declaration
-val map_rel_declaration :
-  (constr -> constr) -> rel_declaration -> rel_declaration
-val fold_named_declaration :
-  (constr -> 'a -> 'a) -> named_declaration -> 'a -> 'a
-val fold_rel_declaration :
-  (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
 type named_context = named_declaration list
 val empty_named_context : named_context
 val fold_named_context :
@@ -111,8 +103,8 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 val eq_constr : constr -> constr -> bool
 
 (* Validation *)
-val val_sortfam : Obj.t -> unit
-val val_sort : Obj.t -> unit
-val val_constr : Obj.t -> unit
-val val_rctxt : Obj.t -> unit
-val val_nctxt : Obj.t -> unit
+val val_sortfam : Validate.func
+val val_sort : Validate.func
+val val_constr : Validate.func
+val val_rctxt : Validate.func
+val val_nctxt : Validate.func
diff --git a/checker/type_errors.ml b/checker/type_errors.ml
index bd3bb90d..12609832 100644
--- a/checker/type_errors.ml
+++ b/checker/type_errors.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml 8845 2006-05-23 07:41:58Z herbelin $ *)
-
 open Names
 open Term
 open Environ
@@ -22,7 +20,7 @@ type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
   | CodomainNotInductiveType of constr
@@ -94,9 +92,6 @@ let error_ill_formed_branch env c i actty expty =
   raise (TypeError (env,
     IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
 
-let error_generalization env nvar c =
-  raise (TypeError (env, Generalization (nvar,c)))
-
 let error_actual_type env j expty =
   raise (TypeError (env, ActualType (j,expty)))
 
diff --git a/checker/type_errors.mli b/checker/type_errors.mli
index 82cb3c55..17a210ef 100644
--- a/checker/type_errors.mli
+++ b/checker/type_errors.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli 8845 2006-05-23 07:41:58Z herbelin $ i*)
-
 (*i*)
 open Names
 open Term
@@ -24,7 +22,7 @@ type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
   | CodomainNotInductiveType of constr
@@ -86,8 +84,6 @@ val error_number_branches : env -> unsafe_judgment -> int -> 'a
 
 val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
 
-val error_generalization : env -> name * constr -> unsafe_judgment -> 'a
-
 val error_actual_type : env -> unsafe_judgment -> constr -> 'a
 
 val error_cant_apply_not_functional :
diff --git a/checker/typeops.ml b/checker/typeops.ml
index dffc9fe1..5226db53 100644
--- a/checker/typeops.ml
+++ b/checker/typeops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -91,37 +89,6 @@ let check_args env c hyps =
   with UserError _ | Not_found ->
     error_reference_variables env c
 
-
-(* Checks if the given context of variables [hyps] is included in the
-   current context of [env]. *)
-(*
-let check_hyps id env hyps =
-  let hyps' = named_context env in
-  if not (hyps_inclusion env hyps hyps') then
-    error_reference_variables env id
-*)
-(* Instantiation of terms on real arguments. *)
-
-(* Make a type polymorphic if an arity *)
-
-let extract_level env p =
-  let _,c = dest_prod_assum env p in
-  match c with Sort (Type u) -> Some u | _ -> None
-
-let extract_context_levels env =
-  List.fold_left
-    (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
-
-let make_polymorphic_if_arity env t =
-  let params, ccl = dest_prod_assum env t in
-  match ccl with
-  | Sort (Type u) ->
-      let param_ccls = extract_context_levels env params in
-      let s = { poly_param_levels = param_ccls; poly_level = u} in
-      PolymorphicArity (params,s)
-  | _ ->
-      NonPolymorphicType t
-
 (* Type of constants *)
 
 let type_of_constant_knowing_parameters env t paramtyps =
@@ -135,9 +102,6 @@ let type_of_constant_knowing_parameters env t paramtyps =
 let type_of_constant_type env t =
   type_of_constant_knowing_parameters env t [||]
 
-let type_of_constant env cst =
-  type_of_constant_type env (constant_type env cst)
-
 let judge_of_constant_knowing_parameters env cst paramstyp =
   let c = Const cst in
   let cb =
@@ -291,7 +255,7 @@ let refresh_arity env ar =
   match hd with
       Sort (Type u) when not (is_univ_variable u) ->
         let u' = fresh_local_univ() in
-        let env' = add_constraints (enforce_geq u' u Constraint.empty) env in
+        let env' = add_constraints (enforce_geq u' u empty_constraint) env in
         env', mkArity (ctxt,Type u')
     | _ -> env, ar
 
@@ -406,12 +370,9 @@ and execute_recdef env (names,lar,vdef) i =
 
 and execute_array env = Array.map (execute env)
 
-and execute_list env = List.map (execute env)
-
 (* Derived functions *)
 let infer env constr = execute env constr
 let infer_type env constr = execute_type env constr
-let infer_v env cv = execute_array env cv
 
 (* Typing of several terms. *)
 
diff --git a/checker/typeops.mli b/checker/typeops.mli
index f4f29fe5..eafe4735 100644
--- a/checker/typeops.mli
+++ b/checker/typeops.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli 9427 2006-12-11 18:46:35Z bgregoir $ i*)
-
 (*i*)
 open Names
 open Term
diff --git a/checker/validate.ml b/checker/validate.ml
index 7d368f05..c5e0bd34 100644
--- a/checker/validate.ml
+++ b/checker/validate.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
-
 (* This module defines validation functions to ensure an imported
    value (using input_value) has the correct structure. *)
 
@@ -38,44 +36,59 @@ let pr_obj o = pr_obj_rec o; Format.print_newline()
 (**************************************************************************)
 (* Obj low-level validators *)
 
-exception ValidObjError of string * Obj.t
-let fail o s = raise (ValidObjError(s,o))
+type error_context = string list
+let mt_ec : error_context = []
+let (/) (ctx:error_context) s : error_context = s::ctx
+let overr (ctx:error_context) f = (fun (_:error_context) -> f ctx) 
+let ext s f (ctx:error_context) = f (ctx/s)
+
 
-let ep s1 f s2 = f (s1^"/"^s2) 
+exception ValidObjError of string * error_context * Obj.t
+let fail ctx o s = raise (ValidObjError(s,ctx,o))
+
+type func = error_context -> Obj.t -> unit
 
 let apply debug f x =
   let o = Obj.repr x in
-  try f o
-  with ValidObjError(msg,obj) ->
+  try f mt_ec o
+  with ValidObjError(msg,ctx,obj) ->
     if debug then begin
       print_endline ("Validation failed: "^msg);
+      print_endline ("Context: "^String.concat"/"(List.rev ctx));
       pr_obj obj
     end;
     failwith "vo structure validation failed"
 
 (* data not validated *)
-let no_val (o:Obj.t) = ()
+let no_val (c:error_context) (o:Obj.t) = ()
 
 (* Check that object o is a block with tag t *)
-let val_tag t o =
+let val_tag t ctx o =
   if Obj.is_block o && Obj.tag o = t then ()
-  else fail o ("expected tag "^string_of_int t)
+  else fail ctx o ("expected tag "^string_of_int t)
 
-let val_block s o =
+let val_block ctx o =
   if Obj.is_block o then
     (if Obj.tag o > Obj.no_scan_tag then
-      fail o (s^": found no scan tag"))
-  else fail o (s^": expected block obj")
+      fail ctx o "block: found no scan tag")
+  else fail ctx o "expected block obj"
 
 (* Check that an object is a tuple (or a record). v is an array of
    validation functions for each field. Its size corresponds to the
    expected size of the object. *)
-let val_tuple s v o =
+let val_tuple ?name v ctx o =
+  let ctx = match name with
+      Some n -> ctx/n
+    | _ -> ctx in
   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
+  let val_fld i f =
+    f (ctx/("fld="^string_of_int i)) (Obj.field o i) in
+  val_block ctx o;
+  if Obj.size o = n then Array.iteri val_fld v
   else
-    fail o ("tuple:" ^s^" size found:"^string_of_int (Obj.size o))
+    fail ctx o
+      ("tuple size: found "^string_of_int (Obj.size o)^
+	 ", expected "^string_of_int n)
 
 (* Check that the object is either a constant constructor of tag < cc,
    or a constructed variant. each element of vv is an array of
@@ -83,70 +96,79 @@ let val_tuple s v o =
    The size of vv corresponds to the number of non-constant
    constructors, and the size of vv.(i) is the expected arity of the
    i-th non-constant constructor. *)
-let val_sum s cc vv o =
+let val_sum name cc vv ctx o =
+  let ctx = ctx/name in
   if Obj.is_block o then
-    (val_block s o;
+    (val_block (ctx/name) 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^": found "^string_of_int i))
+    let ctx' = if n=1 then ctx else ctx/("tag="^string_of_int i) in
+    if i < n then val_tuple vv.(i) ctx' o
+    else fail ctx' o ("sum: unexpected tag"))
   else if Obj.is_int o then
     let (n:int) = Obj.magic o in
     (if n<0 || n>=cc then
-      fail o (s^": bad constant constructor "^string_of_int n))
-  else fail o ("not a sum ("^s^")")
+      fail ctx o ("bad constant constructor "^string_of_int n))
+  else fail ctx o "not a sum"
 
 let val_enum s n = val_sum s n [||]
 
 (* Recursive types: avoid looping by eta-expansion *)
-let rec val_rec_sum s cc f o =
-  val_sum s cc (f (val_rec_sum s cc f)) o
-
-let rec val_rectype f o =
-  f (val_rectype f) o
+let rec val_rec_sum name cc f ctx o =
+  val_sum name cc (f (overr (ctx/name) (val_rec_sum name cc f))) ctx o
 
 (**************************************************************************)
 (* Builtin types *)
 
 (* Check the o is an array of values satisfying f. *)
-let val_array ?(name="array") f o =
-  val_block name o;
+let val_array ?(pos=false) f ctx o =
+  let upd_ctx =
+    if pos then (fun i -> ctx/string_of_int i) else (fun _ -> ctx) in
+  val_block (ctx/"array") o;
   for i = 0 to Obj.size o - 1 do
-    (f (Obj.field o i):unit)
+    (f (upd_ctx i) (Obj.field o i):unit)
   done
 
 (* Integer validator *)
-let val_int o =
-  if not (Obj.is_int o) then fail o "expected an int"
+let val_int ctx o =
+  if not (Obj.is_int o) then fail ctx o "expected an int"
 
 (* String validator *)
-let val_str o =
-  try val_tag Obj.string_tag o
-  with Failure _ -> fail o "expected a string"
+let val_str ctx o =
+  try val_tag Obj.string_tag ctx o
+  with Failure _ -> fail ctx o "expected a string"
 
 (* Booleans *)
 let val_bool = val_enum "bool" 2
 
 (* Option type *)
-let val_opt ?(name="option") f = val_sum name 1 [|[|f|]|]
+let val_opt ?(name="option") f =
+  val_sum name 1 [|[|f|]|]
 
 (* Lists *)
-let val_list ?(name="list") f =
-  val_rec_sum name 1 (fun vlist -> [|[|f;vlist|]|])
+let val_list ?(name="list") f ctx =
+  val_rec_sum name 1 (fun vlist -> [|[|ext "elem" f;vlist|]|])
+    ctx
 
 (* Reference *)
-let val_ref ?(name="ref") f = val_tuple name [|f|]
+let val_ref ?(name="ref") f ctx =
+  val_tuple [|f|] (ctx/name)
 
 (**************************************************************************)
 (* Standard library types *)
 
 (* Sets *)
 let val_set ?(name="Set.t") f =
-  val_rec_sum name 1 (fun vset -> [|[|vset;f;vset;val_int|]|])
+  val_rec_sum name 1
+    (fun vset -> [|[|vset;ext "elem" f;
+		     vset;ext "bal" val_int|]|])
 
 (* Maps *)
 let rec val_map ?(name="Map.t") fk fv =
-  val_rec_sum name 1 (fun vmap -> [|[|vmap;fk;fv;vmap;val_int|]|])
+  val_rec_sum name 1
+    (fun vmap ->
+       [|[|vmap; ext "key" fk; ext "value" fv;
+	   vmap; ext "bal" val_int|]|])
 
 (**************************************************************************)
 (* Coq types *)
@@ -158,19 +180,19 @@ let val_dp = val_list ~name:"dirpath" val_id
 
 let val_name = val_sum "name" 1 [|[|val_id|]|]
 
-let val_uid = val_tuple "uniq_ident" [|val_int;val_str;val_dp|]
+let val_uid = val_tuple ~name:"uniq_ident" [|val_int;val_str;val_dp|]
 
 let val_mp =
   val_rec_sum "module_path" 0
     (fun vmp -> [|[|val_dp|];[|val_uid|];[|vmp;val_id|]|])
 
-let val_kn = val_tuple "kernel_name" [|val_mp;val_dp;val_id|]
+let val_kn = val_tuple ~name:"kernel_name" [|val_mp;val_dp;val_id|]
 
 let val_con =
-  val_tuple "constant/mutind" [|val_kn;val_kn|]
+  val_tuple ~name:"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|]
+let val_ind = val_tuple ~name:"inductive"[|val_con;val_int|]
+let val_cstr = val_tuple ~name:"constructor"[|val_ind;val_int|]
 
 (* univ *)
 let val_level = val_sum "level" 1 [|[|val_dp;val_int|]|]
@@ -179,5 +201,5 @@ let val_univ = val_sum "univ" 0
 
 let val_cstrs =
   val_set ~name:"Univ.constraints"
-   (val_tuple "univ_constraint"
+   (val_tuple ~name:"univ_constraint"
      [|val_level;val_enum "order_request" 3;val_level|])
diff --git a/config/Makefile.template b/config/Makefile.template
index 8864f52d..91b12cb4 100644
--- a/config/Makefile.template
+++ b/config/Makefile.template
@@ -34,6 +34,8 @@ BUILDLDPATH=
 # EMACSDIR=path where to put Coq's Emacs mode (coq.el)
 BINDIR="BINDIRDIRECTORY"
 COQLIBINSTALL="COQLIBDIRECTORY"
+CONFIGDIR="CONFIGDIRDIRECTORY"
+DATADIR="DATADIRDIRECTORY"
 MANDIR="MANDIRDIRECTORY"
 DOCDIR="DOCDIRDIRECTORY"
 EMACSLIB="EMACSLIBDIRECTORY"
@@ -56,6 +58,7 @@ CAMLLIB="CAMLLIBDIRECTORY"
 CAMLHLIB="CAMLLIBDIRECTORY"
 
 # Camlp4 library directory (avoid CAMLP4LIB used on Windows)
+CAMLP4=CAMLP4VARIANT
 CAMLP4O=CAMLP4TOOL
 CAMLP4COMPAT=CAMLP4COMPATFLAGS
 MYCAMLP4LIB="CAMLP4LIBDIRECTORY"
@@ -137,15 +140,13 @@ STRIP=STRIPCOMMAND
 
 # CoqIde (no/byte/opt)
 HASCOQIDE=COQIDEOPT
+IDEOPTFLAGS=IDEARCHFLAGS
+IDEOPTDEPS=IDEARCHFILE
+IDEOPTINT=IDEARCHDEF
 
 # Defining REVISION
 CHECKEDOUT=CHECKEDOUTSOURCETREE
 
-# Defining options to generate dependencies graphs
-DOT=dot
-DOTOPTS=-Tps
-ODOCDOTOPTS=-dot -dot-reduce
-
 # Option to control compilation and installation of the documentation
 WITHDOC=WITHDOCOPT
 
diff --git a/config/coq_config.mli b/config/coq_config.mli
index 6845df7d..35446072 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -1,17 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_config.mli 14641 2011-11-06 11:59:10Z herbelin $ 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 coqlib : string option (* where the std library is installed *)
+val configdir : string option (* where configuration files are installed *)
+val datadir : string option (* where extra data files are installed *)
+val docdir : string     (* where the doc is installed *)
 
 val ocaml : string      (* names of ocaml binaries *)
 val ocamlc : string
@@ -60,6 +60,7 @@ val browser : string
     variable COQREMOTEBROWSER *)
 
 val has_coqide : string
+val gtk_platform : [`QUARTZ | `WIN32 | `X11]
 
 val has_natdynlink : bool
 val natdynlinkflag : string (* special cases of natdynlink (e.g. MacOS 10.5) *)
diff --git a/configure b/configure
index 8498bd70..867ee935 100755
--- a/configure
+++ b/configure
@@ -6,10 +6,10 @@
 # 
 ##################################
 
-VERSION=8.3pl3
-VOMAGIC=08300
-STATEMAGIC=58300
-DATE=`LANG=C date +"%B %Y"`
+VERSION=8.4beta
+VOMAGIC=08400
+STATEMAGIC=58400
+DATE="December 2011"
 
 # Create the bin/ directory if non-existent
 test -d bin || mkdir bin
@@ -45,9 +45,11 @@ usage () {
     printf "\tSpecifies the source directory\n"
     echo "-bindir"
     echo "-libdir"
+    echo "-configdir"
+    echo "-datadir"
     echo "-mandir"
     echo "-docdir"
-    printf "\tSpecifies where to install bin/lib/man/doc files resp.\n"
+    printf "\tSpecifies where to install bin/lib/config/data/man/doc files resp.\n"
     echo "-emacslib"
     echo "-emacs"
     printf "\tSpecifies where emacs files are to be installed\n"
@@ -57,6 +59,10 @@ usage () {
     printf "\tSpecifies the path to the OCaml library\n"
     echo "-lablgtkdir"
     printf "\tSpecifies the path to the Lablgtk library\n"
+    echo "-usecamlp5"
+    printf "\tSpecifies to use camlp5 instead of camlp4\n"
+    echo "-usecamlp4"
+    printf "\tSpecifies to use camlp4 instead of camlp5\n"
     echo "-camlp5dir"
     printf "\tSpecifies where to look for the Camlp5 library and tells to use it\n"
     echo "-arch"
@@ -67,6 +73,8 @@ usage () {
     printf "\tSpecifies whether or not to use dynamic loading of native code\n"
     echo "-coqide (opt|byte|no)"
     printf "\tSpecifies whether or not to compile Coqide\n"
+    echo "-nomacintegration"
+    printf "\tSpecifies to not try to build coqide mac integration\n"
     echo "-browser <command>"
     printf "\tUse <command> to open URL %%s\n"
     echo "-with-doc (yes|no)"
@@ -85,6 +93,8 @@ usage () {
     printf "\tAdd profiling information in the Coq executables\n"
     echo "-annotate"
     printf "\tCompiles Coq with -dtypes option\n"
+    echo "-makecmd <command>"
+    printf "\tName of GNU Make command.\n"
 }
 
 
@@ -121,6 +131,8 @@ src_spec=no
 prefix_spec=no
 bindir_spec=no
 libdir_spec=no
+configdir_spec=no
+datadir_spec=no
 mandir_spec=no
 docdir_spec=no
 emacslib_spec=no
@@ -130,6 +142,7 @@ lablgtkdir_spec=no
 coqdocdir_spec=no
 arch_spec=no
 coqide_spec=no
+nomacintegration_spec=no
 browser_spec=no
 wwwcoq_spec=no
 with_geoproof=false
@@ -137,6 +150,7 @@ with_doc=all
 with_doc_spec=no
 force_caml_version=no
 force_caml_version_spec=no
+usecamlp5=yes
 
 COQSRC=`pwd`
 
@@ -168,6 +182,12 @@ while : ; do
     -libdir|--libdir) libdir_spec=yes
                       libdir="$2"
 		      shift;;
+    -configdir|--configdir) configdir_spec=yes
+                      configdir="$2"
+		      shift;;
+    -datadir|--datadir) datadir_spec=yes
+                      datadir="$2"
+		      shift;;
     -mandir|--mandir) mandir_spec=yes
                       mandir="$2"
 		      shift;;
@@ -189,7 +209,12 @@ while : ; do
     -lablgtkdir|--lablgtkdir) lablgtkdir_spec=yes
 	                lablgtkdir="$2"
 			shift;;
+    -usecamlp5|--usecamlp5)
+	                usecamlp5=yes;;
+    -usecamlp4|--usecamlp4)
+	                usecamlp5=no;;
     -camlp5dir|--camlp5dir)
+                        usecamlp5=yes
 	                camlp5dir="$2"
 			shift;;
     -arch|--arch) arch_spec=yes
@@ -209,6 +234,8 @@ while : ; do
 			  *) COQIDE=no
 		      esac
 		      shift;;
+    -nomacintegration) nomacintegration_spec=yes
+		      shift;;
     -browser|--browser) browser_spec=yes
 		      BROWSER=$2
 		      shift;;
@@ -239,6 +266,8 @@ while : ; do
 	  ranlib_spec=yes
 	  ranlib_exec=$2
 	  shift;;
+    -makecmd|--makecmd) makecmd="$2"
+		      shift;;
     -byte-only|-byteonly|--byteonly|--byte-only) best_compiler=byte;;
     -debug|--debug) coq_debug_flag=-g;;
     -profile|--profile) coq_profile_flag=-p;;
@@ -273,18 +302,19 @@ case $arch_spec in
     # First we test if we are running a Cygwin system
     if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then
 	ARCH="win32"
+	CYGWIN=yes
     else
 	# If not, we determine the architecture
-	if test -x /bin/arch ; then
+	if test -x /bin/uname ; then
+ 	    ARCH=`/bin/uname -s`
+ 	elif test -x /usr/bin/uname ; then
+ 	    ARCH=`/usr/bin/uname -s`
+ 	elif test -x /bin/arch ; then
  	    ARCH=`/bin/arch`
  	elif test -x /usr/bin/arch ; then
  	    ARCH=`/usr/bin/arch`
  	elif test -x /usr/ucb/arch ; then
  	    ARCH=`/usr/ucb/arch`
- 	elif test -x /bin/uname ; then
- 	    ARCH=`/bin/uname -s`
- 	elif test -x /usr/bin/uname ; then
- 	    ARCH=`/usr/bin/uname -s`
 	else
 	    echo "I can not automatically find the name of your architecture."
 	    printf "%s"\
@@ -319,7 +349,7 @@ fi
 
 # make command
 
-MAKE=`which make`
+MAKE=`which ${makecmd:-make}`
 if [ "$MAKE" != "" ]; then
   MAKEVERSION=`$MAKE -v | head -1 | cut -d" " -f3`
   MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1`
@@ -328,6 +358,8 @@ if [ "$MAKE" != "" ]; then
       echo "You have GNU Make $MAKEVERSION. Good!"
   else
       OK="no"
+      #Extra support for local installation of make 3.81
+      #will be useless when make >= 3.81 will be standard
       if [ -x ./make ]; then
 	  MAKEVERSION=`./make -v | head -1`
 	  if [ "$MAKEVERSION" = "GNU Make 3.81" ]; then OK="yes"; fi
@@ -357,6 +389,7 @@ fi
 if [ "$browser_spec" = "no" ]; then
     case $ARCH in
         win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;;
+	Darwin) BROWSER='open %s' ;;
         *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;;
     esac
 fi
@@ -412,16 +445,16 @@ esac
 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.07*|3.08*|3.09*)
+    1.*|2.*|3.0*)
 	echo "Your version of Objective-Caml is $CAMLVERSION."
 	if [ "$force_caml_version" = "yes" ]; then
 	    echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml."
 	else
-	    echo "          You need Objective-Caml 3.10.2 or later."
+	    echo "          You need Objective-Caml 3.10.0 or later."
 	    echo "          Configuration script failed!"
 	    exit 1
 	fi;;
-    ?*)
+    3.1*)
 	CAMLP4COMPAT="-loc loc" 
 	echo "You have Objective-Caml $CAMLVERSION. Good!";;
     *)
@@ -458,7 +491,7 @@ else
     HASNATDYNLINK=false
 fi
 
-case $HASNATDYNLINK,`uname -s`,`uname -r`,$CAMLVERSION in
+case $HASNATDYNLINK,$ARCH,`uname -r`,$CAMLVERSION in
     true,Darwin,9.*,3.11.*)  # ocaml 3.11.0 dynlink on MacOS 10.5 is buggy
         NATDYNLINKFLAG=os5fixme;;
     #Possibly a problem on 10.6.0/10.6.1/10.6.2
@@ -483,75 +516,76 @@ esac
 
 # Camlp4 / Camlp5 configuration
 
-if [ "$camlp5dir" != "" ]; then
+# Assume that camlp(4|5) binaries are at the same place as ocaml ones
+# (this should become configurable some day)
+CAMLP4BIN=${CAMLBIN}
+
+if [ "$usecamlp5" = "yes" ]; then
     CAMLP4=camlp5
-    CAMLP4LIB=$camlp5dir
-    if [ ! -f $camlp5dir/camlp5.cma ]; then
-	echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)."
+    CAMLP4MOD=gramlib
+    if [ "$camlp5dir" != "" ]; then
+	if [ -f "$camlp5dir/${CAMLP4MOD}.cma" ]; then
+	    CAMLP4LIB=$camlp5dir
+	    FULLCAMLP4LIB=$camlp5dir
+	else
+	    echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)."
+	    echo "Configuration script failed!"
+	    exit 1
+	fi
+    elif [ -f "${CAMLLIB}/camlp5/${CAMLP4MOD}.cma" ]; then
+        CAMLP4LIB=+camlp5
+	FULLCAMLP4LIB=${CAMLLIB}/camlp5
+    elif [ -f "${CAMLLIB}/site-lib/${CAMLP4MOD}.cma" ]; then
+        CAMLP4LIB=+site-lib/camlp5
+	FULLCAMLP4LIB=${CAMLLIB}/site-lib/camlp5
+    else
+	echo "Objective Caml $CAMLVERSION found but no Camlp5 installed."
 	echo "Configuration script failed!"
 	exit 1
     fi
+
     camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'`
-else
-    case $CAMLTAG in
-        OCAML31*)
-            if [ -x "${CAMLLIB}/camlp5" ]; then
-                CAMLP4LIB=+camlp5
-            elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then
-                CAMLP4LIB=+site-lib/camlp5
-            else
-	        echo "Objective Caml $CAMLVERSION found but no Camlp5 installed."
-	        echo "Configuration script failed!"
-	        exit 1
-            fi
-            CAMLP4=camlp5
-            camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'`
-            ;;
-        *)
-            CAMLP4=camlp4
-            CAMLP4LIB=+camlp4
-            ;;
+    case `$camlp4oexec -v 2>&1` in
+	*4.0*|*5.00*)
+	    echo "Camlp5 version < 5.01 not supported."
+	    echo "Configuration script failed!"
+	    exit 1;;
     esac
-fi
 
-if [ "$CAMLP4" = "camlp5" ] && `$camlp4oexec -v 2>&1 | grep -q 5.00`; then
-    echo "Camlp5 version 5.00 not supported: versions 4.0x or >= 5.01 are OK"
-    echo "(depending also on your ocaml version)."
-    echo "Configuration script failed!"
-    exit 1
-fi
+else # let's use camlp4
+    CAMLP4=camlp4
+    CAMLP4MOD=camlp4lib
+    CAMLP4LIB=+camlp4
+    FULLCAMLP4LIB=${CAMLLIB}/camlp4
 
+    if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cma" ]; then
+	echo "Objective Caml $CAMLVERSION found but no Camlp4 installed."
+	echo "Configuration script failed!"
+	exit 1
+    fi
 
-case $CAMLP4LIB in
-    +*) FULLCAMLP4LIB=$CAMLLIB/`echo $CAMLP4LIB | cut -b 2-`;;
-    *)  FULLCAMLP4LIB=$CAMLP4LIB;;
-esac
-
-# Assume that camlp(4|5) binaries are at the same place as ocaml ones
-# (this should become configurable some day) 
-CAMLP4BIN=${CAMLBIN}
+    camlp4oexec=${camlp4oexec}rf
+    if [ "`$camlp4oexec 2>&1`" != "" ]; then
+	echo "Error: $camlp4oexec not found or not executable."
+	echo "Configuration script failed!"
+	exit 1
+    fi
+fi
 
 # do we have a native compiler: test of ocamlopt and its version
 
 if [ "$best_compiler" = "opt" ] ; then
   if test -e "$nativecamlc" || test -e "`which $nativecamlc`"; then
       CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
-      if [ "`uname -s`" = "Darwin" -a "$ARCH" = "i386" ]; then
-	  case $CAMLOPTVERSION in
-	      3.09.3|3.1?*) ;;
-	      *) echo "Native compilation on MacOS X Pentium requires Objective-Caml >= 3.09.3,"
-		 best_compiler=byte
-		 echo "only the bytecode version of Coq will be available."
-	  esac
-      elif [ ! -f $FULLCAMLP4LIB/gramlib.cmxa ]; then
+      if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cmxa" ]; then
 	  best_compiler=byte
 	  echo "Cannot find native-code $CAMLP4,"
 	  echo "only the bytecode version of Coq will be available."
       else
-        if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then
-	  echo "Native and bytecode compilers do not have the same version!"
-        fi
-        echo "You have native-code compilation. Good!"
+          if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then
+	      echo "Native and bytecode compilers do not have the same version!"
+          fi
+          echo "You have native-code compilation. Good!"
       fi
   else
       best_compiler=byte
@@ -569,7 +603,6 @@ case $ARCH in
 	   *) OS="Sun OS $OS"
 	      OSDEPLIBS="-cclib -lunix"
         esac;;
-  alpha) OSDEPLIBS="-cclib -lunix";;
   win32) OS="Win32" 
 	 OSDEPLIBS="-cclib -lunix"
 	 cflags="-mno-cygwin $cflags";;
@@ -578,6 +611,10 @@ esac
 
 # lablgtk2 and CoqIDE
 
+IDEARCHFLAGS=
+IDEARCHFILE=
+IDEARCHDEF=X11
+
 # -byte-only should imply -coqide byte, unless the user decides otherwise
 
 if [ "$best_compiler" = "byte" -a "$coqide_spec" = "no" ]; then 
@@ -616,9 +653,21 @@ else
     elif [ ! -f "${CAMLLIB}/threads/threads.cmxa" ]; then 
 	echo "LablGtk2 found, no native threads: bytecode CoqIde will be available."
 	COQIDE=byte
-    else 
-	echo "LablGtk2 found, native threads: native CoqIde will be available."
+    else
+        echo "LablGtk2 found, native threads: native CoqIde will be available."
 	COQIDE=opt
+        if [ "$nomacintegration_spec" = "no" ] && pkg-config --exists ige-mac-integration;
+        then
+            cflags=$cflags" `pkg-config --cflags ige-mac-integration`"
+	    IDEARCHFLAGS='-ccopt "`pkg-config --libs ige-mac-integration`"'
+	    IDEARCHFILE=ide/ide_mac_stubs.o
+	    IDEARCHDEF=QUARTZ
+	elif [ "$ARCH" = "win32" ];
+        then
+	    IDEARCHFLAGS=
+	    IDEARCHFILE=ide/ide_win32_stubs.o
+	    IDEARCHDEF=WIN32
+	fi
     fi
 fi
 
@@ -627,8 +676,8 @@ case $COQIDE in
         case $lablgtkdir_spec in
             no)  LABLGTKLIB=+lablgtk2                   # Pour le message
                  LABLGTKINCLUDES="-I $LABLGTKLIB";;     # Pour le makefile
-            yes) LABLGTKLIB="$lablgtkdir"               # Pour le message
-                 LABLGTKINCLUDES="-I \"$LABLGTKLIB\"";; # Pour le makefile
+            yes) LABLGTKLIB=$lablgtkdir               # Pour le message
+                 LABLGTKINCLUDES="-I $LABLGTKLIB";; # Pour le makefile
         esac;;
     no) LABLGTKINCLUDES="";;
 esac
@@ -639,9 +688,14 @@ case $ARCH in
     win32)
 	# true -> strip : it exists under cygwin !
 	STRIPCOMMAND="strip";; 
+    Darwin) if [ "$HASNATDYNLINK" = "true" ]
+	then
+	  STRIPCOMMAND="true"
+	else
+	  STRIPCOMMAND="strip"
+	fi;;
     *)
-    if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ] ||
-       [ "`uname -s`" = "Darwin" -a "$HASNATDYNLINK" = "true" ]
+    if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ]
     then
 	STRIPCOMMAND="true"
     else
@@ -682,18 +736,23 @@ case $ARCH in
     win32) COQTOP=`cygpath -m ${COQTOP}`
 esac
 
-case $ARCH in
+case $ARCH$CYGWIN in
   win32)
-	 bindir_def='C:\coq\bin'
-	 libdir_def='C:\coq\lib'
-	 mandir_def='C:\coq\man'
-	 docdir_def='C:\coq\doc'
-	 emacslib_def='C:\coq\emacs'
-         coqdocdir_def='C:\coq\latex';;
+	 W32PREF='C:\\coq\\'
+	 bindir_def=${W32PREF}bin
+	 libdir_def=${W32PREF}lib
+	 configdir_def=${W32PREF}config
+	 datadir_def=${W32PREF}data
+	 mandir_def=${W32PREF}man
+	 docdir_def=${W32PREF}doc
+	 emacslib_def=${W32PREF}emacs
+         coqdocdir_def=${W32PREF}latex;;
   *)
 	 bindir_def=/usr/local/bin
 	 libdir_def=/usr/local/lib/coq
-	 mandir_def=/usr/local/man
+	 configdir_def=/etc/xdg/coq
+	 datadir_def=/usr/local/share/coq
+	 mandir_def=/usr/local/share/man
 	 docdir_def=/usr/local/share/doc/coq
 	 emacslib_def=/usr/local/share/emacs/site-lisp
          coqdocdir_def=/usr/local/share/texmf/tex/latex/misc;;
@@ -716,6 +775,7 @@ esac
 case $libdir_spec/$prefix_spec/$local in
     yes/*/*) LIBDIR=$libdir;;
     */yes/*)
+        libdir_spec=yes
         case $ARCH in
           win32) LIBDIR=$prefix ;;
           *)  LIBDIR=$prefix/lib/coq ;;
@@ -723,15 +783,57 @@ case $libdir_spec/$prefix_spec/$local in
     */*/true) LIBDIR=$COQTOP ;;
     *)  printf "Where should I install the Coq library [$libdir_def]? "
         read LIBDIR
+        libdir_spec=yes
 	case $LIBDIR in
 	    "") LIBDIR=$libdir_def;;
 	    *) true;;
 	esac;;
 esac
 
+case $libdir_spec in
+    yes) LIBDIR_OPTION="Some \"$LIBDIR\"";;
+    *) LIBDIR_OPTION="None";;
+esac
+
+case $configdir_spec/$local in
+    yes/*) CONFIGDIR=$configdir;;
+    */true) CONFIGDIR=$COQTOP/ide
+        configdir_spec=yes;;
+    *)  printf "Where should I install the Coqide configuration files [$configdir_def]? "
+        read CONFIGDIR
+	case $CONFIGDIR in
+	    "") CONFIGDIR=$configdir_def;;
+	    *) configdir_spec=yes;;
+	esac;;
+esac
+
+case $configdir_spec in
+    yes) CONFIGDIR_OPTION="Some \"$CONFIGDIR\"";;
+    *) CONFIGDIR_OPTION="None";;
+esac
+
+case $datadir_spec/$prefix_spec/$local in
+    yes/*/*) DATADIR=$datadir;;
+    */yes/*) DATADIR=$prefix/share/coq;;
+    */*/true) DATADIR=$COQTOP/ide
+        datadir_spec=yes;;
+    *)  printf "Where should I install the Coqide data files [$datadir_def]? "
+        read DATADIR
+	case $DATADIR in
+	    "") DATADIR=$datadir_def;;
+	    *) datadir_spec=yes;;
+	esac;;
+esac
+
+case $datadir_spec in
+    yes) DATADIR_OPTION="Some \"$DATADIR\"";;
+    *) DATADIR_OPTION="None";;
+esac
+
+
 case $mandir_spec/$prefix_spec/$local in
     yes/*/*) MANDIR=$mandir;;
-    */yes/*) MANDIR=$prefix/man ;;
+    */yes/*) MANDIR=$prefix/share/man ;;
     */*/true) MANDIR=$COQTOP/man ;;
     *)  printf "Where should I install the Coq man pages [$mandir_def]? "
         read MANDIR
@@ -742,13 +844,13 @@ case $mandir_spec/$prefix_spec/$local in
 esac
 
 case $docdir_spec/$prefix_spec/$local in
-    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;;
+    yes/*/*) DOCDIR=$docdir;;
+    */yes/*) DOCDIR=$prefix/share/doc/coq;;
+    */*/true) DOCDIR=$COQTOP/doc;;
     *)  printf "Where should I install the Coq documentation [$docdir_def]? "
         read DOCDIR
 	case $DOCDIR in
-	    "") DOCDIR=$docdir_def; HTMLREFMANDIR=$DOCDIR/html/refman;;
+	    "") DOCDIR=$docdir_def;;
 	    *) true;;
 	esac;;
 esac
@@ -787,7 +889,7 @@ esac
 
 # Determine if we enable -custom by default (Windows and MacOS)
 CUSTOM_OS=no
-if [ "$ARCH" = "win32" ] || [ "`uname -s`" = "Darwin" ]; then
+if [ "$ARCH" = "win32" ] || [ "$ARCH" = "Darwin" ]; then
     CUSTOM_OS=yes
 fi
 
@@ -841,6 +943,9 @@ fi
 if test "$COQIDE" != "no"; then
 echo "  Lablgtk2 library in               : $LABLGTKLIB"
 fi
+if test "$IDEARCHDEF" = "QUARTZ"; then
+echo "  Mac OS integration is on"
+fi
 if test "$with_doc" = "all"; then
 echo "  Documentation                     : All"
 else
@@ -854,6 +959,8 @@ echo ""
 echo "  Paths for true installation:"
 echo "    binaries      will be copied in $BINDIR"
 echo "    library       will be copied in $LIBDIR"
+echo "    config files  will be copied in $CONFIGDIR"
+echo "    data files    will be copied in $DATADIR"
 echo "    man pages     will be copied in $MANDIR"
 echo "    documentation will be copied in $DOCDIR"
 echo "    emacs mode    will be copied in $EMACSLIB"
@@ -923,6 +1030,8 @@ case $ARCH in
 	BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
 	COQSRC=`cygpath -m $COQSRC |sed -e 's|\\\|\\\\\\\|g'`
 	LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
+	CONFIGDIR=`echo $CONFIGDIR |sed -e 's|\\\|\\\\\\\|g'`
+	DATADIR=`echo $DATADIR |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'`
@@ -957,8 +1066,10 @@ cat << END_OF_COQ_CONFIG > $mlconfig_file
 
 let local = $local
 let coqrunbyteflags = "$COQRUNBYTEFLAGS"
-let coqlib = "$LIBDIR"
-let coqsrc = "$COQSRC"
+let coqlib = $LIBDIR_OPTION
+let configdir = $CONFIGDIR_OPTION
+let datadir = $DATADIR_OPTION
+let docdir = "$DOCDIR"
 let ocaml = "$ocamlexec"
 let ocamlc = "$bytecamlc"
 let ocamlopt = "$nativecamlc"
@@ -979,6 +1090,7 @@ let cflags = "$cflags"
 let best = "$best_compiler"
 let arch = "$ARCH"
 let has_coqide = "$COQIDE"
+let gtk_platform = \`$IDEARCHDEF
 let has_natdynlink = $HASNATDYNLINK
 let natdynlinkflag = "$NATDYNLINKFLAG"
 let osdeplibs = "$OSDEPLIBS"
@@ -994,7 +1106,7 @@ let browser = "$BROWSER"
 let wwwcoq = "$WWWCOQ"
 let wwwrefman = wwwcoq ^ "distrib/" ^ version ^ "/refman/"
 let wwwstdlib = wwwcoq ^ "distrib/" ^ version ^ "/stdlib/"
-let localwwwrefman = "file://$HTMLREFMANDIR/"
+let localwwwrefman = "file:/" ^ docdir ^ "html/refman"
 
 END_OF_COQ_CONFIG
 
@@ -1030,6 +1142,8 @@ sed -e "s|LOCALINSTALLATION|$local|" \
     -e "s|COQVERSION|$VERSION|" \
     -e "s|BINDIRDIRECTORY|$BINDIR|" \
     -e "s|COQLIBDIRECTORY|$LIBDIR|" \
+    -e "s|CONFIGDIRDIRECTORY|$CONFIGDIR|" \
+    -e "s|DATADIRDIRECTORY|$DATADIR|" \
     -e "s|BUILDLDPATH=|$BUILDLDPATH|" \
     -e "s|MANDIRDIRECTORY|$MANDIR|" \
     -e "s|DOCDIRDIRECTORY|$DOCDIR|" \
@@ -1042,6 +1156,7 @@ sed -e "s|LOCALINSTALLATION|$local|" \
     -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
     -e "s|CAMLLIBDIRECTORY|$CAMLLIB|" \
     -e "s|CAMLTAG|$CAMLTAG|" \
+    -e "s|CAMLP4VARIANT|$CAMLP4|" \
     -e "s|CAMLP4BINDIRECTORY|$CAMLP4BIN|" \
     -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
     -e "s|CAMLP4TOOL|$camlp4oexec|" \
@@ -1069,6 +1184,9 @@ sed -e "s|LOCALINSTALLATION|$local|" \
     -e "s|RANLIBEXEC|$ranlib_exec|" \
     -e "s|STRIPCOMMAND|$STRIPCOMMAND|" \
     -e "s|COQIDEOPT|$COQIDE|" \
+    -e "s|IDEARCHFLAGS|$IDEARCHFLAGS|" \
+    -e "s|IDEARCHFILE|$IDEARCHFILE|" \
+    -e "s|IDEARCHDEF|$IDEARCHDEF|" \
     -e "s|CHECKEDOUTSOURCETREE|$checkedout|" \
     -e "s|WITHDOCOPT|$with_doc|" \
     -e "s|HASNATIVEDYNLINK|$NATDYNLINKFLAG|" \
@@ -1085,4 +1203,3 @@ echo
 echo "*Warning* To compile the system for a new architecture"
 echo "          don't forget to do a 'make archclean' before './configure'."
 
-# $Id: configure 14833 2011-12-19 21:57:30Z notin $
diff --git a/coq.itarget b/coq.itarget
index 7488f421..dd8b2590 100644
--- a/coq.itarget
+++ b/coq.itarget
@@ -1,3 +1,8 @@
-binaries
-plugins/plugins.otarget
+# NB: for the moment we start with bytecode compilation
+# for early error detection in .ml
+binariesbyte
+plugins/pluginsbyte.otarget
+binariesopt
+plugins/pluginsopt.otarget
 theories/theories.otarget
+plugins/pluginsvo.otarget
diff --git a/dev/Makefile.oug b/dev/Makefile.oug
new file mode 100644
index 00000000..ee69ea80
--- /dev/null
+++ b/dev/Makefile.oug
@@ -0,0 +1,74 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+
+#### Source Code Analysis via Oug ####
+#### Cf http://home.gna.org/oug ####
+
+
+# To be used from top dir : make -f dev/Makefile.oug ...
+
+include Makefile.build
+
+# Oug location: in the path by default, native version
+
+OUG:=oug.x
+
+# NB: coq should have been compiled with the same ocaml version as oug
+
+# NOTA: it seems we obtain more useless elements reported when _not_
+# providing the .mli files, and also when giving a precise start point.
+# TO BE INVESTIGATED
+
+ml_of_cma = $(patsubst %.cmo,%.ml,$(filter %.cmo,$(shell cat $(1:.cma=.mllib.d))))
+local_ml_of_cma = $(filter $(dir $(1))%,$(call ml_of_cma,$(1)))
+mli_of_ml = $(foreach ml,$(1),$(wildcard $(ml)i))
+
+# Analysis of coqtop, without plugins
+
+COREML:=config/coq_config.ml $(call ml_of_cma, $(CORECMA))
+COREMLI:=$(call mli_of_ml,$(COREML))
+
+core.oug:
+	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML)
+
+core.useless: core.oug
+	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@
+
+core_intf.oug:
+	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI)
+
+core_intf.useless: core_intf.oug
+	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@
+
+# Analysis of coqchk, considering only files in the checker/ subdir
+
+CHECKERML:=$(call local_ml_of_cma,checker/check.cma)
+CHECKERMLI:=$(call mli_of_ml,$(CHECKERML))
+
+## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS
+MYCHKINCL:=$(MLINCLUDES) -I checker
+
+checker.oug:
+	$(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI)
+
+checker.useless: checker.oug
+	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Checker.start>" --useless-elements $@
+
+# Analysis of extraction
+
+EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA))
+EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI))
+
+extraction.oug:
+	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI)
+
+extraction.useless: extraction.oug
+	$(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@
+
+# More to come ...
\ No newline at end of file
diff --git a/dev/README b/dev/README
index 0e40e820..5edf64c8 100644
--- a/dev/README
+++ b/dev/README
@@ -32,16 +32,14 @@ perf-analysis: analysis of perfs measured on the compilation of user contribs
 cic.dtd:       official dtd of the calc. of ind. constr. for im/ex-portation
 
 
-Documentation of ML interfaces using tex (directory ocamlweb-doc)
+Documentation of ML interfaces using ocamldoc (directory ocamldoc/html)
 ----------------------------------------
-
-go in directory and call "make"
+"make mli-doc" in coq root directory.
 
 
 Other development tools (directory tools)
 -----------------------
 
-univdot: produces a graph of CIC universes
 Makefile.dir: makefile dedicated to intensive work in a given directory
 Makefile.subdir: makefile dedicated to intensive work in a given subdirectory
 Makefile.devel: utilities to automatically launch coq in various states
diff --git a/dev/base_include b/dev/base_include
index 05e87da1..d1125965 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -24,7 +24,6 @@
 #install_printer  (* identifier *) ppidset;;
 #install_printer  (* Intset.t *) ppintset;;
 #install_printer  (* label *) pplab;;
-(*#install_printer  (* mod_self_id *) ppmsid;;*)
 #install_printer  (* mod_bound_id *) ppmbid;;
 #install_printer  (* dir_path *) ppdir;;
 #install_printer  (* module_path *) ppmp;;
@@ -38,7 +37,6 @@
 #install_printer  (* values *) ppvalues;;
 #install_printer  (* Idpred.t *) pp_idpred;;
 #install_printer  (* Cpred.t *) pp_cpred;;
-#install_printer  (* transparent_state *) pp_transparent_state;;
 #install_printer ppzipper;;
 #install_printer ppstack;;
 #install_printer ppatom;;
@@ -78,7 +76,8 @@ open Pretyping.Default.Cases
 open Cbv
 open Classops
 open Clenv
-open Rawterm
+open Clenvtac
+open Glob_term
 open Coercion
 open Coercion.Default
 open Recordops
@@ -110,11 +109,9 @@ open Topconstr
 open Prettyp
 open Search
 
-open Clenvtac
 open Evar_refiner
 open Logic
 open Pfedit
-open Proof_trees
 open Proof_type
 open Redexpr
 open Refiner
@@ -172,7 +169,7 @@ let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;;
 let parse_tac    = Pcoq.parse_string Pcoq.Tactic.tactic;;
 let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;;
 
-(* build a term of type rawconstr without type-checking or resolution of 
+(* build a term of type glob_constr without type-checking or resolution of 
    implicit syntax *)
 
 let e s =
@@ -190,18 +187,22 @@ open Declarations;;
 
 let constbody_of_string s =
   let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in
-  Option.get b.const_body;;
+  Option.get (body_of_constant b);;
 
 (* Get the current goal *)
-
+(*
 let getgoal x = top_goal_of_pftreestate (Pfedit.get_pftreestate x);;
 
 let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());;
 let current_goal () = get_nth_goal 1;;
-
+*)
 let pf_e gl s = 
   Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);;
 
 open Toplevel
 let go = loop
 
+let _ =
+ print_string
+   ("\n\tOcaml toplevel with Coq printers and utilities (use go();; to exit)\n\n");
+ flush_all()
diff --git a/dev/db b/dev/db
index 22b76605..63c98bb6 100644
--- a/dev/db
+++ b/dev/db
@@ -6,7 +6,6 @@ install_printer Top_printers.ppidset
 install_printer Top_printers.ppevarsubst
 install_printer Top_printers.ppintset
 install_printer Top_printers.pplab
-install_printer Top_printers.ppmbid
 install_printer Top_printers.ppdir
 install_printer Top_printers.ppmp
 install_printer Top_printers.ppkn
@@ -18,7 +17,7 @@ install_printer Top_printers.ppclindex
 install_printer Top_printers.ppbigint
 
 install_printer Top_printers.pppattern
-install_printer Top_printers.pprawconstr
+install_printer Top_printers.ppglob_constr
 
 install_printer Top_printers.ppconstr
 install_printer Top_printers.ppuni
@@ -28,16 +27,13 @@ install_printer Top_printers.pptype
 install_printer Top_printers.ppj
 install_printer Top_printers.ppenv
 
-install_printer Top_printers.ppgoal
-install_printer Top_printers.ppsigmagoal
-install_printer Top_printers.pproof
 install_printer Top_printers.ppmetas
 install_printer Top_printers.ppevm
-install_printer Top_printers.ppclenv
+install_printer Top_printers.ppgoal
 
 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
+install_printer Top_printers.ppfconstr
diff --git a/dev/db_printers.ml b/dev/db_printers.ml
index 883103c3..b3edd7d0 100644
--- a/dev/db_printers.ml
+++ b/dev/db_printers.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/dev/doc/about-hints b/dev/doc/about-hints
new file mode 100644
index 00000000..95712c3c
--- /dev/null
+++ b/dev/doc/about-hints
@@ -0,0 +1,454 @@
+An investigation of how ZArith lemmas could be classified in different
+automation classes
+
+- Reversible lemmas relating operators (to be declared as hints but
+  needing precedences)
+- Equivalent notions (one has to be considered as primitive and the
+  other rewritten into the canonical one)
+- Isomorphisms between structure (one structure has to be considered
+  as more primitive than the other for a give operator)
+- Irreversible simplifications (to be declared with precedences)
+- Reversible bottom-up simplifications (to be used in hypotheses)
+- Irreversible bottom-up simplifications (to be used in hypotheses
+  with precedences)
+- Rewriting rules (relevant for autorewrite, or for an improved auto)
+
+Note: this analysis, made in 2001, was previously stored in
+theories/ZArith/Zhints.v. It has been moved here to avoid obfuscating
+the standard library.
+
+(**********************************************************************)
+(** *        Reversible lemmas relating operators                     *)
+(** Probably to be declared as hints but need to define precedences   *)
+
+(** ** 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`
+Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
+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`
+>>
+*)
+
+(** 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)`
+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`
+Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
+Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
+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)`
+>>
+*)
+
+(** ** 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`
+>>
+*)
+
+(** Lemmas ending by Zgt *)
+(**
+<<
+Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
+not_Zle: (x,y:Z)~`x <= y`->`x > y`
+Zlt_gt: (m,n:Z)`m < n`->`n > m`
+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`
+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`
+Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
+Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p`
+Zge_le: (m,n:Z)`m >= n`->`n <= m`
+Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
+Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
+Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
+Zle_refl: (n,m:Z)`n = m`->`n <= m`
+>>
+*)
+
+(** ** Irreversible simplification involving several comparaisons *)
+(**    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`
+>>
+*)
+
+(** ** 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)`
+>>
+*)
+
+(**********************************************************************)
+(** *                Useful Bottom-up lemmas                          *)
+
+(** ** 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`
+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`
+>>
+*)
+
+(** 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`
+>>
+*)
+
+(** Lemmas ending by Zle *)
+(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
+Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
+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`
+>>
+*)
+
+(** ** Other unclearly simplifying lemmas *)
+
+(** Lemmas ending by Zeq *)
+(**
+<<
+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                                               *)
+
+(* 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`
+>>
+*)
+
+
+(**********************************************************************)
+(** *               Unclear or too specific lemmas                    *)
+(** Not to be used ?                                                  *)
+
+(** ** Irreversible and too specific (not enough regular) *)
+
+(** Lemmas ending by Zle *)
+(**
+<<
+Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
+Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
+OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
+OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
+>>
+*)
+
+(** ** Expansion and too specific ? *)
+
+(** Lemmas ending by Zge *)
+(**
+<<
+Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
+>>
+*)
+
+(** Lemmas ending by Zgt *)
+(**
+<<
+Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
+Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
+>>
+*)
+
+(** Lemmas ending by Zle *)
+(**
+<<
+Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
+Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
+>>
+*)
+
+(** ** Reversible but too specific ? *)
+
+(** Lemmas ending by Zlt *)
+(**
+<<
+Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
+>>
+*)
+
+(**********************************************************************)
+(** *               Lemmas to be used as rewrite rules                *)
+(** but can also be used as hints                                     *)
+
+(** Left-to-right simplification lemmas (a symbol disappears) *)
+
+(**
+<<
+Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
+Zmin_n_n: (n:Z)`(Zmin n n) = n`
+Zmult_1_n: (n:Z)`1*n = n`
+Zmult_n_1: (n:Z)`n*1 = n`
+Zminus_plus: (n,m:Z)`n+m-n = m`
+Zle_plus_minus: (n,m:Z)`n+(m-n) = m`
+Zopp_Zopp: (x:Z)`(-(-x)) = x`
+Zero_left: (x:Z)`0+x = x`
+Zero_right: (x:Z)`x+0 = x`
+Zplus_inverse_r: (x:Z)`x+(-x) = 0`
+Zplus_inverse_l: (x:Z)`(-x)+x = 0`
+Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y`
+Zmult_one: (x:Z)`1*x = x`
+Zero_mult_left: (x:Z)`0*x = 0`
+Zero_mult_right: (x:Z)`x*0 = 0`
+Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
+>>
+*)
+
+(** Right-to-left simplification lemmas (a symbol disappears) *)
+
+(**
+<<
+Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
+Zs_pred: (n:Z)`n = (Zs (Zpred n))`
+Zplus_n_O: (n:Z)`n = n+0`
+Zmult_n_O: (n:Z)`0 = n*0`
+Zminus_n_O: (n:Z)`n = n-0`
+Zminus_n_n: (n:Z)`0 = n-n`
+Zred_factor6: (x:Z)`x = x+0`
+Zred_factor0: (x:Z)`x = x*1`
+>>
+*)
+
+(** Unclear orientation (no symbol disappears) *)
+
+(**
+<<
+Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
+Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
+Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
+Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p`
+Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)`
+Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)`
+Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)`
+Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)`
+Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m`
+Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p`
+Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p`
+Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)`
+Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p`
+Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)`
+Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m`
+Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z`
+Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p`
+Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)`
+Zplus_sym: (x,y:Z)`x+y = y+x`
+Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z`
+Zmult_sym: (x,y:Z)`x*y = y*x`
+Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z`
+Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))`
+Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))`
+Zopp_one: (x:Z)`(-x) = x*(-1)`
+Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)`
+Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)`
+Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y`
+Zred_factor1: (x:Z)`x+x = x*2`
+Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)`
+Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
+Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
+Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
+Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
+>>
+*)
+
+(** nat <-> Z *)
+(**
+<<
+inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
+inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
+inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
+inj_minus1:
+ (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
+inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
+>>
+*)
+
+(** Too specific ? *)
+(**
+<<
+Zred_factor5: (x,y:Z)`x*0+y = y`
+>>
+*)
diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt
index d4014303..3d9cba14 100644
--- a/dev/doc/build-system.dev.txt
+++ b/dev/doc/build-system.dev.txt
@@ -1,6 +1,22 @@
+
 Since July 2007, Coq features a build system overhauled by Pierre
 Corbineau and Lionel Elie Mamane.
 
+---------------------------------------------------------------------
+WARNING:
+In March 2010 this build system has been heavily adapted by Pierre
+Letouzey. In particular there no more explicit stage1,2. Stage3
+was removed some time ago when coqdep was splitted into coqdep_boot
+and full coqdep. Ideas are still similar to what is describe below,
+but:
+1) .ml4 are explicitely turned into .ml files, which stay after build
+2) we let "make" handle the inclusion of .d without trying to guess
+   what could be done at what time. Some initial inclusions hence
+  _fail_, but "make" tries again later and succeed.
+
+TODO: remove obsolete sections below and better describe the new approach
+-----------------------------------------------------------------------
+
 This file documents internals of the implementation of the build
 system. For what a Coq developer needs to know about the build system,
 see build-system.txt .
diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt
index 9362aeeb..b243ebe2 100644
--- a/dev/doc/build-system.txt
+++ b/dev/doc/build-system.txt
@@ -1,12 +1,60 @@
 Since July 2007, Coq features a build system overhauled by Pierre
 Corbineau and Lionel Elie Mamane.
 
+---------------------------------------------------------------------
+WARNING:
+In March 2010 this build system has been heavily adapted by Pierre
+Letouzey. In particular there no more explicit stage1,2. Stage3
+was removed some time ago when coqdep was splitted into coqdep_boot
+and full coqdep. Ideas are still similar to what is describe below,
+but:
+1) .ml4 are explicitely turned into .ml files, which stay after build
+2) we let "make" handle the inclusion of .d without trying to guess
+   what could be done at what time. Some initial inclusions hence
+  _fail_, but "make" tries again later and succeed.
+
+TODO: remove obsolete sections below and better describe the new approach
+-----------------------------------------------------------------------
+
 This file documents what a Coq developer needs to know about the build
 system. If you want to enhance the build system itself (or are curious
 about its implementation details), see build-system.dev.txt .
 
 The build system is not at its optimal state, see TODO section.
 
+
+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.htmlPrerequisite-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 ...), $(if ...)
+
+* Behavior of -include
+
+If the file given to -include doesn't exist, make tries to build it,
+but doesn't care if this build fails. This can be quite surprising,
+see in particular the -include in Makefile.stage*
+
+
 Stages in build system
 ----------------------
 
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index 069f7d42..322530e6 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -1,4 +1,43 @@
 =========================================
+= CHANGES BETWEEN COQ V8.3 AND COQ V8.4 =
+=========================================
+
+** Functions in unification.ml have now the evar_map coming just after the env
+
+** Removal of Tacinterp.constr_of_id **
+
+Use instead either global_reference or construct_reference in constrintern.ml.
+
+** Optimizing calls to Evd functions **
+
+Evars are split into defined evars and undefined evars; for
+efficiency, when an evar is known to be undefined, it is preferable to
+use specific functions about undefined evars since these ones are
+generally fewer than the defined ones.
+
+** Type changes in TACTIC EXTEND rules **
+
+Arguments bound with tactic(_) in TACTIC EXTEND rules are now of type
+glob_tactic_expr, instead of glob_tactic_expr * tactic. Only the first
+component is kept, the second one can be obtained via
+Tacinterp.eval_tactic.
+
+** ARGUMENT EXTEND **
+
+It is now forbidden to use TYPED simultaneously with {RAW,GLOB}_TYPED
+in ARGUMENT EXTEND statements.
+
+** Renaming of rawconstr to glob_constr **
+
+The "rawconstr" type has been renamed to "glob_constr" for
+consistency. The "raw" in everything related to former rawconstr has
+been changed to "glob". For more details about the rationale and
+scripts to migrate code using Coq's internals, see commits 13743,
+13744, 13755, 13756, 13757, 13758, 13761 (by glondu, end of December
+2010) in Subversion repository. Contribs have been fixed too, and
+commit messages there might also be helpful for migrating.
+
+=========================================
 = CHANGES BETWEEN COQ V8.2 AND COQ V8.3 =
 =========================================
 
diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt
index 50b3b45c..2480b8ed 100644
--- a/dev/doc/debugging.txt
+++ b/dev/doc/debugging.txt
@@ -11,6 +11,12 @@ Debugging from Coq toplevel using Caml trace mechanism
   6. Test your Coq command and observe the result of tracing your functions
   7. Freely switch from Coq to Ocaml toplevels with 'Drop.' and 'go();;'
 
+  You can avoid typing #use "include" (or "base_include") after Drop
+  by adding the following lines in your $HOME/.ocamlinit :
+
+   if Filename.basename Sys.argv.(0) = "coqtop.byte"
+   then ignore (Toploop.use_silently Format.std_formatter "include")
+
   Hints: To remove high-level pretty-printing features (coercions,
   notations, ...), use "Set Printing All". It will affect the #trace
   printers too.
diff --git a/dev/doc/perf-analysis b/dev/doc/perf-analysis
index d23bf835..ac54fa6f 100644
--- a/dev/doc/perf-analysis
+++ b/dev/doc/perf-analysis
@@ -1,13 +1,32 @@
 Performance analysis (trunk repository)
 ---------------------------------------
 
+Jun 7, 2010: delayed re-typing of Ltac instances in matching
+  (-1% on HighSchoolGeometry, -2% on JordanCurveTheorem)
+
+Jun 4, 2010: improvement in eauto and type classes inference by removing
+  systematic preparation of debugging pretty-printing streams (std_ppcmds)
+  (-7% in ATBR, visible only on V8.3 logs since ATBR is broken in trunk;
+   -6% in HighSchoolGeometry)
+
+Apr 19, 2010: small improvement obtained by reducing evar instantiation 
+  from O(n^3) to O(n^2) in the size of the instance (-2% in Compcert,
+  -2% AreaMethod, -15% in Ssreflect)
+
+Apr 17, 2010: small improvement obtained by not repeating unification
+  twice in auto (-2% in Compcert, -2% in Algebra)
+
+Feb 15, 2010: Global decrease due to unicode inefficiency repaired
+
+Jan 8, 2010: Global increase due to an inefficiency in unicode treatment
+
 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 
+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/unification.txt b/dev/doc/unification.txt
new file mode 100644
index 00000000..6d05bcf5
--- /dev/null
+++ b/dev/doc/unification.txt
@@ -0,0 +1,208 @@
+Some notes about the use of unification in Coq
+----------------------------------------------
+
+There are several applications of unification and pattern-matching
+
+** Unification of types **
+
+- For type inference, inference of implicit arguments
+  * this basically amounts to solve problems of the form T <= U or T = U
+    where T and U are types coming from a given typing problem
+  * this kind of problem has to succeed and all the power of unification is
+    a priori expected (full beta/delta/iota/zeta/nu/mu, pattern-unification,
+    pruning, imitation/projection heuristics, ...)
+
+- For lemma application (apply, auto, ...)
+  * these are also problems of the form T <= U on types but with T
+    coming from a lemma and U from the goal
+  * it is not obvious that we always want unification and not matching
+  * it is not clear which amounts of delta one wants to use
+
+** Looking for subterms **
+
+- For tactics applying on subterms: induction, destruct, rewrite
+
+- As part of unification of types in the presence of higher-order
+  evars (e.g. when applying a lemma of conclusion "?P t")
+
+
+----------------------------------------------------------------------
+Here are examples of features one may want or not when looking for subterms
+
+A- REWRITING
+
+1- Full conversion on closed terms
+
+1a- Full conversion on closed terms in the presence of at least one evars (meta)
+
+Section A1.
+Variable y: nat.
+Hypothesis H: forall x, x+2 = 0.
+Goal y+(1+1) = 0.
+rewrite H.
+(* 0 = 0 *)
+Abort.
+
+Goal 2+(1+1) = 0.
+rewrite H.
+(* 0 = 0 *)
+Abort.
+
+(* This exists since the very beginning of Chet's unification for tactics *)
+(* But this fails for setoid rewrite *)
+
+1b- Full conversion on closed terms without any evars in the lemma
+
+1b.1- Fails on rewrite (because Unification.w_unify_to_subterm_list replaces
+  unification by check for a syntactic subterm if terms has no evar/meta)
+
+Goal 0+1 = 0 -> 0+(1+0) = 0.
+intros H; rewrite H.
+(* fails *)
+Abort.
+
+1b.2- Works with setoid rewrite
+
+Require Import Setoid.
+Goal 0+1 = 0 -> 0+(1+0) = 0.
+intros H; rewrite H at 1.
+(* 0 = 0 *)
+Abort.
+
+2- Using known instances in full conversion on closed terms
+
+Section A2.
+Hypothesis H: forall x, x+(2+x) = 0.
+Goal 1+(1+2) = 0.
+rewrite H.
+Abort.
+End A2.
+
+(* This exists since 8.2 (HH) *)
+
+3- Pattern-unification on Rels
+
+Section A3a.
+Variable F: (nat->nat->nat)->nat.
+Goal exists f, F (fun x y => f x y) = 0 -> F (fun x y => plus y x) = 0.
+eexists. intro H; rewrite H.
+(* 0 = 0 *)
+Abort.
+End A3a.
+
+(* Works since pattern unification on Meta applied to Rel was introduced *)
+(* in unification.ml (8.1, Sep 2006, HH) *)
+
+Section A3b.
+Variables x y: nat.
+Variable H: forall f, f x y = 0.
+Goal plus y x = 0.
+rewrite H.
+(* 0 = 0 *)
+Abort.
+End A3b.
+
+(* Works since pattern unification on all Meta was supported *)
+(* in unification.ml (8.4, Jun 2011, HH) *)
+
+4- Unification with open terms
+
+Section A4.
+Hypothesis H: forall x, S x = 0.
+Goal S 0 = 0.
+rewrite (H _).
+(* 0 = 0 *)
+Abort.
+End A4.
+
+(* Works since unification on Evar was introduced so as to support rewriting *)
+(* with open terms (8.2, MS, r11543, Unification.w_unify_to_subterm_list ) *)
+
+5- Unification of pre-existing evars
+
+5a- Basic unification of pre-existing evars
+
+Section A4.
+Variables x y: nat.
+Goal exists z, S z = 0 -> S (plus y x) = 0.
+eexists. intro H; rewrite H.
+(* 0 = 0 *)
+Abort.
+End A4.
+
+(* This worked in 8.2 and 8.3 as a side-effect of support for rewriting *)
+(* with open terms (8.2, MS, r11543) *)
+
+5b- Pattern-unification of pre-existing evars in rewriting lemma
+
+Goal exists f, forall x y, f x y = 0 -> plus y x = 0.
+eexists. intros x y H; rewrite H.
+(* 0 = 0 *)
+Abort.
+
+(* Works since pattern-unification on Evar was introduced *)
+(* in unification.ml (8.3, HH, r12229) *)
+(* currently governed by a flag: use_evars_pattern_unification *)
+
+5c- Pattern-unification of pre-existing evars in goal
+
+Goal exists f, forall x y, plus x y = 0 -> f y x = 0.
+eexists. intros x y H; rewrite H.
+(* 0 = 0 *)
+Abort.
+
+(* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *)
+
+5d- Mixing pattern-unification of pre-existing evars in goal and evars in lemma
+
+Goal exists f, forall x, (forall y, plus x y = 0) -> forall y:nat, f y x = 0.
+eexists. intros x H y. rewrite H.
+(* 0 = 0 *)
+Abort.
+
+(* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *)
+
+6- Multiple non-identical but convertible occurrences
+
+Tactic rewrite only considers the first one, from left-to-right, e.g.:
+
+Section A6.
+Variable y: nat.
+Hypothesis H: forall x, x+2 = 0.
+Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)).
+rewrite H.
+(* 0+(y+(1+1)) = y+(1+1)+0 *)
+Abort.
+End A6.
+
+Tactic setoid rewrite first looks for syntactically equal terms and if
+not uses the leftmost occurrence modulo delta.
+
+Require Import Setoid.
+Section A6.
+Variable y: nat.
+Hypothesis H: forall x, x+2 = 0.
+Goal (y+(2+0))+(y+2) = (y+2)+(y+(2+0)).
+rewrite H at 1 2 3 4.
+(* (y+(2+0))+0 = 0+(y+(2+0)) *)
+Abort.
+
+Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)).
+rewrite H at 1 2 3 4.
+(* 0+(y+(1+1)) = y+(1+1)+0 *)
+Abort.
+End A6.
+
+7- Conversion
+
+Section A6.
+Variable y: nat.
+Hypothesis H: forall x, S x = 0.
+Goal id 1 = 0.
+rewrite H.
+
+
+B- ELIMINATION (INDUCTION / CASE ANALYSIS)
+
+This is simpler because open terms are not allowed and no unification
+is involved (8.3).
diff --git a/dev/doc/universes.txt b/dev/doc/universes.txt
index 65c1e522..a40706e9 100644
--- a/dev/doc/universes.txt
+++ b/dev/doc/universes.txt
@@ -1,32 +1,26 @@
 How to debug universes?
 
-1. There is a command Dump Universes in Coq toplevel
+1. There is a command Print Universes in Coq toplevel
 
-   Dump Universes.
+   Print Universes.
      prints the graph of universes in the form of constraints
 
-   Dump Universes "file".
+   Print Universes "file".
      produces the "file" containing universe constraints in the form
        univ1 # univ2 ;
      where # can be either > >= or =
-     
-   The file produced by the latter command can be transformed using
-   the script univdot to dot format.
-   For example
 
-   univdot file | dot -Tps > file.ps
-
-   produces a graph of universes in ps format. 
-   > arrows are red, >= blue, and = black.
+   If "file" ends with .gv or .dot, the resulting file will be in
+   dot format.
 
 
    *) for dot see http://www.research.att.com/sw/tools/graphviz/
 
 
 2. There is a printing option
-  
-   Termast.print_universes : bool ref
 
-   which, when set (in ocaml after Drop), makes all pretty-printed
-   Type's annotated with the name of the universe.
+   {Set,Unset} Printing Universes.
+
+   which, when set, makes all pretty-printed Type's annotated with the
+   name of the universe.
 
diff --git a/dev/include b/dev/include
index 251a969b..69ac3c41 100644
--- a/dev/include
+++ b/dev/include
@@ -1,6 +1,19 @@
 
 (* File to include to install the pretty-printers in the ocaml toplevel *)
 
+(* Typical usage :
+
+   $ coqtop.byte    # or even better : rlwrap coqtop.byte
+   Coq < Drop.
+   # #use "include";;
+
+   Alternatively, you can avoid typing #use "include" after each Drop
+   by adding the following lines in your $HOME/.ocamlinit :
+
+   if Filename.basename Sys.argv.(0) = "coqtop.byte"
+   then ignore (Toploop.use_silently Format.std_formatter "include")
+*)
+
 (* 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:
@@ -14,7 +27,7 @@
 #install_printer  (* pp_stdcmds *) pppp;;
 
 #install_printer  (* pattern *) pppattern;;
-#install_printer  (* rawconstr *) pprawconstr;;
+#install_printer  (* glob_constr *) ppglob_constr;;
 
 #install_printer  (* constr *) ppconstr;;
 #install_printer  (* constr_substituted *) ppsconstr;; 
@@ -24,12 +37,14 @@
 #install_printer  (* judgement *) ppj;;
 
 #install_printer  (* hint_db *)  print_hint_db;;
+(*#install_printer  (* hints_path *)  pphintspath;;*)
 #install_printer  (* goal *)  ppgoal;;
-#install_printer  (* sigma goal *)  ppsigmagoal;;
-#install_printer  (* proof *)  pproof;;
-#install_printer  (* pftreestate *)  pppftreestate;;
+(*#install_printer  (* sigma goal *)  ppsigmagoal;;*)
+(*#install_printer  (* proof *)  pproof;;*)
+#install_printer  (* Goal.goal *)  ppgoalgoal;;
 #install_printer  (* metaset.t *) ppmetas;;
 #install_printer  (* evar_map *)  ppevm;;
+#install_printer  (* ExistentialSet.t *) ppexistentialset;;
 #install_printer  (* clenv *) ppclenv;;
 #install_printer  (* env *) ppenv;;
 
diff --git a/dev/ocamldoc/docintro b/dev/ocamldoc/docintro
new file mode 100644
index 00000000..33d20fc8
--- /dev/null
+++ b/dev/ocamldoc/docintro
@@ -0,0 +1,49 @@
+{!indexlist}
+
+This is Coq, a proof assistant for the Calculus of Inductive Constructions.
+This document describes the implementation of Coq.
+It has been automatically generated from the source of
+Coq using {{:http://caml.inria.fr/}ocamldoc}.
+The source files are organized in several directories ordered like that:
+
+{ol {- Utility libraries : lib
+
+describes the various utility libraries used in the code
+of Coq.}
+{- Kernel : kernel
+
+describes the Coq kernel, which is a type checker for the Calculus
+of Inductive Constructions.}
+{- Library : library
+
+describes the Coq library, which is made of two parts:
+- a general mechanism to keep a trace of all operations and of
+    the state of the system, with backtrack capabilities;
+- a global environment for the CCI, with functions to export and 
+    import compiled modules.
+
+}
+{- Pretyping : pretyping
+
+}
+{- Front abstract syntax of terms : interp
+
+describes the translation from Coq context-dependent
+front abstract syntax of terms {v constr_expr v} to and from the
+context-free, untyped, globalized form of constructions {v glob_constr v}.}
+{- Parsers and printers : parsing
+
+describes the implementation of the Coq parsers and printers.}
+{- Proof engine : proofs
+
+describes the Coq proof engine, which is also called
+the ``refiner'', since it provides a way to build terms by successive
+refining steps. Those steps are either primitive rules or higher-level
+tactics.}
+{- Tacticts : tactics
+
+describes the Coq main tactics.}
+{- Toplevel : toplevel
+
+describes the highest modules of the Coq system.}
+}
diff --git a/dev/ocamldoc/html/style.css b/dev/ocamldoc/html/style.css
new file mode 100644
index 00000000..c2c45b62
--- /dev/null
+++ b/dev/ocamldoc/html/style.css
@@ -0,0 +1,220 @@
+a:visited {

+  color: #416DFF; text-decoration: none; 

+}

+

+a:link {

+  color: #416DFF; text-decoration: none;

+}

+

+a:hover {

+  color: Red; text-decoration: none; background-color: #5FFF88

+}

+

+a:active {

+  color: Red; text-decoration: underline; 

+}

+

+.keyword {

+  font-weight: bold; color: Red 

+}

+

+.keywordsign {

+  color: #C04600 

+}

+

+.superscript {

+  font-size: 8 

+}

+

+.subscript {

+  font-size: 8 

+}

+

+.comment {

+  color: Green 

+}

+

+.constructor {

+  color: Blue 

+}

+

+.type {

+  color: #5C6585 

+}

+

+.string {

+  color: Maroon 

+}

+

+.warning {

+  color: Red; font-weight: bold 

+}

+

+.info {

+  margin-left: 3em; margin-right: 3em 

+}

+

+.param_info {

+  margin-top: 4px; margin-left: 3em; margin-right: 3em 

+}

+

+.code {

+  color: #465F91; 

+}

+

+h1 {

+  font-size: 20pt; text-align: center; 

+}

+

+h5, h6, div.h7, div.h8, div.h9 {

+  font-size: 20pt;

+  border: 1px solid #000000;

+  margin-top: 5px;

+  margin-bottom: 2px;

+  text-align: center;

+  padding: 2px;

+}

+

+h5 {

+  background-color: #90FDFF;

+}

+

+h6 {

+  background-color: #016699;

+  color: white;

+}

+

+div.h7 {

+  background-color: #E0FFFF;

+}

+

+div.h8 {

+  background-color: #F0FFFF;

+}

+

+div.h9 {

+  background-color: #FFFFFF;

+}

+

+.typetable, .indextable, .paramstable {

+  border-style: hidden;

+}

+

+.paramstable {

+  padding: 5pt 5pt;

+}

+

+body {

+  background-color: white;

+}

+

+tr {

+  background-color: white;

+}

+

+td.typefieldcomment {

+  background-color: #FFFFFF;

+  font-size: smaller;

+}

+

+pre {

+  margin-bottom: 4px;

+}

+

+div.sig_block {

+  margin-left: 2em;

+}

+

+

+h2 {

+  font-family: Arial, Helvetica, sans-serif;

+  font-size: 16pt;

+  font-weight: normal;

+  border-bottom: 1px solid #dadada;

+  border-top: 1px solid #dadada;

+  color: #101010;

+  background: #eeeeff;

+  margin: 25px 0px 10px 0px;

+  padding: 1px 1px 1px 1px;

+}

+

+h3 {

+  font-family: Arial, Helvetica, sans-serif;

+  font-size: 12pt;

+  color: #016699;

+  font-weight: bold;

+  padding: 15px 0 0 0ex;

+  margin: 5px 0 0 0;

+}

+

+h4 {

+  font-family: Arial, Helvetica, sans-serif;

+  font-size: 10pt;

+  color: #016699;

+  padding: 15px 0 0 0ex;

+  margin: 5px 0 0 0;

+}

+

+/* Here starts the overwrite of default rules to give a better look */

+

+body {

+  font-family: Calibri, Georgia, Garamond, Baskerville, serif;

+  font-size: 12pt;

+  background-color: white;

+}

+

+a:link, a {

+  color: #6895c3 !important;

+}

+

+a:hover {

+  color: #2F4459 !important;

+  background-color: white;

+}

+

+hr {

+  height: 1px;

+  color: #016699;

+  background-color: #016699;

+  border-width: 0;

+}

+

+h1, h1 a:link, h1 a:visited, h1 a {

+  font-family: Cambria, Georgia, Garamond, Baskerville, serif;

+  color: #016699;

+}

+

+.navbar {

+  float: left;

+}

+

+.navbar a, .navbar a:link, .navbar a:visited {

+  color: #016699;

+  font-family: Arial, Helvetica, sans-serif;

+  font-weight: bold;

+  font-size: 80%;

+}

+

+.keyword {

+  color: #c13939;

+}

+

+.constructor {

+  color: #3c8f7e;

+}

+

+pre, code {

+  font-family: "DejaVu Sans Mono", "Bitstream Vera Mono", "Courrier New", monospace;

+  white-space: normal;

+  font-size: 9pt;

+  font-weight: bold;

+}

+

+.type br {

+  display: none;

+}

+

+.info {

+  margin-left: 1em;

+  font-size: 12pt;

+}

diff --git a/dev/ocamlweb-doc/Makefile b/dev/ocamlweb-doc/Makefile
deleted file mode 100644
index 3189d7c5..00000000
--- a/dev/ocamlweb-doc/Makefile
+++ /dev/null
@@ -1,90 +0,0 @@
-include ../../config/Makefile
-
-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 ../../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)
-
-
-all:: newparse coq.ps minicop.ps
-#newsyntax.dvi minicoq.dvi
-
-
-OBJS=lex.cmo ast.cmo parse.cmo syntax.cmo
-
-newparse: $(OBJS) syntax.mli lex.ml syntax.ml
-	ocamlc -o newparse $(OBJS)
-
-%.cmo: %.ml
-	ocamlc -c $<
-
-%.cmi: %.mli
-	ocamlc -c $<
-
-%.ml: %.mll
-	ocamllex $<
-
-%.ml: %.mly
-	ocamlyacc -v $<
-
-%.mli: %.mly
-	ocamlyacc -v $<
-
-clean::
-	rm -f *.cm* *.output syntax.ml syntax.mli lex.ml newparse
-
-parse.cmo: ast.cmo
-syntax.cmi: parse.cmo
-syntax.cmo: lex.cmo parse.cmo syntax.cmi
-lex.cmo: syntax.cmi
-ast.cmo: ast.ml
-
-newsyntax.dvi: newsyntax.tex
-	latex $<
-	latex $<
-
-coq.dvi: coq.tex
-	latex coq
-	latex coq
-
-coq.tex::
-	ocamlweb -p "\usepackage{epsfig}" \
-	macros.tex intro.tex \
-	../../lib/{doc.tex,*.mli} ../../kernel/{doc.tex,*.mli} ../../library/{doc.tex,*.mli} \
-	../../pretyping/{doc.tex,*.mli} ../../interp/{doc.tex,*.mli} \
-	../../parsing/{doc.tex,*.mli} ../../proofs/{doc.tex,*.mli} \
-	../../tactics/{doc.tex,*.mli} ../../toplevel/{doc.tex,*.mli} \
-	-o coq.tex
-
-
-depend:: kernel.dep.ps library.dep.ps pretyping.dep.ps parsing.dep.ps \
-         proofs.dep.ps tactics.dep.ps toplevel.dep.ps interp.dep.ps
-
-%.dot: ../../%
-	ocamldoc -rectypes $(MLINCLUDES) -t $* -dot -dot-reduce ../../$*/*.ml ../../$*/*.mli -o $@
-
-%.dep.ps: %.dot
-	dot -Tps $< -o $@
-
-clean::
-	rm -f *~ *.log *.aux
-
-.SUFFIXES: .tex .dvi .ps .cmo .cmi .mli .ml .mll .mly
-
-%.dvi: %.tex
-	latex $< && latex $<
-
-%.ps: %.dvi
-	dvips $< -o $@
-
-
diff --git a/dev/ocamlweb-doc/ast.ml b/dev/ocamlweb-doc/ast.ml
deleted file mode 100644
index 4eb135d8..00000000
--- a/dev/ocamlweb-doc/ast.ml
+++ /dev/null
@@ -1,47 +0,0 @@
-
-type constr_ast =
-  Pair of constr_ast * constr_ast
-| Prod of binder list * constr_ast
-| Lambda of binder list * constr_ast
-| Let of string * constr_ast * constr_ast
-| LetCase of binder list * constr_ast * constr_ast
-| IfCase of constr_ast * constr_ast * constr_ast
-| Eval of red_fun * constr_ast
-| Infix of string * constr_ast * constr_ast
-| Prefix of string * constr_ast
-| Postfix of string * constr_ast
-| Appl of constr_ast * constr_arg list
-| ApplExpl of string list * constr_ast list
-| Scope of string * constr_ast
-| Qualid of string list
-| Prop | Set | Type
-| Int of string
-| Hole
-| Meta of string
-| Fixp of fix_kind *
-      (string * binder list * constr_ast * string option * constr_ast) list *
-      string
-| Match of case_item list * constr_ast option *
-           (pattern list * constr_ast) list
-
-and red_fun = Simpl
-
-and binder = string * constr_ast
-
-and constr_arg = string option * constr_ast
-
-and fix_kind = Fix | CoFix
-
-and case_item = constr_ast * (string option * constr_ast option)
-
-and pattern =
-  PatAs of pattern * string
-| PatType of pattern * constr_ast
-| PatConstr of string * pattern list
-| PatVar of string
-
-let mk_cast c t =
-  if t=Hole then c else Infix(":",c,t)
-
-let mk_lambda bl t =
-  if bl=[] then t else Lambda(bl,t)
diff --git a/dev/ocamlweb-doc/interp.dep.ps b/dev/ocamlweb-doc/interp.dep.ps
deleted file mode 100644
index fda7a33c..00000000
--- a/dev/ocamlweb-doc/interp.dep.ps
+++ /dev/null
@@ -1,545 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: Graphviz version 2.12 (Tue Oct 23 13:46:12 UTC 2007)
-%%For: (notin) Jean-Marc Notin,,,
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: (atend)
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-EncodingVector 45 /hyphen put
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-       dup 1 exch div /InvScaleFactor exch def
-       scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-setupLatin1
-%%Page: 1 1
-%%PageBoundingBox: 36 36 576 753
-%%PageOrientation: Landscape
-gsave
-36 36 576 753 boxprim clip newpath
-0 0 1 beginpage
-0.985401 0.985401 set_scale 90 rotate 40.5333 -580.533 translate
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 544 lineto
-724 544 lineto
-724 -4 lineto
-closepath fill
-0.985401 setlinewidth
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 544 lineto
-724 544 lineto
-724 -4 lineto
-closepath stroke
-% Constrextern
-gsave
-0.502 1.000 0.820 nodecolor
-172 417 49.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-172 417 49.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-172 412 moveto 72 -0.5 (Constrextern) alignedtext
-grestore
-% Reserve
-gsave
-0.502 1.000 0.820 nodecolor
-264 319 35.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-264 319 35.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-264 314 moveto 44 -0.5 (Reserve) alignedtext
-grestore
-% Constrextern->Reserve
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 188 400 moveto
-203 384 225 361 242 343 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 245.049 344.831 moveto
-249 335 lineto
-239.781 340.221 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 245.049 344.831 moveto
-249 335 lineto
-239.781 340.221 lineto
-closepath stroke
-grestore
-% Notation
-gsave
-0.502 1.000 0.820 nodecolor
-268 122 37.1753 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-268 122 37.1753 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-268 117 moveto 49 -0.5 (Notation) alignedtext
-grestore
-% Constrextern->Notation
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 178 399 moveto
-194 349 240 209 259 150 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 262.479 150.584 moveto
-262 140 lineto
-255.774 148.573 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 262.479 150.584 moveto
-262 140 lineto
-255.774 148.573 lineto
-closepath stroke
-grestore
-% Topconstr
-gsave
-0.502 1.000 0.820 nodecolor
-82 24 41.1755 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-82 24 41.1755 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-82 19 moveto 57 -0.5 (Topconstr) alignedtext
-grestore
-% Notation->Topconstr
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 243 109 moveto
-211 91 154 62 117 43 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 118.441 39.7969 moveto
-108 38 lineto
-115.042 45.916 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 118.441 39.7969 moveto
-108 38 lineto
-115.042 45.916 lineto
-closepath stroke
-grestore
-% Ppextend
-gsave
-0.502 1.000 0.820 nodecolor
-278 24 39.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-278 24 39.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-278 19 moveto 52 -0.5 (Ppextend) alignedtext
-grestore
-% Notation->Ppextend
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 270 104 moveto
-272 89 273 68 275 52 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 278.488 52.2987 moveto
-276 42 lineto
-271.522 51.6021 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 278.488 52.2987 moveto
-276 42 lineto
-271.522 51.6021 lineto
-closepath stroke
-grestore
-% Constrintern
-gsave
-0.502 1.000 0.820 nodecolor
-472 417 48.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-472 417 48.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-472 412 moveto 70 -0.5 (Constrintern) alignedtext
-grestore
-% Constrintern->Reserve
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 442 403 moveto
-404 385 340 355 299 335 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 300.56 331.863 moveto
-290 331 lineto
-297.717 338.26 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 300.56 331.863 moveto
-290 331 lineto
-297.717 338.26 lineto
-closepath stroke
-grestore
-% Implicit_quantifiers
-gsave
-0.502 1.000 0.820 nodecolor
-508 319 69.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-508 319 69.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-508 314 moveto 112 -0.5 (Implicit_quantifiers) alignedtext
-grestore
-% Constrintern->Implicit_quantifiers
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 479 399 moveto
-484 385 492 364 498 347 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 501.479 347.584 moveto
-501 337 lineto
-494.774 345.573 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 501.479 347.584 moveto
-501 337 lineto
-494.774 345.573 lineto
-closepath stroke
-grestore
-% Syntax_def
-gsave
-0.502 1.000 0.820 nodecolor
-396 220 45.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-396 220 45.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-396 215 moveto 64 -0.5 (Syntax_def) alignedtext
-grestore
-% Implicit_quantifiers->Syntax_def
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 488 302 moveto
-469 285 442 261 422 244 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 424.546 241.596 moveto
-415 237 lineto
-419.596 246.546 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 424.546 241.596 moveto
-415 237 lineto
-419.596 246.546 lineto
-closepath stroke
-grestore
-% Coqlib
-gsave
-0.502 1.000 0.820 nodecolor
-656 515 32.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-656 515 32.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-656 510 moveto 38 -0.5 (Coqlib) alignedtext
-grestore
-% Genarg
-gsave
-0.502 1.000 0.820 nodecolor
-82 122 33.175 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-82 122 33.175 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-82 117 moveto 41 -0.5 (Genarg) alignedtext
-grestore
-% Genarg->Topconstr
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 82 104 moveto
-82 89 82 69 82 52 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 85.5001 52 moveto
-82 42 lineto
-78.5001 52 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 85.5001 52 moveto
-82 42 lineto
-78.5001 52 lineto
-closepath stroke
-grestore
-% Syntax_def->Notation
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 375 204 moveto
-354 187 320 161 296 143 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 298.1 140.2 moveto
-288 137 lineto
-293.9 145.8 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 298.1 140.2 moveto
-288 137 lineto
-293.9 145.8 lineto
-closepath stroke
-grestore
-% Modintern
-gsave
-0.502 1.000 0.820 nodecolor
-472 515 42.1756 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-472 515 42.1756 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-472 510 moveto 59 -0.5 (Modintern) alignedtext
-grestore
-% Modintern->Constrintern
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 472 497 moveto
-472 482 472 462 472 445 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 475.5 445 moveto
-472 435 lineto
-468.5 445 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 475.5 445 moveto
-472 435 lineto
-468.5 445 lineto
-closepath stroke
-grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-%%BoundingBox: 36 36 576 753
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/intro.tex b/dev/ocamlweb-doc/intro.tex
deleted file mode 100644
index 4cec8673..00000000
--- a/dev/ocamlweb-doc/intro.tex
+++ /dev/null
@@ -1,25 +0,0 @@
-
-\ocwsection This is \Coq, a proof assistant for the \CCI.
-This document describes the implementation of \Coq.
-It has been automatically generated from the source of
-\Coq\ using \textsf{ocamlweb}, a literate programming tool for
-\textsf{Objective Caml}\footnote{\Coq, \textsf{Objective Caml} and
-  \textsf{ocamlweb} are all freely available at
-  \textsf{http://coq.inria.fr/}, \textsf{http://caml.inria.fr/} and
-  \textsf{http://www.lri.fr/\~{}filliatr/ocamlweb}.}.
-The source files are organized in several directories, which are
-described here as separate chapters.
-
-\begin{center}
-  \begin{tabular}{p{10cm}rr}
-    Chapter & section & page \\[0.5em]
-    \hline\\[0.2em]
-    Utility libraries \dotfill & \refsec{lib}     & \pageref{lib}     \\[0.5em]
-    Kernel            \dotfill & \refsec{kernel}  & \pageref{kernel}  \\[0.5em]
-    Library           \dotfill & \refsec{library} & \pageref{library} \\[0.5em]
-    Pretyping     \dotfill & \refsec{pretyping} & \pageref{pretyping} \\[0.5em]
-    Proof engine      \dotfill & \refsec{proofs}  & \pageref{proofs}  \\[0.5em]
-    Tactics           \dotfill & \refsec{tactics} & \pageref{tactics} \\[0.5em]
-    Toplevel          \dotfill & \refsec{toplevel}& \pageref{toplevel}\\[0.5em]
-  \end{tabular}
-\end{center}
\ No newline at end of file
diff --git a/dev/ocamlweb-doc/kernel.dep.ps b/dev/ocamlweb-doc/kernel.dep.ps
deleted file mode 100644
index b7b4137b..00000000
--- a/dev/ocamlweb-doc/kernel.dep.ps
+++ /dev/null
@@ -1,1431 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: Graphviz version 2.12 (Tue Oct 23 13:46:12 UTC 2007)
-%%For: (notin) Jean-Marc Notin,,,
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: (atend)
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-EncodingVector 45 /hyphen put
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-       dup 1 exch div /InvScaleFactor exch def
-       scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-setupLatin1
-%%Page: 1 1
-%%PageBoundingBox: 36 36 535 756
-%%PageOrientation: Landscape
-gsave
-36 36 535 756 boxprim clip newpath
-0 0 1 beginpage
-0.393658 0.393658 set_scale 90 rotate 95.45 -1355.45 translate
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 1264 lineto
-1825 1264 lineto
-1825 -4 lineto
-closepath fill
-0.393658 setlinewidth
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 1264 lineto
-1825 1264 lineto
-1825 -4 lineto
-closepath stroke
-% Cbytecodes
-gsave
-0.502 1.000 0.820 nodecolor
-1258 234 45.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1258 234 45.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1258 229 moveto 64 -0.5 (Cbytecodes) alignedtext
-grestore
-% Term
-gsave
-0.502 1.000 0.820 nodecolor
-1093 162 28.1746 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1093 162 28.1746 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1093 157 moveto 31 -0.5 (Term) alignedtext
-grestore
-% Cbytecodes->Term
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1227 221 moveto
-1198 208 1155 189 1125 176 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1126.56 172.863 moveto
-1116 172 lineto
-1123.72 179.26 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1126.56 172.863 moveto
-1116 172 lineto
-1123.72 179.26 lineto
-closepath stroke
-grestore
-% Esubst
-gsave
-0.502 1.000 0.820 nodecolor
-1093 90 31.1748 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1093 90 31.1748 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1093 85 moveto 37 -0.5 (Esubst) alignedtext
-grestore
-% Term->Esubst
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1093 144 moveto
-1093 136 1093 127 1093 118 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1096.5 118 moveto
-1093 108 lineto
-1089.5 118 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1096.5 118 moveto
-1093 108 lineto
-1089.5 118 lineto
-closepath stroke
-grestore
-% Univ
-gsave
-0.502 1.000 0.820 nodecolor
-580 90 27.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-580 90 27.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-580 85 moveto 28 -0.5 (Univ) alignedtext
-grestore
-% Term->Univ
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1065 158 moveto
-979 145 714 109 616 95 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 616.299 91.5125 moveto
-606 94 lineto
-615.602 98.4778 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 616.299 91.5125 moveto
-606 94 lineto
-615.602 98.4778 lineto
-closepath stroke
-grestore
-% Cbytegen
-gsave
-0.502 1.000 0.820 nodecolor
-1148 522 39.1754 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1148 522 39.1754 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1148 517 moveto 53 -0.5 (Cbytegen) alignedtext
-grestore
-% Pre_env
-gsave
-0.502 1.000 0.820 nodecolor
-1148 450 36.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1148 450 36.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1148 445 moveto 46 -0.5 (Pre_env) alignedtext
-grestore
-% Cbytegen->Pre_env
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1148 504 moveto
-1148 496 1148 487 1148 478 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 478 moveto
-1148 468 lineto
-1144.5 478 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 478 moveto
-1148 468 lineto
-1144.5 478 lineto
-closepath stroke
-grestore
-% Declarations
-gsave
-0.502 1.000 0.820 nodecolor
-1148 378 48.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1148 378 48.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1148 373 moveto 70 -0.5 (Declarations) alignedtext
-grestore
-% Pre_env->Declarations
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1148 432 moveto
-1148 424 1148 415 1148 406 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 406 moveto
-1148 396 lineto
-1144.5 406 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 406 moveto
-1148 396 lineto
-1144.5 406 lineto
-closepath stroke
-grestore
-% Cemitcodes
-gsave
-0.502 1.000 0.820 nodecolor
-663 306 45.1757 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-663 306 45.1757 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-663 301 moveto 65 -0.5 (Cemitcodes) alignedtext
-grestore
-% Cemitcodes->Cbytecodes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 706 301 moveto
-813 287 1088 254 1205 240 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1205.4 243.478 moveto
-1215 239 lineto
-1204.7 236.512 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1205.4 243.478 moveto
-1215 239 lineto
-1204.7 236.512 lineto
-closepath stroke
-grestore
-% Copcodes
-gsave
-0.502 1.000 0.820 nodecolor
-786 234 40.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-786 234 40.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-786 229 moveto 54 -0.5 (Copcodes) alignedtext
-grestore
-% Cemitcodes->Copcodes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 688 291 moveto
-707 281 732 266 752 253 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 753.958 255.916 moveto
-761 248 lineto
-750.559 249.797 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 753.958 255.916 moveto
-761 248 lineto
-750.559 249.797 lineto
-closepath stroke
-grestore
-% Mod_subst
-gsave
-0.502 1.000 0.820 nodecolor
-325 234 43.1756 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-325 234 43.1756 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-325 229 moveto 61 -0.5 (Mod_subst) alignedtext
-grestore
-% Cemitcodes->Mod_subst
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 623 298 moveto
-561 284 441 259 374 244 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 374.492 240.529 moveto
-364 242 lineto
-373.119 247.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 374.492 240.529 moveto
-364 242 lineto
-373.119 247.393 lineto
-closepath stroke
-grestore
-% Mod_subst->Term
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 367 230 moveto
-502 217 925 178 1055 166 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1055.4 169.478 moveto
-1065 165 lineto
-1054.7 162.512 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1055.4 169.478 moveto
-1065 165 lineto
-1054.7 162.512 lineto
-closepath stroke
-grestore
-% Closure
-gsave
-0.502 1.000 0.820 nodecolor
-713 666 34.1751 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-713 666 34.1751 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-713 661 moveto 43 -0.5 (Closure) alignedtext
-grestore
-% Environ
-gsave
-0.502 1.000 0.820 nodecolor
-1148 594 36.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1148 594 36.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1148 589 moveto 46 -0.5 (Environ) alignedtext
-grestore
-% Closure->Environ
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 746 661 moveto
-823 648 1016 616 1104 602 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1104.88 605.393 moveto
-1114 600 lineto
-1103.51 598.529 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1104.88 605.393 moveto
-1114 600 lineto
-1103.51 598.529 lineto
-closepath stroke
-grestore
-% Environ->Cbytegen
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1148 576 moveto
-1148 568 1148 559 1148 550 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 550 moveto
-1148 540 lineto
-1144.5 550 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 550 moveto
-1148 540 lineto
-1144.5 550 lineto
-closepath stroke
-grestore
-% Conv_oracle
-gsave
-0.502 1.000 0.820 nodecolor
-383 522 48.1758 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-383 522 48.1758 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-383 517 moveto 71 -0.5 (Conv_oracle) alignedtext
-grestore
-% Names
-gsave
-0.502 1.000 0.820 nodecolor
-288 18 32.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-288 18 32.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-288 13 moveto 38 -0.5 (Names) alignedtext
-grestore
-% Conv_oracle->Names
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 339 515 moveto
-238 497 0 449 0 378 curveto
-0 378 0 378 0 162 curveto
-0 53 166 26 246 20 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 246.398 23.4778 moveto
-256 19 lineto
-245.701 16.5125 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 246.398 23.4778 moveto
-256 19 lineto
-245.701 16.5125 lineto
-closepath stroke
-grestore
-% Cooking
-gsave
-0.502 1.000 0.820 nodecolor
-960 1026 37.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-960 1026 37.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-960 1021 moveto 48 -0.5 (Cooking) alignedtext
-grestore
-% Typeops
-gsave
-0.502 1.000 0.820 nodecolor
-960 954 37.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-960 954 37.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-960 949 moveto 48 -0.5 (Typeops) alignedtext
-grestore
-% Cooking->Typeops
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 960 1008 moveto
-960 1000 960 991 960 982 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 963.5 982 moveto
-960 972 lineto
-956.5 982 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 963.5 982 moveto
-960 972 lineto
-956.5 982 lineto
-closepath stroke
-grestore
-% Entries
-gsave
-0.502 1.000 0.820 nodecolor
-1391 882 33.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1391 882 33.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1391 877 moveto 40 -0.5 (Entries) alignedtext
-grestore
-% Typeops->Entries
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 995 948 moveto
-1074 935 1265 903 1349 889 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1349.88 892.393 moveto
-1359 887 lineto
-1348.51 885.529 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1349.88 892.393 moveto
-1359 887 lineto
-1348.51 885.529 lineto
-closepath stroke
-grestore
-% Inductive
-gsave
-0.502 1.000 0.820 nodecolor
-837 882 39.1754 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-837 882 39.1754 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-837 877 moveto 53 -0.5 (Inductive) alignedtext
-grestore
-% Typeops->Inductive
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 936 940 moveto
-918 929 891 914 871 901 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 872.441 897.797 moveto
-862 896 lineto
-869.042 903.916 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 872.441 897.797 moveto
-862 896 lineto
-869.042 903.916 lineto
-closepath stroke
-grestore
-% Csymtable
-gsave
-0.502 1.000 0.820 nodecolor
-1148 666 42.1756 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1148 666 42.1756 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1148 661 moveto 59 -0.5 (Csymtable) alignedtext
-grestore
-% Csymtable->Environ
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1148 648 moveto
-1148 640 1148 631 1148 622 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 622 moveto
-1148 612 lineto
-1144.5 622 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 622 moveto
-1148 612 lineto
-1144.5 622 lineto
-closepath stroke
-grestore
-% Vm
-gsave
-0.502 1.000 0.820 nodecolor
-731 594 27 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-731 594 27 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-731 589 moveto 21 -0.5 (Vm) alignedtext
-grestore
-% Csymtable->Vm
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1109 659 moveto
-1029 645 845 614 767 600 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 767.492 596.529 moveto
-757 598 lineto
-766.119 603.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 767.492 596.529 moveto
-757 598 lineto
-766.119 603.393 lineto
-closepath stroke
-grestore
-% Vm->Cemitcodes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 727 576 moveto
-716 527 684 392 669 334 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 672.393 333.119 moveto
-667 324 lineto
-665.529 334.492 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 672.393 333.119 moveto
-667 324 lineto
-665.529 334.492 lineto
-closepath stroke
-grestore
-% Vm->Conv_oracle
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 705 589 moveto
-648 577 510 549 435 533 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 435.492 529.529 moveto
-425 531 lineto
-434.119 536.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 435.492 529.529 moveto
-425 531 lineto
-434.119 536.393 lineto
-closepath stroke
-grestore
-% Declarations->Cemitcodes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1103 371 moveto
-1013 358 811 328 715 314 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 715.492 310.529 moveto
-705 312 lineto
-714.119 317.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 715.492 310.529 moveto
-705 312 lineto
-714.119 317.393 lineto
-closepath stroke
-grestore
-% Sign
-gsave
-0.502 1.000 0.820 nodecolor
-1697 306 27 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1697 306 27 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1697 301 moveto 26 -0.5 (Sign) alignedtext
-grestore
-% Declarations->Sign
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1193 372 moveto
-1300 359 1563 324 1660 311 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1660.4 314.478 moveto
-1670 310 lineto
-1659.7 307.512 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1660.4 314.478 moveto
-1670 310 lineto
-1659.7 307.512 lineto
-closepath stroke
-grestore
-% Retroknowledge
-gsave
-0.502 1.000 0.820 nodecolor
-1221 306 59.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1221 306 59.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1221 301 moveto 92 -0.5 (Retroknowledge) alignedtext
-grestore
-% Declarations->Retroknowledge
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1165 361 moveto
-1175 352 1186 341 1197 330 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1199.4 332.546 moveto
-1204 323 lineto
-1194.45 327.596 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1199.4 332.546 moveto
-1204 323 lineto
-1194.45 327.596 lineto
-closepath stroke
-grestore
-% Sign->Term
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1671 300 moveto
-1576 277 1241 197 1130 170 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1130.49 166.529 moveto
-1120 168 lineto
-1129.12 173.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1130.49 166.529 moveto
-1120 168 lineto
-1129.12 173.393 lineto
-closepath stroke
-grestore
-% Retroknowledge->Cbytecodes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1230 288 moveto
-1234 280 1239 270 1244 261 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1247.2 262.441 moveto
-1249 252 lineto
-1241.08 259.042 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1247.2 262.441 moveto
-1249 252 lineto
-1241.08 259.042 lineto
-closepath stroke
-grestore
-% Entries->Sign
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1411 868 moveto
-1442 844 1496 795 1496 738 curveto
-1496 738 1496 738 1496 450 curveto
-1496 370 1604 330 1661 314 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1661.88 317.393 moveto
-1671 312 lineto
-1660.51 310.529 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1661.88 317.393 moveto
-1671 312 lineto
-1660.51 310.529 lineto
-closepath stroke
-grestore
-% Indtypes
-gsave
-0.502 1.000 0.820 nodecolor
-539 1026 37.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-539 1026 37.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-539 1021 moveto 48 -0.5 (Indtypes) alignedtext
-grestore
-% Indtypes->Typeops
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 574 1020 moveto
-650 1008 831 977 915 962 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 915.881 965.393 moveto
-925 960 lineto
-914.508 958.529 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 915.881 965.393 moveto
-925 960 lineto
-914.508 958.529 lineto
-closepath stroke
-grestore
-% Type_errors
-gsave
-0.502 1.000 0.820 nodecolor
-713 810 47.1758 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-713 810 47.1758 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-713 805 moveto 69 -0.5 (Type_errors) alignedtext
-grestore
-% Inductive->Type_errors
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 813 868 moveto
-794 858 769 843 748 830 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 749.441 826.797 moveto
-739 825 lineto
-746.042 832.916 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 749.441 826.797 moveto
-739 825 lineto
-746.042 832.916 lineto
-closepath stroke
-grestore
-% Reduction
-gsave
-0.502 1.000 0.820 nodecolor
-713 738 41.1755 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-713 738 41.1755 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-713 733 moveto 57 -0.5 (Reduction) alignedtext
-grestore
-% Type_errors->Reduction
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 713 792 moveto
-713 784 713 775 713 766 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 716.5 766 moveto
-713 756 lineto
-709.5 766 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 716.5 766 moveto
-713 756 lineto
-709.5 766 lineto
-closepath stroke
-grestore
-% Modops
-gsave
-0.502 1.000 0.820 nodecolor
-1404 954 35.1752 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1404 954 35.1752 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1404 949 moveto 45 -0.5 (Modops) alignedtext
-grestore
-% Modops->Environ
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1439 951 moveto
-1511 943 1670 914 1670 810 curveto
-1670 810 1670 810 1670 738 curveto
-1670 639 1322 606 1194 597 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1194.3 593.512 moveto
-1184 596 lineto
-1193.6 600.478 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1194.3 593.512 moveto
-1184 596 lineto
-1193.6 600.478 lineto
-closepath stroke
-grestore
-% Modops->Entries
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1401 936 moveto
-1400 928 1398 919 1396 910 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1399.39 909.119 moveto
-1394 900 lineto
-1392.53 910.492 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1399.39 909.119 moveto
-1394 900 lineto
-1392.53 910.492 lineto
-closepath stroke
-grestore
-% Mod_typing
-gsave
-0.502 1.000 0.820 nodecolor
-1157 1170 47.1758 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1157 1170 47.1758 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1157 1165 moveto 69 -0.5 (Mod_typing) alignedtext
-grestore
-% Subtyping
-gsave
-0.502 1.000 0.820 nodecolor
-1404 1026 42.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1404 1026 42.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1404 1021 moveto 58 -0.5 (Subtyping) alignedtext
-grestore
-% Mod_typing->Subtyping
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1183 1155 moveto
-1227 1129 1320 1075 1370 1046 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1371.96 1048.92 moveto
-1379 1041 lineto
-1368.56 1042.8 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1371.96 1048.92 moveto
-1379 1041 lineto
-1368.56 1042.8 lineto
-closepath stroke
-grestore
-% Term_typing
-gsave
-0.502 1.000 0.820 nodecolor
-960 1098 50.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-960 1098 50.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-960 1093 moveto 74 -0.5 (Term_typing) alignedtext
-grestore
-% Mod_typing->Term_typing
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1123 1157 moveto
-1090 1145 1040 1127 1005 1114 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1005.58 1110.52 moveto
-995 1111 lineto
-1003.57 1117.23 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1005.58 1110.52 moveto
-995 1111 lineto
-1003.57 1117.23 lineto
-closepath stroke
-grestore
-% Subtyping->Typeops
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1365 1020 moveto
-1282 1007 1092 975 1005 962 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1005.49 958.529 moveto
-995 960 lineto
-1004.12 965.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1005.49 958.529 moveto
-995 960 lineto
-1004.12 965.393 lineto
-closepath stroke
-grestore
-% Subtyping->Modops
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1404 1008 moveto
-1404 1000 1404 991 1404 982 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1407.5 982 moveto
-1404 972 lineto
-1400.5 982 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1407.5 982 moveto
-1404 972 lineto
-1400.5 982 lineto
-closepath stroke
-grestore
-% Term_typing->Cooking
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 960 1080 moveto
-960 1072 960 1063 960 1054 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 963.5 1054 moveto
-960 1044 lineto
-956.5 1054 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 963.5 1054 moveto
-960 1044 lineto
-956.5 1054 lineto
-closepath stroke
-grestore
-% Term_typing->Indtypes
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 915 1090 moveto
-833 1077 665 1048 584 1034 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 584.492 1030.53 moveto
-574 1032 lineto
-583.119 1037.39 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 584.492 1030.53 moveto
-574 1032 lineto
-583.119 1037.39 lineto
-closepath stroke
-grestore
-% Reduction->Closure
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 713 720 moveto
-713 712 713 703 713 694 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 716.5 694 moveto
-713 684 lineto
-709.5 694 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 716.5 694 moveto
-713 684 lineto
-709.5 694 lineto
-closepath stroke
-grestore
-% Reduction->Conv_oracle
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 690 723 moveto
-633 686 482 587 415 544 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 417.1 541.2 moveto
-407 538 lineto
-412.9 546.8 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 417.1 541.2 moveto
-407 538 lineto
-412.9 546.8 lineto
-closepath stroke
-grestore
-% Safe_typing
-gsave
-0.502 1.000 0.820 nodecolor
-1157 1242 47.1777 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1157 1242 47.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1157 1237 moveto 68 -0.5 (Safe_typing) alignedtext
-grestore
-% Safe_typing->Mod_typing
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1157 1224 moveto
-1157 1216 1157 1207 1157 1198 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1160.5 1198 moveto
-1157 1188 lineto
-1153.5 1198 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1160.5 1198 moveto
-1157 1188 lineto
-1153.5 1198 lineto
-closepath stroke
-grestore
-% Univ->Names
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 555 84 moveto
-504 71 388 42 327 27 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 327.492 23.5292 moveto
-317 25 lineto
-326.119 30.3933 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 327.492 23.5292 moveto
-317 25 lineto
-326.119 30.3933 lineto
-closepath stroke
-grestore
-% Vconv
-gsave
-0.502 1.000 0.820 nodecolor
-1152 810 31.1748 18 ellipse_path fill
-0.393658 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-1152 810 31.1748 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-1152 805 moveto 37 -0.5 (Vconv) alignedtext
-grestore
-% Vconv->Csymtable
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1151 792 moveto
-1150 767 1149 723 1148 694 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 694 moveto
-1148 684 lineto
-1144.5 694 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 1151.5 694 moveto
-1148 684 lineto
-1144.5 694 lineto
-closepath stroke
-grestore
-% Vconv->Reduction
-gsave
-0.393658 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1122 805 moveto
-1047 792 852 760 761 746 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 761.492 742.529 moveto
-751 744 lineto
-760.119 749.393 lineto
-closepath fill
-0.393658 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 761.492 742.529 moveto
-751 744 lineto
-760.119 749.393 lineto
-closepath stroke
-grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-%%BoundingBox: 36 36 535 756
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/lex.mll b/dev/ocamlweb-doc/lex.mll
deleted file mode 100644
index 059526d9..00000000
--- a/dev/ocamlweb-doc/lex.mll
+++ /dev/null
@@ -1,81 +0,0 @@
-
-{
- open Lexing
- open Syntax
-
- let chan_out = ref stdout
-
- let comment_depth = ref 0
- let print s = output_string !chan_out s
-
- exception Fin_fichier
-
-}
-
-let space = [' ' '\t' '\n']
-let letter = ['a'-'z' 'A'-'Z']
-let digit = ['0'-'9']
-
-let identifier = letter (letter | digit | ['_' '\''])*
-let number = digit+
-let oper = ['-' '+' '/' '*' '|' '>' '<' '=' '%' '#' '$' ':' '\\' '?'
-            '.' '!' '@' ]+
-
-rule token = parse
-  | "let" {LET}
-  | "in" {IN}
-  | "match" {MATCH}
-  | "with" {WITH}
-  | "end" {END}
-  | "and" {AND}
-  | "fun" {FUN}
-  | "if" {IF}
-  | "then" {THEN}
-  | "else" {ELSE}
-  | "eval" {EVAL}
-  | "for" {FOR}
-  | "Prop" {PROP}
-  | "Set" {SET}
-  | "Type" {TYPE}
-  | "fix" {FIX}
-  | "cofix" {COFIX}
-  | "struct" {STRUCT}
-  | "as" {AS}
-
-  | "Simpl" {SIMPL}
-
-  | "_" {WILDCARD}
-  | "(" {LPAR}
-  | ")" {RPAR}
-  | "{" {LBRACE}
-  | "}" {RBRACE}
-  | "!" {BANG}
-  | "@" {AT}
-  | ":" {COLON}
-  | ":=" {COLONEQ}
-  | "." {DOT}
-  | "," {COMMA}
-  | "->" {OPER "->"}
-  | "=>" {RARROW}
-  | "|" {BAR}
-  | "%" {PERCENT}
-
-  | '?' { META(ident lexbuf)}
-  | number { INT(Lexing.lexeme lexbuf) }
-  | oper { OPER(Lexing.lexeme lexbuf) }
-  | identifier { IDENT (Lexing.lexeme lexbuf) }
-  | "(*" (*"*)"*)       { comment_depth := 1;
-                          comment lexbuf;
-		          token lexbuf }
-  | space+     { token lexbuf}
-  | eof        { EOF }
-
-and ident = parse
-  | identifier { Lexing.lexeme lexbuf }
-
-and comment = parse
-  | "(*" (*"*)"*)  { incr comment_depth; comment lexbuf }
-  | (*"(*"*) "*)"
-      { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
-  | eof   { raise Fin_fichier }
-  | _     { comment lexbuf }
diff --git a/dev/ocamlweb-doc/library.dep.ps b/dev/ocamlweb-doc/library.dep.ps
deleted file mode 100644
index c9bb351e..00000000
--- a/dev/ocamlweb-doc/library.dep.ps
+++ /dev/null
@@ -1,773 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: Graphviz version 2.12 (Tue Oct 23 13:46:12 UTC 2007)
-%%For: (notin) Jean-Marc Notin,,,
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: (atend)
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-EncodingVector 45 /hyphen put
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-       dup 1 exch div /InvScaleFactor exch def
-       scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-setupLatin1
-%%Page: 1 1
-%%PageBoundingBox: 36 36 576 752
-%%PageOrientation: Landscape
-gsave
-36 36 576 752 boxprim clip newpath
-0 0 1 beginpage
-0.985401 0.985401 set_scale 90 rotate 40.5333 -580.533 translate
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 544 lineto
-723 544 lineto
-723 -4 lineto
-closepath fill
-0.985401 setlinewidth
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 544 lineto
-723 544 lineto
-723 -4 lineto
-closepath stroke
-% Declare
-gsave
-0.502 1.000 0.820 nodecolor
-488 436 34.1751 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-488 436 34.1751 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-488 431 moveto 43 -0.5 (Declare) alignedtext
-grestore
-% Dischargedhypsmap
-gsave
-0.502 1.000 0.820 nodecolor
-488 353 69.1764 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-488 353 69.1764 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-488 348 moveto 113 -0.5 (Dischargedhypsmap) alignedtext
-grestore
-% Declare->Dischargedhypsmap
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 488 418 moveto
-488 407 488 393 488 381 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 491.5 381 moveto
-488 371 lineto
-484.5 381 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 491.5 381 moveto
-488 371 lineto
-484.5 381 lineto
-closepath stroke
-grestore
-% Impargs
-gsave
-0.502 1.000 0.820 nodecolor
-201 353 36.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-201 353 36.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-201 348 moveto 46 -0.5 (Impargs) alignedtext
-grestore
-% Declare->Impargs
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 458 427 moveto
-407 412 301 382 242 365 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 242.584 361.521 moveto
-232 362 lineto
-240.573 368.226 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 242.584 361.521 moveto
-232 362 lineto
-240.573 368.226 lineto
-closepath stroke
-grestore
-% Decl_kinds
-gsave
-0.502 1.000 0.820 nodecolor
-661 353 44.1757 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-661 353 44.1757 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-661 348 moveto 63 -0.5 (Decl_kinds) alignedtext
-grestore
-% Declare->Decl_kinds
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 514 424 moveto
-543 410 590 388 624 372 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 625.958 374.916 moveto
-633 367 lineto
-622.559 368.797 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 625.958 374.916 moveto
-633 367 lineto
-622.559 368.797 lineto
-closepath stroke
-grestore
-% Lib
-gsave
-0.502 1.000 0.820 nodecolor
-219 270 27 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-219 270 27 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-219 265 moveto 20 -0.5 (Lib) alignedtext
-grestore
-% Dischargedhypsmap->Lib
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 443 339 moveto
-390 323 302 296 254 281 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 254.584 277.521 moveto
-244 278 lineto
-252.573 284.226 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 254.584 277.521 moveto
-244 278 lineto
-252.573 284.226 lineto
-closepath stroke
-grestore
-% Global
-gsave
-0.502 1.000 0.820 nodecolor
-82 270 32.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-82 270 32.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-82 265 moveto 38 -0.5 (Global) alignedtext
-grestore
-% Impargs->Global
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 180 338 moveto
-161 325 132 305 110 290 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 112.1 287.2 moveto
-102 284 lineto
-107.9 292.8 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 112.1 287.2 moveto
-102 284 lineto
-107.9 292.8 lineto
-closepath stroke
-grestore
-% Impargs->Lib
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 205 335 moveto
-207 324 210 310 213 298 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 216.471 298.492 moveto
-215 288 lineto
-209.607 297.119 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 216.471 298.492 moveto
-215 288 lineto
-209.607 297.119 lineto
-closepath stroke
-grestore
-% Declaremods
-gsave
-0.502 1.000 0.820 nodecolor
-65 353 49.1759 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-65 353 49.1759 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-65 348 moveto 73 -0.5 (Declaremods) alignedtext
-grestore
-% Declaremods->Global
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 69 335 moveto
-71 324 74 310 76 298 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 79.4708 298.492 moveto
-78 288 lineto
-72.6067 297.119 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 79.4708 298.492 moveto
-78 288 lineto
-72.6067 297.119 lineto
-closepath stroke
-grestore
-% Declaremods->Lib
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 93 338 moveto
-120 324 161 301 189 286 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 190.958 288.916 moveto
-198 281 lineto
-187.559 282.797 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 190.958 288.916 moveto
-198 281 lineto
-187.559 282.797 lineto
-closepath stroke
-grestore
-% Summary
-gsave
-0.502 1.000 0.820 nodecolor
-69 103 40.1755 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-69 103 40.1755 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-69 98 moveto 55 -0.5 (Summary) alignedtext
-grestore
-% Global->Summary
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 81 252 moveto
-78 223 74 166 71 131 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 74.4778 130.602 moveto
-70 121 lineto
-67.5125 131.299 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 74.4778 130.602 moveto
-70 121 lineto
-67.5125 131.299 lineto
-closepath stroke
-grestore
-% Libnames
-gsave
-0.502 1.000 0.820 nodecolor
-203 103 40.1755 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-203 103 40.1755 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-203 98 moveto 55 -0.5 (Libnames) alignedtext
-grestore
-% Global->Libnames
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 94 253 moveto
-115 224 159 164 184 129 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 186.8 131.1 moveto
-190 121 lineto
-181.2 126.9 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 186.8 131.1 moveto
-190 121 lineto
-181.2 126.9 lineto
-closepath stroke
-grestore
-% Nametab
-gsave
-0.502 1.000 0.820 nodecolor
-203 186 38.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-203 186 38.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-203 181 moveto 50 -0.5 (Nametab) alignedtext
-grestore
-% Lib->Nametab
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 216 252 moveto
-214 241 211 226 209 214 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 212.393 213.119 moveto
-207 204 lineto
-205.529 214.492 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 212.393 213.119 moveto
-207 204 lineto
-205.529 214.492 lineto
-closepath stroke
-grestore
-% Libobject
-gsave
-0.502 1.000 0.820 nodecolor
-329 186 40.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-329 186 40.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-329 181 moveto 54 -0.5 (Libobject) alignedtext
-grestore
-% Lib->Libobject
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 237 256 moveto
-254 243 280 223 300 208 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 302.1 210.8 moveto
-308 202 lineto
-297.9 205.2 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 302.1 210.8 moveto
-308 202 lineto
-297.9 205.2 lineto
-closepath stroke
-grestore
-% Nameops
-gsave
-0.502 1.000 0.820 nodecolor
-203 20 39.1777 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-203 20 39.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-203 15 moveto 52 -0.5 (Nameops) alignedtext
-grestore
-% Libnames->Nameops
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 203 85 moveto
-203 74 203 60 203 48 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 206.5 48 moveto
-203 38 lineto
-199.5 48 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 206.5 48 moveto
-203 38 lineto
-199.5 48 lineto
-closepath stroke
-grestore
-% Goptions
-gsave
-0.502 1.000 0.820 nodecolor
-322 353 38.1754 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-322 353 38.1754 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-322 348 moveto 51 -0.5 (Goptions) alignedtext
-grestore
-% Goptions->Lib
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 303 337 moveto
-287 324 263 305 245 291 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 246.831 287.951 moveto
-237 284 lineto
-242.221 293.219 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 246.831 287.951 moveto
-237 284 lineto
-242.221 293.219 lineto
-closepath stroke
-grestore
-% Nametab->Summary
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 180 172 moveto
-158 159 125 138 101 123 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 102.441 119.797 moveto
-92 118 lineto
-99.0418 125.916 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 102.441 119.797 moveto
-92 118 lineto
-99.0418 125.916 lineto
-closepath stroke
-grestore
-% Nametab->Libnames
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 203 168 moveto
-203 157 203 143 203 131 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 206.5 131 moveto
-203 121 lineto
-199.5 131 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 206.5 131 moveto
-203 121 lineto
-199.5 131 lineto
-closepath stroke
-grestore
-% Libobject->Libnames
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 306 171 moveto
-286 158 256 138 235 124 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 236.262 120.635 moveto
-226 118 lineto
-232.379 126.459 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 236.262 120.635 moveto
-226 118 lineto
-232.379 126.459 lineto
-closepath stroke
-grestore
-% Library
-gsave
-0.502 1.000 0.820 nodecolor
-65 436 34.1751 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-65 436 34.1751 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-65 431 moveto 43 -0.5 (Library) alignedtext
-grestore
-% Library->Declaremods
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 65 418 moveto
-65 407 65 393 65 381 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 68.5001 381 moveto
-65 371 lineto
-61.5001 381 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 68.5001 381 moveto
-65 371 lineto
-61.5001 381 lineto
-closepath stroke
-grestore
-% States
-gsave
-0.502 1.000 0.820 nodecolor
-65 519 29.1747 18 ellipse_path fill
-0.985401 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-65 519 29.1747 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-65 514 moveto 33 -0.5 (States) alignedtext
-grestore
-% States->Library
-gsave
-0.985401 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 65 501 moveto
-65 490 65 476 65 464 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 68.5001 464 moveto
-65 454 lineto
-61.5001 464 lineto
-closepath fill
-0.985401 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 68.5001 464 moveto
-65 454 lineto
-61.5001 464 lineto
-closepath stroke
-grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-%%BoundingBox: 36 36 576 752
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/macros.tex b/dev/ocamlweb-doc/macros.tex
deleted file mode 100644
index 6beacf7b..00000000
--- a/dev/ocamlweb-doc/macros.tex
+++ /dev/null
@@ -1,7 +0,0 @@
-
-% macros for coq.tex
-
-\newcommand{\Coq}{\textsf{Coq}}
-\newcommand{\CCI}{Calculus of Inductive Constructions}
-
-\newcommand{\refsec}[1]{\textbf{\ref{#1}}}
\ No newline at end of file
diff --git a/dev/ocamlweb-doc/parse.ml b/dev/ocamlweb-doc/parse.ml
deleted file mode 100644
index b145fffd..00000000
--- a/dev/ocamlweb-doc/parse.ml
+++ /dev/null
@@ -1,183 +0,0 @@
-
-open Ast
-
-type assoc = L | R | N
-
-let level = function
-  | "--" -> 70,L
-  | "=" -> 70,N
-  | "+" -> 60,L
-  | "++" -> 60,R
-  | "+++" -> 60,R
-  | "-" -> 60,L
-  | "*" -> 50,L
-  | "/" -> 50,L
-  | "**" -> 40,R
-  | ":" -> (100,R)
-  | "->" -> (90,R)
-  | s -> failwith ("unknowm operator '"^s^"'")
-
-let fixity = function
-  | "--" -> [L]
-  | "=" -> [N]
-  | ("+"|"-"|"*"|"/") -> [L;N]
-  | "++" -> [R]
-  | _ -> [L;N;R]
-
-let ground_oper = function
-    ("-"|"+") -> true
-  | _ -> false
-
-let is_prefix op = List.mem L (fixity op)
-let is_infix op = List.mem N (fixity op)
-let is_postfix op = List.mem R (fixity op)
-
-let mk_inf op t1 t2 =
-  if not (is_infix op) then failwith (op^" not infix");
-  Infix(op,t1,t2)
-
-let mk_post op t =
-  if not (is_postfix op) then failwith (op^" not postfix");
-  Postfix(op,t)
-
-
-(* Pb avec ground_oper: pas de diff entre -1 et -(1) *)
-let mk_pre op t =
-  if not (is_prefix op) then failwith (op^" not prefix");
-  if ground_oper op then
-    match t with
-    | Int i -> Int (op^i)
-    | _     -> Prefix(op,t)
-  else Prefix(op,t)
-
-(* teste si on peut reduire op suivi d'un op de niveau (n,a)
-   si la reponse est false, c'est que l'op (n,a) doit se reduire
-   avant *)
-let red_left_op (nl,al) (nr,ar) =
-  if nl < nr then true
-  else
-    if nl = nr then
-      match al,ar with
-        | (L|N), L -> true
-        | R, (R|N) -> false
-        | R, L ->  failwith "conflit d'assoc: ambigu"
-        | (L|N), (R|N) -> failwith "conflit d'assoc: blocage"
-    else false
-
-
-type level = int * assoc
-type stack =
-  | PrefixOper of string list
-  | Term of constr_ast * stack
-  | Oper of string list * string * constr_ast * stack
-
-let rec str_ast = function
-  | Infix(op,t1,t2) -> str_ast t1 ^ " " ^ op ^ " " ^ str_ast t2
-  | Postfix(op,t) -> str_ast t ^ " " ^ op
-  | Prefix(op,t) -> op ^ " " ^ str_ast t
-  | _ -> "_"
-
-let rec str_stack = function
-  | PrefixOper ops -> String.concat " " (List.rev ops)
-  | 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)
-
-let pps s = prerr_endline (str_stack s)
-let err s stk = failwith (s^": "^str_stack stk)
-
-
-let empty = PrefixOper []
-
-let check_fixity_term stk =
-  match stk with
-      Term _ -> err "2 termes successifs" stk
-    | _ -> ()
-
-let shift_term t stk =
-  check_fixity_term stk;
-  Term(t,stk)
-
-let shift_oper op stk =
-  match stk with
-    | Oper(ops,lop,t,s) -> Oper(op::ops,lop,t,s)
-    | Term(t,s) -> Oper([],op,t,s)
-    | PrefixOper ops -> PrefixOper (op::ops)
-
-let is_reducible lv stk =
-  match stk with
-    | Oper([],iop,_,_)  -> red_left_op (level iop) lv
-    | Oper(op::_,_,_,_) -> red_left_op (level op) lv
-    | PrefixOper(op::_) -> red_left_op (level op) lv
-    | _                 -> false
-
-let reduce_head (t,stk) =
-  match stk with
-    | Oper([],iop,t1,s) ->
-        (Infix(iop,t1,t), s)
-    | Oper(op::ops,lop,t',s) ->
-        (mk_pre op t, Oper(ops,lop,t',s))
-    | PrefixOper(op::ops) ->
-        (Prefix(op,t), PrefixOper ops)
-    | _ -> assert false
-
-let rec reduce_level lv (t,s) =
-  if is_reducible lv s then reduce_level lv (reduce_head (t, s))
-  else (t, s)
-
-let reduce_post op (t,s) =
-  let (t',s') = reduce_level (level op) (t,s) in
-  (mk_post op t', s')
-
-let reduce_posts stk =
-  match stk with
-      Oper(ops,iop,t,s) ->
-        let pts1 = reduce_post iop (t,s) in
-        List.fold_right reduce_post ops pts1
-    | Term(t,s) -> (t,s)
-    | PrefixOper _ -> failwith "reduce_posts"
-
-
-let shift_infix op stk =
-  let (t,s) = reduce_level (level op) (reduce_posts stk) in
-  Oper([],op,t,s)
-
-let is_better_infix op stk =
-  match stk with
-    | Oper(ops,iop,t,s) ->
-        is_postfix iop &&
-        List.for_all is_postfix ops &&
-        (not (is_prefix op) || red_left_op (level iop) (level op))
-    | Term _ -> false
-    | _ -> assert false
-
-let parse_oper op stk =
-  match stk with
-    | PrefixOper _ ->
-        if is_prefix op then shift_oper op stk else failwith "prefix_oper"
-    | Oper _ ->
-        if is_infix op then
-          if is_better_infix op stk then shift_infix op stk
-          else shift_oper op stk
-        else if is_prefix op then shift_oper op stk
-        else if is_postfix op then
-          let (t,s) = reduce_post op (reduce_posts stk) in
-          Term(t,s)
-        else assert false
-    | Term(t,s) ->
-        if is_infix op then shift_infix op stk
-        else if is_postfix op then
-          let (t2,s2) = reduce_post op (t,s) in Term(t2,s2)
-        else failwith "infix/postfix"
-
-let parse_term = shift_term
-
-let rec close_stack stk =
-  match stk with
-      Term(t,PrefixOper []) -> t
-    | PrefixOper _ -> failwith "expression sans atomes"
-    | _ ->
-        let (t,s) = reduce_head (reduce_posts stk) in
-        close_stack (Term(t,s))
-
diff --git a/dev/ocamlweb-doc/parsing.dep.ps b/dev/ocamlweb-doc/parsing.dep.ps
deleted file mode 100644
index 723d8c69..00000000
--- a/dev/ocamlweb-doc/parsing.dep.ps
+++ /dev/null
@@ -1,1115 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
-%%For: (herbelin) Hugo Herbelin
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: 35 35 577 314
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-
-EncodingVector
-  dup 306 /AE
-  dup 301 /Aacute
-  dup 302 /Acircumflex
-  dup 304 /Adieresis
-  dup 300 /Agrave
-  dup 305 /Aring
-  dup 303 /Atilde
-  dup 307 /Ccedilla
-  dup 311 /Eacute
-  dup 312 /Ecircumflex
-  dup 313 /Edieresis
-  dup 310 /Egrave
-  dup 315 /Iacute
-  dup 316 /Icircumflex
-  dup 317 /Idieresis
-  dup 314 /Igrave
-  dup 334 /Udieresis
-  dup 335 /Yacute
-  dup 376 /thorn
-  dup 337 /germandbls
-  dup 341 /aacute
-  dup 342 /acircumflex
-  dup 344 /adieresis
-  dup 346 /ae
-  dup 340 /agrave
-  dup 345 /aring
-  dup 347 /ccedilla
-  dup 351 /eacute
-  dup 352 /ecircumflex
-  dup 353 /edieresis
-  dup 350 /egrave
-  dup 355 /iacute
-  dup 356 /icircumflex
-  dup 357 /idieresis
-  dup 354 /igrave
-  dup 360 /dcroat
-  dup 361 /ntilde
-  dup 363 /oacute
-  dup 364 /ocircumflex
-  dup 366 /odieresis
-  dup 362 /ograve
-  dup 365 /otilde
-  dup 370 /oslash
-  dup 372 /uacute
-  dup 373 /ucircumflex
-  dup 374 /udieresis
-  dup 371 /ugrave
-  dup 375 /yacute
-  dup 377 /ydieresis  
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-	dup 1 exch div /InvScaleFactor exch def
-	dup scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-%%Page: 1 1
-%%PageBoundingBox: 36 36 577 314
-%%PageOrientation: Portrait
-gsave
-35 35 542 279 boxprim clip newpath
-36 36 translate
-0 0 1 beginpage
-0.6027 set_scale
-0 0 translate 0 rotate
-0.000 0.000 0.000 graphcolor
-14.00 /Times-Roman set_font
-
-%	Pcoq
-gsave 10 dict begin
-557 280 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-543 275 moveto
-(Pcoq)
-[7.68 6.24 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Extend
-gsave 10 dict begin
-664 226 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-643 221 moveto
-(Extend)
-[8.4 6.96 3.84 6.24 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Pcoq -> Extend
-newpath 579 269 moveto
-593 261 613 252 630 243 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 632 246 moveto
-639 238 lineto
-629 240 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 632 246 moveto
-639 238 lineto
-629 240 lineto
-closepath
-stroke
-end grestore
-
-%	Ast
-gsave 10 dict begin
-764 172 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-753 167 moveto
-(Ast)
-[10.08 5.28 3.84]
-xshow
-end grestore
-end grestore
-
-%	Extend -> Ast
-newpath 688 213 moveto
-701 206 719 196 734 188 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 736 191 moveto
-743 183 lineto
-733 185 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 736 191 moveto
-743 183 lineto
-733 185 lineto
-closepath
-stroke
-end grestore
-
-%	Lexer
-gsave 10 dict begin
-764 226 29 18 ellipse_path
-stroke
-gsave 10 dict begin
-747 221 moveto
-(Lexer)
-[8.4 5.76 6.48 6.24 4.56]
-xshow
-end grestore
-end grestore
-
-%	Extend -> Lexer
-newpath 698 226 moveto
-706 226 715 226 724 226 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 724 230 moveto
-734 226 lineto
-724 223 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 724 230 moveto
-734 226 lineto
-724 223 lineto
-closepath
-stroke
-end grestore
-
-%	Termast
-gsave 10 dict begin
-557 172 35 18 ellipse_path
-stroke
-gsave 10 dict begin
-534 167 moveto
-(Termast)
-[7.2 6.24 4.8 10.8 6.24 5.28 3.84]
-xshow
-end grestore
-end grestore
-
-%	Termast -> Ast
-newpath 593 172 moveto
-630 172 689 172 727 172 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 727 176 moveto
-737 172 lineto
-727 169 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 727 176 moveto
-737 172 lineto
-727 169 lineto
-closepath
-stroke
-end grestore
-
-%	Coqast
-gsave 10 dict begin
-863 172 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-843 167 moveto
-(Coqast)
-[9.36 6.96 6.96 6.24 5.28 3.84]
-xshow
-end grestore
-end grestore
-
-%	Ast -> Coqast
-newpath 791 172 moveto
-800 172 810 172 820 172 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 820 176 moveto
-830 172 lineto
-820 169 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 820 176 moveto
-830 172 lineto
-820 169 lineto
-closepath
-stroke
-end grestore
-
-%	Tactic_printer
-gsave 10 dict begin
-53 126 52 18 ellipse_path
-stroke
-gsave 10 dict begin
-13 121 moveto
-(Tactic_printer)
-[7.44 6.24 6.24 3.84 3.84 6.24 6.96 6.96 4.8 3.84 6.96 3.84 6.24 4.56]
-xshow
-end grestore
-end grestore
-
-%	Pptactic
-gsave 10 dict begin
-178 126 36 18 ellipse_path
-stroke
-gsave 10 dict begin
-155 121 moveto
-(Pptactic)
-[7.68 6.96 4.08 6.24 6.24 3.84 3.84 6.24]
-xshow
-end grestore
-end grestore
-
-%	Tactic_printer -> Pptactic
-newpath 106 126 moveto
-114 126 123 126 132 126 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 132 130 moveto
-142 126 lineto
-132 123 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 132 130 moveto
-142 126 lineto
-132 123 lineto
-closepath
-stroke
-end grestore
-
-%	Printer
-gsave 10 dict begin
-289 72 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-269 67 moveto
-(Printer)
-[7.68 4.8 3.84 6.96 3.84 6.24 4.56]
-xshow
-end grestore
-end grestore
-
-%	Pptactic -> Printer
-newpath 204 113 moveto
-219 105 238 96 255 88 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 256 91 moveto
-264 84 lineto
-253 85 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 256 91 moveto
-264 84 lineto
-253 85 lineto
-closepath
-stroke
-end grestore
-
-%	Search
-gsave 10 dict begin
-178 72 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-159 67 moveto
-(Search)
-[7.68 6.24 6.24 4.56 6 6.96]
-xshow
-end grestore
-end grestore
-
-%	Search -> Printer
-newpath 210 72 moveto
-221 72 234 72 246 72 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 246 76 moveto
-256 72 lineto
-246 69 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 246 76 moveto
-256 72 lineto
-246 69 lineto
-closepath
-stroke
-end grestore
-
-%	Printer -> Termast
-newpath 316 62 moveto
-355 48 430 30 484 58 curveto
-518 77 538 117 548 144 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 545 146 moveto
-552 154 lineto
-552 143 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 545 146 moveto
-552 154 lineto
-552 143 lineto
-closepath
-stroke
-end grestore
-
-%	Esyntax
-gsave 10 dict begin
-557 226 36 18 ellipse_path
-stroke
-gsave 10 dict begin
-533 221 moveto
-(Esyntax)
-[8.4 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	Printer -> Esyntax
-newpath 322 71 moveto
-370 70 460 72 484 91 curveto
-489 95 516 193 520 197 curveto
-527 204 532 203 538 204 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 536 207 moveto
-547 208 lineto
-539 201 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 536 207 moveto
-547 208 lineto
-539 201 lineto
-closepath
-stroke
-end grestore
-
-%	Ppconstr
-gsave 10 dict begin
-424 388 37 18 ellipse_path
-stroke
-gsave 10 dict begin
-399 383 moveto
-(Ppconstr)
-[7.68 6.96 6.24 6.96 6.96 5.28 3.84 4.56]
-xshow
-end grestore
-end grestore
-
-%	Printer -> Ppconstr
-newpath 292 90 moveto
-300 147 329 319 364 361 curveto
-369 367 375 371 382 375 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 380 378 moveto
-391 379 lineto
-383 372 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 380 378 moveto
-391 379 lineto
-383 372 lineto
-closepath
-stroke
-end grestore
-
-%	Esyntax -> Extend
-newpath 594 226 moveto
-602 226 611 226 620 226 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 620 230 moveto
-630 226 lineto
-620 223 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 620 230 moveto
-630 226 lineto
-620 223 lineto
-closepath
-stroke
-end grestore
-
-%	Ppconstr -> Pcoq
-newpath 454 377 moveto
-464 373 475 368 484 361 curveto
-506 345 526 322 540 304 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 543 306 moveto
-546 296 lineto
-537 302 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 543 306 moveto
-546 296 lineto
-537 302 lineto
-closepath
-stroke
-end grestore
-
-%	Prettyp
-gsave 10 dict begin
-178 18 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-158 13 moveto
-(Prettyp)
-[7.68 4.56 6 3.84 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Prettyp -> Printer
-newpath 203 30 moveto
-218 38 238 47 255 55 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 254 58 moveto
-264 60 lineto
-257 52 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 254 58 moveto
-264 60 lineto
-257 52 lineto
-closepath
-stroke
-end grestore
-
-%	Printmod
-gsave 10 dict begin
-289 18 39 18 ellipse_path
-stroke
-gsave 10 dict begin
-263 13 moveto
-(Printmod)
-[7.68 4.8 3.84 6.96 3.84 10.8 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Prettyp -> Printmod
-newpath 211 18 moveto
-220 18 230 18 240 18 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 240 22 moveto
-250 18 lineto
-240 15 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 240 22 moveto
-250 18 lineto
-240 15 lineto
-closepath
-stroke
-end grestore
-
-%	G_zsyntax
-gsave 10 dict begin
-424 172 43 18 ellipse_path
-stroke
-gsave 10 dict begin
-393 167 moveto
-(G_zsyntax)
-[10.08 6.96 6.24 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	G_zsyntax -> Pcoq
-newpath 458 183 moveto
-467 188 476 193 484 199 curveto
-507 218 501 233 520 253 curveto
-523 256 526 259 530 261 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 528 264 moveto
-538 267 lineto
-532 258 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 528 264 moveto
-538 267 lineto
-532 258 lineto
-closepath
-stroke
-end grestore
-
-%	G_zsyntax -> Termast
-newpath 468 172 moveto
-482 172 497 172 511 172 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 511 176 moveto
-521 172 lineto
-511 169 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 511 176 moveto
-521 172 lineto
-511 169 lineto
-closepath
-stroke
-end grestore
-
-%	G_zsyntax -> Esyntax
-newpath 455 185 moveto
-474 193 499 203 520 211 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 518 214 moveto
-529 215 lineto
-521 208 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 518 214 moveto
-529 215 lineto
-521 208 lineto
-closepath
-stroke
-end grestore
-
-%	G_string_syntax
-gsave 10 dict begin
-424 280 59 18 ellipse_path
-stroke
-gsave 10 dict begin
-377 275 moveto
-(G_string_syntax)
-[10.08 6.96 5.28 3.84 4.8 3.84 6.96 6.96 6.96 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	G_string_syntax -> Pcoq
-newpath 484 280 moveto
-496 280 509 280 520 280 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 520 284 moveto
-530 280 lineto
-520 277 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 520 284 moveto
-530 280 lineto
-520 277 lineto
-closepath
-stroke
-end grestore
-
-%	G_string_syntax -> Esyntax
-newpath 460 266 moveto
-478 258 501 249 520 242 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 521 245 moveto
-529 238 lineto
-518 239 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 521 245 moveto
-529 238 lineto
-518 239 lineto
-closepath
-stroke
-end grestore
-
-%	G_rsyntax
-gsave 10 dict begin
-424 118 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-394 113 moveto
-(G_rsyntax)
-[10.08 6.96 4.56 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	G_rsyntax -> Pcoq
-newpath 459 128 moveto
-468 132 477 138 484 145 curveto
-518 183 491 213 520 253 curveto
-523 256 526 259 529 262 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 527 265 moveto
-537 268 lineto
-531 259 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 527 265 moveto
-537 268 lineto
-531 259 lineto
-closepath
-stroke
-end grestore
-
-%	G_rsyntax -> Termast
-newpath 455 131 moveto
-474 139 499 149 520 157 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 518 160 moveto
-529 161 lineto
-521 154 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 518 160 moveto
-529 161 lineto
-521 154 lineto
-closepath
-stroke
-end grestore
-
-%	G_rsyntax -> Esyntax
-newpath 457 129 moveto
-467 133 476 139 484 145 curveto
-507 164 501 179 520 199 curveto
-522 201 525 203 527 205 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 525 208 moveto
-535 212 lineto
-530 203 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 525 208 moveto
-535 212 lineto
-530 203 lineto
-closepath
-stroke
-end grestore
-
-%	G_natsyntax
-gsave 10 dict begin
-424 226 48 18 ellipse_path
-stroke
-gsave 10 dict begin
-388 221 moveto
-(G_natsyntax)
-[10.08 6.96 6.96 6.24 3.84 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	G_natsyntax -> Pcoq
-newpath 457 239 moveto
-478 248 504 259 525 266 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 523 269 moveto
-534 270 lineto
-526 263 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 523 269 moveto
-534 270 lineto
-526 263 lineto
-closepath
-stroke
-end grestore
-
-%	G_natsyntax -> Termast
-newpath 457 213 moveto
-476 205 500 195 520 187 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 521 190 moveto
-529 183 lineto
-518 184 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 521 190 moveto
-529 183 lineto
-518 184 lineto
-closepath
-stroke
-end grestore
-
-%	G_natsyntax -> Esyntax
-newpath 473 226 moveto
-485 226 498 226 510 226 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 510 230 moveto
-520 226 lineto
-510 223 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 510 230 moveto
-520 226 lineto
-510 223 lineto
-closepath
-stroke
-end grestore
-
-%	G_ascii_syntax
-gsave 10 dict begin
-424 334 56 18 ellipse_path
-stroke
-gsave 10 dict begin
-380 329 moveto
-(G_ascii_syntax)
-[10.08 6.96 6.24 5.52 6.24 3.84 3.84 6.96 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	G_ascii_syntax -> Pcoq
-newpath 459 320 moveto
-479 311 504 301 525 293 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 526 296 moveto
-534 289 lineto
-523 290 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 526 296 moveto
-534 289 lineto
-523 290 lineto
-closepath
-stroke
-end grestore
-
-%	G_ascii_syntax -> Esyntax
-newpath 462 321 moveto
-470 317 478 312 484 307 curveto
-507 288 501 273 520 253 curveto
-522 251 524 249 527 247 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 529 250 moveto
-535 241 lineto
-525 244 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 529 250 moveto
-535 241 lineto
-525 244 lineto
-closepath
-stroke
-end grestore
-
-%	Egrammar
-gsave 10 dict begin
-424 442 43 18 ellipse_path
-stroke
-gsave 10 dict begin
-394 437 moveto
-(Egrammar)
-[8.4 7.2 4.56 6.24 10.8 10.8 6.24 4.56]
-xshow
-end grestore
-end grestore
-
-%	Egrammar -> Pcoq
-newpath 458 431 moveto
-467 427 477 422 484 415 curveto
-516 385 537 337 548 308 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 551 309 moveto
-551 298 lineto
-545 307 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 551 309 moveto
-551 298 lineto
-545 307 lineto
-closepath
-stroke
-end grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/preamble.tex b/dev/ocamlweb-doc/preamble.tex
deleted file mode 100644
index 2cd21f02..00000000
--- a/dev/ocamlweb-doc/preamble.tex
+++ /dev/null
@@ -1,8 +0,0 @@
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{ocamlweb}
-\pagestyle{ocamlweb}
-\usepackage{fullpage}
-\usepackage{epsfig}
-\begin{document}
diff --git a/dev/ocamlweb-doc/pretyping.dep.ps b/dev/ocamlweb-doc/pretyping.dep.ps
deleted file mode 100644
index 02d1b8b5..00000000
--- a/dev/ocamlweb-doc/pretyping.dep.ps
+++ /dev/null
@@ -1,1259 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
-%%For: (herbelin) Hugo Herbelin
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: 35 35 577 146
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-
-EncodingVector
-  dup 306 /AE
-  dup 301 /Aacute
-  dup 302 /Acircumflex
-  dup 304 /Adieresis
-  dup 300 /Agrave
-  dup 305 /Aring
-  dup 303 /Atilde
-  dup 307 /Ccedilla
-  dup 311 /Eacute
-  dup 312 /Ecircumflex
-  dup 313 /Edieresis
-  dup 310 /Egrave
-  dup 315 /Iacute
-  dup 316 /Icircumflex
-  dup 317 /Idieresis
-  dup 314 /Igrave
-  dup 334 /Udieresis
-  dup 335 /Yacute
-  dup 376 /thorn
-  dup 337 /germandbls
-  dup 341 /aacute
-  dup 342 /acircumflex
-  dup 344 /adieresis
-  dup 346 /ae
-  dup 340 /agrave
-  dup 345 /aring
-  dup 347 /ccedilla
-  dup 351 /eacute
-  dup 352 /ecircumflex
-  dup 353 /edieresis
-  dup 350 /egrave
-  dup 355 /iacute
-  dup 356 /icircumflex
-  dup 357 /idieresis
-  dup 354 /igrave
-  dup 360 /dcroat
-  dup 361 /ntilde
-  dup 363 /oacute
-  dup 364 /ocircumflex
-  dup 366 /odieresis
-  dup 362 /ograve
-  dup 365 /otilde
-  dup 370 /oslash
-  dup 372 /uacute
-  dup 373 /ucircumflex
-  dup 374 /udieresis
-  dup 371 /ugrave
-  dup 375 /yacute
-  dup 377 /ydieresis  
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-	dup 1 exch div /InvScaleFactor exch def
-	dup scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-%%Page: 1 1
-%%PageBoundingBox: 36 36 577 146
-%%PageOrientation: Portrait
-gsave
-35 35 542 111 boxprim clip newpath
-36 36 translate
-0 0 1 beginpage
-0.3600 set_scale
-0 0 translate 0 rotate
-0.000 0.000 0.000 graphcolor
-14.00 /Times-Roman set_font
-
-%	Unification
-gsave 10 dict begin
-610 118 45 18 ellipse_path
-stroke
-gsave 10 dict begin
-577 113 moveto
-(Unification)
-[9.6 6.96 3.84 4.8 3.84 6.24 6.24 3.84 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Evarutil
-gsave 10 dict begin
-728 72 36 18 ellipse_path
-stroke
-gsave 10 dict begin
-705 67 moveto
-(Evarutil)
-[8.4 6.72 6.24 4.8 6.96 3.84 3.84 3.84]
-xshow
-end grestore
-end grestore
-
-%	Unification -> Evarutil
-newpath 643 105 moveto
-657 99 674 93 689 87 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 691 90 moveto
-699 83 lineto
-688 83 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 691 90 moveto
-699 83 lineto
-688 83 lineto
-closepath
-stroke
-end grestore
-
-%	Pattern
-gsave 10 dict begin
-728 210 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-708 205 moveto
-(Pattern)
-[7.44 6.24 3.84 3.84 6.24 4.8 6.96]
-xshow
-end grestore
-end grestore
-
-%	Unification -> Pattern
-newpath 631 134 moveto
-650 150 680 173 701 189 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 699 192 moveto
-709 195 lineto
-703 186 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 699 192 moveto
-709 195 lineto
-703 186 lineto
-closepath
-stroke
-end grestore
-
-%	Retyping
-gsave 10 dict begin
-839 118 38 18 ellipse_path
-stroke
-gsave 10 dict begin
-813 113 moveto
-(Retyping)
-[9.12 6 3.84 6.96 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Unification -> Retyping
-newpath 656 118 moveto
-695 118 750 118 790 118 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 790 122 moveto
-800 118 lineto
-790 115 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 790 122 moveto
-800 118 lineto
-790 115 lineto
-closepath
-stroke
-end grestore
-
-%	Typing
-gsave 10 dict begin
-839 64 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-819 59 moveto
-(Typing)
-[6.96 6.96 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Evarutil -> Typing
-newpath 764 69 moveto
-775 68 786 67 797 67 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 797 70 moveto
-807 66 lineto
-797 64 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 797 70 moveto
-807 66 lineto
-797 64 lineto
-closepath
-stroke
-end grestore
-
-%	Rawterm
-gsave 10 dict begin
-1109 110 39 18 ellipse_path
-stroke
-gsave 10 dict begin
-1083 105 moveto
-(Rawterm)
-[9.36 5.76 10.08 3.84 6.24 4.8 10.8]
-xshow
-end grestore
-end grestore
-
-%	Pattern -> Rawterm
-newpath 759 216 moveto
-816 226 939 239 1024 191 curveto
-1049 176 1038 155 1060 138 curveto
-1069 131 1077 130 1084 129 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1085 132 moveto
-1094 127 lineto
-1084 126 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1085 132 moveto
-1094 127 lineto
-1084 126 lineto
-closepath
-stroke
-end grestore
-
-%	Inductiveops
-gsave 10 dict begin
-1109 164 49 18 ellipse_path
-stroke
-gsave 10 dict begin
-1073 159 moveto
-(Inductiveops)
-[4.56 6.96 6.96 6.96 6.24 3.84 3.84 6.48 6.24 6.96 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Retyping -> Inductiveops
-newpath 878 120 moveto
-915 122 974 126 1024 137 curveto
-1037 139 1051 144 1064 148 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1063 151 moveto
-1074 151 lineto
-1065 145 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1063 151 moveto
-1074 151 lineto
-1065 145 lineto
-closepath
-stroke
-end grestore
-
-%	Pretype_errors
-gsave 10 dict begin
-969 72 54 18 ellipse_path
-stroke
-gsave 10 dict begin
-927 67 moveto
-(Pretype_errors)
-[7.68 4.56 6 3.84 6.96 6.96 6.24 6.96 6.24 5.04 4.56 6.96 4.56 5.52]
-xshow
-end grestore
-end grestore
-
-%	Typing -> Pretype_errors
-newpath 871 66 moveto
-881 67 893 68 905 68 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 905 71 moveto
-915 69 lineto
-905 65 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 905 71 moveto
-915 69 lineto
-905 65 lineto
-closepath
-stroke
-end grestore
-
-%	Pretype_errors -> Inductiveops
-newpath 998 87 moveto
-1007 92 1016 98 1024 104 curveto
-1042 116 1043 124 1060 137 curveto
-1063 139 1067 142 1071 144 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1070 147 moveto
-1080 149 lineto
-1073 141 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1070 147 moveto
-1080 149 lineto
-1073 141 lineto
-closepath
-stroke
-end grestore
-
-%	Pretype_errors -> Rawterm
-newpath 1011 84 moveto
-1029 88 1048 94 1065 98 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1064 101 moveto
-1075 101 lineto
-1066 95 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1064 101 moveto
-1075 101 lineto
-1066 95 lineto
-closepath
-stroke
-end grestore
-
-%	Tacred
-gsave 10 dict begin
-728 18 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-709 13 moveto
-(Tacred)
-[7.44 6.24 6.24 4.56 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	Tacred -> Retyping
-newpath 748 32 moveto
-754 36 759 41 764 45 curveto
-783 63 782 73 800 91 curveto
-802 93 805 95 808 97 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 806 100 moveto
-816 103 lineto
-810 94 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 806 100 moveto
-816 103 lineto
-810 94 lineto
-closepath
-stroke
-end grestore
-
-%	Tacred -> Typing
-newpath 754 29 moveto
-769 35 787 43 803 49 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 802 53 moveto
-813 53 lineto
-805 46 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 802 53 moveto
-813 53 lineto
-805 46 lineto
-closepath
-stroke
-end grestore
-
-%	Cbv
-gsave 10 dict begin
-1246 41 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-1234 36 moveto
-(Cbv)
-[9.36 6.48 6.96]
-xshow
-end grestore
-end grestore
-
-%	Tacred -> Cbv
-newpath 760 19 moveto
-852 23 1111 35 1209 40 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1209 44 moveto
-1219 40 lineto
-1209 37 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1209 44 moveto
-1219 40 lineto
-1209 37 lineto
-closepath
-stroke
-end grestore
-
-%	Evd
-gsave 10 dict begin
-1361 110 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-1349 105 moveto
-(Evd)
-[8.4 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Cbv -> Evd
-newpath 1266 53 moveto
-1284 64 1312 80 1332 93 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1331 96 moveto
-1341 98 lineto
-1334 90 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1331 96 moveto
-1341 98 lineto
-1334 90 lineto
-closepath
-stroke
-end grestore
-
-%	Reductionops
-gsave 10 dict begin
-1246 164 51 18 ellipse_path
-stroke
-gsave 10 dict begin
-1207 159 moveto
-(Reductionops)
-[9.12 6.24 6.96 6.96 6.24 3.84 3.84 6.96 6.96 6.96 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Inductiveops -> Reductionops
-newpath 1158 164 moveto
-1167 164 1175 164 1184 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1184 168 moveto
-1194 164 lineto
-1184 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1184 168 moveto
-1194 164 lineto
-1184 161 lineto
-closepath
-stroke
-end grestore
-
-%	Reductionops -> Evd
-newpath 1277 150 moveto
-1294 142 1313 133 1330 125 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1331 128 moveto
-1339 121 lineto
-1328 122 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1331 128 moveto
-1339 121 lineto
-1328 122 lineto
-closepath
-stroke
-end grestore
-
-%	Termops
-gsave 10 dict begin
-1462 110 37 18 ellipse_path
-stroke
-gsave 10 dict begin
-1437 105 moveto
-(Termops)
-[7.2 6.24 4.8 10.8 6.96 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Evd -> Termops
-newpath 1388 110 moveto
-1396 110 1405 110 1414 110 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1414 114 moveto
-1424 110 lineto
-1414 107 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1414 114 moveto
-1424 110 lineto
-1414 107 lineto
-closepath
-stroke
-end grestore
-
-%	Recordops
-gsave 10 dict begin
-485 24 43 18 ellipse_path
-stroke
-gsave 10 dict begin
-455 19 moveto
-(Recordops)
-[9.12 6.24 6.24 6.96 4.32 6.96 6.96 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Classops
-gsave 10 dict begin
-610 20 38 18 ellipse_path
-stroke
-gsave 10 dict begin
-584 15 moveto
-(Classops)
-[9.36 3.84 6.24 5.52 5.52 6.96 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Recordops -> Classops
-newpath 528 23 moveto
-538 22 550 22 561 22 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 561 25 moveto
-571 21 lineto
-561 19 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 561 25 moveto
-571 21 lineto
-561 19 lineto
-closepath
-stroke
-end grestore
-
-%	Classops -> Tacred
-newpath 649 19 moveto
-661 19 674 19 686 19 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 686 23 moveto
-696 19 lineto
-686 16 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 686 23 moveto
-696 19 lineto
-686 16 lineto
-closepath
-stroke
-end grestore
-
-%	Rawterm -> Evd
-newpath 1148 110 moveto
-1196 110 1277 110 1324 110 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1324 114 moveto
-1334 110 lineto
-1324 107 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1324 114 moveto
-1334 110 lineto
-1324 107 lineto
-closepath
-stroke
-end grestore
-
-%	Pretyping
-gsave 10 dict begin
-40 183 40 18 ellipse_path
-stroke
-gsave 10 dict begin
-13 178 moveto
-(Pretyping)
-[7.68 4.56 6 3.84 6.96 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Pretyping -> Pattern
-newpath 78 189 moveto
-121 194 191 202 251 202 curveto
-251 202 251 202 485 202 curveto
-556 202 636 205 685 208 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 685 212 moveto
-695 208 lineto
-685 205 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 685 212 moveto
-695 208 lineto
-685 205 lineto
-closepath
-stroke
-end grestore
-
-%	Cases
-gsave 10 dict begin
-146 64 30 18 ellipse_path
-stroke
-gsave 10 dict begin
-129 59 moveto
-(Cases)
-[9.36 6.24 5.52 6.24 5.52]
-xshow
-end grestore
-end grestore
-
-%	Pretyping -> Cases
-newpath 53 166 moveto
-68 147 93 115 116 91 curveto
-118 89 119 88 121 86 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 124 88 moveto
-129 79 lineto
-119 83 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 124 88 moveto
-129 79 lineto
-119 83 lineto
-closepath
-stroke
-end grestore
-
-%	Detyping
-gsave 10 dict begin
-969 164 39 18 ellipse_path
-stroke
-gsave 10 dict begin
-942 159 moveto
-(Detyping)
-[10.08 6 3.84 6.96 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Pretyping -> Detyping
-newpath 78 177 moveto
-121 172 191 164 251 164 curveto
-251 164 251 164 728 164 curveto
-794 164 870 164 919 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 919 168 moveto
-929 164 lineto
-919 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 919 168 moveto
-929 164 lineto
-919 161 lineto
-closepath
-stroke
-end grestore
-
-%	Indrec
-gsave 10 dict begin
-251 271 31 18 ellipse_path
-stroke
-gsave 10 dict begin
-233 266 moveto
-(Indrec)
-[4.56 6.96 6.96 4.56 6.24 6.24]
-xshow
-end grestore
-end grestore
-
-%	Pretyping -> Indrec
-newpath 69 195 moveto
-83 202 101 209 116 216 curveto
-150 230 188 246 216 257 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 214 260 moveto
-225 261 lineto
-217 254 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 214 260 moveto
-225 261 lineto
-217 254 lineto
-closepath
-stroke
-end grestore
-
-%	Coercion
-gsave 10 dict begin
-251 67 39 18 ellipse_path
-stroke
-gsave 10 dict begin
-225 62 moveto
-(Coercion)
-[9.36 6.96 6.24 4.56 6.24 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Cases -> Coercion
-newpath 176 65 moveto
-184 65 193 66 202 66 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 202 70 moveto
-212 66 lineto
-202 63 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 202 70 moveto
-212 66 lineto
-202 63 lineto
-closepath
-stroke
-end grestore
-
-%	Detyping -> Inductiveops
-newpath 1009 164 moveto
-1022 164 1036 164 1050 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1050 168 moveto
-1060 164 lineto
-1050 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1050 168 moveto
-1060 164 lineto
-1050 161 lineto
-closepath
-stroke
-end grestore
-
-%	Detyping -> Rawterm
-newpath 999 152 moveto
-1020 144 1047 133 1069 125 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1070 128 moveto
-1079 122 lineto
-1068 122 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1070 128 moveto
-1079 122 lineto
-1068 122 lineto
-closepath
-stroke
-end grestore
-
-%	Indrec -> Inductiveops
-newpath 281 276 moveto
-325 283 412 294 485 294 curveto
-485 294 485 294 839 294 curveto
-937 294 1036 225 1082 188 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1085 190 moveto
-1090 181 lineto
-1080 185 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1085 190 moveto
-1090 181 lineto
-1080 185 lineto
-closepath
-stroke
-end grestore
-
-%	Matching
-gsave 10 dict begin
-610 248 40 18 ellipse_path
-stroke
-gsave 10 dict begin
-582 243 moveto
-(Matching)
-[12.48 6.24 3.84 6 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Matching -> Pattern
-newpath 643 237 moveto
-658 232 675 227 689 222 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 690 225 moveto
-699 219 lineto
-688 219 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 690 225 moveto
-699 219 lineto
-688 219 lineto
-closepath
-stroke
-end grestore
-
-%	Matching -> Reductionops
-newpath 650 250 moveto
-696 253 773 256 839 256 curveto
-839 256 839 256 969 256 curveto
-1059 256 1159 212 1210 184 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1212 187 moveto
-1219 179 lineto
-1209 181 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1212 187 moveto
-1219 179 lineto
-1209 181 lineto
-closepath
-stroke
-end grestore
-
-%	Evarconv
-gsave 10 dict begin
-366 67 40 18 ellipse_path
-stroke
-gsave 10 dict begin
-339 62 moveto
-(Evarconv)
-[8.4 6.72 6.24 4.56 6.24 6.96 6.48 6.96]
-xshow
-end grestore
-end grestore
-
-%	Evarconv -> Evarutil
-newpath 406 68 moveto
-474 69 610 71 682 72 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 682 76 moveto
-692 72 lineto
-682 69 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 682 76 moveto
-692 72 lineto
-682 69 lineto
-closepath
-stroke
-end grestore
-
-%	Evarconv -> Recordops
-newpath 397 56 moveto
-411 51 428 45 442 39 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 443 42 moveto
-452 36 lineto
-441 36 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 443 42 moveto
-452 36 lineto
-441 36 lineto
-closepath
-stroke
-end grestore
-
-%	Coercion -> Evarconv
-newpath 290 67 moveto
-299 67 307 67 316 67 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 316 71 moveto
-326 67 lineto
-316 64 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 316 71 moveto
-326 67 lineto
-316 64 lineto
-closepath
-stroke
-end grestore
-
-%	Clenv
-gsave 10 dict begin
-146 118 30 18 ellipse_path
-stroke
-gsave 10 dict begin
-129 113 moveto
-(Clenv)
-[9.36 3.84 6.24 6.48 6.96]
-xshow
-end grestore
-end grestore
-
-%	Clenv -> Unification
-newpath 176 118 moveto
-252 118 455 118 554 118 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 554 122 moveto
-564 118 lineto
-554 115 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 554 122 moveto
-564 118 lineto
-554 115 lineto
-closepath
-stroke
-end grestore
-
-%	Clenv -> Coercion
-newpath 170 107 moveto
-183 100 200 93 215 85 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 217 88 moveto
-224 80 lineto
-214 82 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 217 88 moveto
-224 80 lineto
-214 82 lineto
-closepath
-stroke
-end grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/proofs.dep.ps b/dev/ocamlweb-doc/proofs.dep.ps
deleted file mode 100644
index 4dd045ce..00000000
--- a/dev/ocamlweb-doc/proofs.dep.ps
+++ /dev/null
@@ -1,649 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: Graphviz version 2.12 (Tue Oct 23 13:46:12 UTC 2007)
-%%For: (notin) Jean-Marc Notin,,,
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: (atend)
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-EncodingVector 45 /hyphen put
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-       dup 1 exch div /InvScaleFactor exch def
-       scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-setupLatin1
-%%Page: 1 1
-%%PageBoundingBox: 36 36 576 753
-%%PageOrientation: Landscape
-gsave
-36 36 576 753 boxprim clip newpath
-0 0 1 beginpage
-0.870968 0.870968 set_scale 90 rotate 45.3333 -657.333 translate
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 616 lineto
-819 616 lineto
-819 -4 lineto
-closepath fill
-0.870968 setlinewidth
-0.000 0.000 1.000 graphcolor
-newpath -4 -4 moveto
--4 616 lineto
-819 616 lineto
-819 -4 lineto
-closepath stroke
-% Clenvtac
-gsave
-0.502 1.000 0.820 nodecolor
-451 522 37.1753 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-451 522 37.1753 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-451 517 moveto 49 -0.5 (Clenvtac) alignedtext
-grestore
-% Evar_refiner
-gsave
-0.502 1.000 0.820 nodecolor
-439 450 49.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 450 49.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 445 moveto 72 -0.5 (Evar_refiner) alignedtext
-grestore
-% Clenvtac->Evar_refiner
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 448 504 moveto
-447 496 445 487 444 478 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 447.393 477.119 moveto
-442 468 lineto
-440.529 478.492 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 447.393 477.119 moveto
-442 468 lineto
-440.529 478.492 lineto
-closepath stroke
-grestore
-% Tacmach
-gsave
-0.502 1.000 0.820 nodecolor
-711 450 38.1754 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-711 450 38.1754 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-711 445 moveto 51 -0.5 (Tacmach) alignedtext
-grestore
-% Clenvtac->Tacmach
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 483 513 moveto
-530 500 616 476 668 462 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 669.427 465.226 moveto
-678 459 lineto
-667.416 458.521 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 669.427 465.226 moveto
-678 459 lineto
-667.416 458.521 lineto
-closepath stroke
-grestore
-% Refiner
-gsave
-0.502 1.000 0.820 nodecolor
-439 378 34.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 378 34.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 373 moveto 42 -0.5 (Refiner) alignedtext
-grestore
-% Evar_refiner->Refiner
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 432 moveto
-439 424 439 415 439 406 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 406 moveto
-439 396 lineto
-435.5 406 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 406 moveto
-439 396 lineto
-435.5 406 lineto
-closepath stroke
-grestore
-% Tacmach->Refiner
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 678 441 moveto
-628 428 533 403 480 389 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 480.584 385.521 moveto
-470 386 lineto
-478.573 392.226 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 480.584 385.521 moveto
-470 386 lineto
-478.573 392.226 lineto
-closepath stroke
-grestore
-% Redexpr
-gsave
-0.502 1.000 0.820 nodecolor
-711 378 36.1752 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-711 378 36.1752 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-711 373 moveto 47 -0.5 (Redexpr) alignedtext
-grestore
-% Tacmach->Redexpr
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 711 432 moveto
-711 424 711 415 711 406 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 714.5 406 moveto
-711 396 lineto
-707.5 406 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 714.5 406 moveto
-711 396 lineto
-707.5 406 lineto
-closepath stroke
-grestore
-% Decl_mode
-gsave
-0.502 1.000 0.820 nodecolor
-698 594 45.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-698 594 45.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-698 589 moveto 64 -0.5 (Decl_mode) alignedtext
-grestore
-% Pfedit
-gsave
-0.502 1.000 0.820 nodecolor
-698 522 30.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-698 522 30.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-698 517 moveto 34 -0.5 (Pfedit) alignedtext
-grestore
-% Decl_mode->Pfedit
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 698 576 moveto
-698 568 698 559 698 550 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 701.5 550 moveto
-698 540 lineto
-694.5 550 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 701.5 550 moveto
-698 540 lineto
-694.5 550 lineto
-closepath stroke
-grestore
-% Pfedit->Evar_refiner
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 671 514 moveto
-628 503 543 479 488 464 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 488.584 460.521 moveto
-478 461 lineto
-486.573 467.226 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 488.584 460.521 moveto
-478 461 lineto
-486.573 467.226 lineto
-closepath stroke
-grestore
-% Pfedit->Tacmach
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 701 504 moveto
-702 496 704 487 706 478 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 709.471 478.492 moveto
-708 468 lineto
-702.607 477.119 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 709.471 478.492 moveto
-708 468 lineto
-702.607 477.119 lineto
-closepath stroke
-grestore
-% Logic
-gsave
-0.502 1.000 0.820 nodecolor
-439 306 29.1747 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 306 29.1747 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 301 moveto 33 -0.5 (Logic) alignedtext
-grestore
-% Refiner->Logic
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 360 moveto
-439 352 439 343 439 334 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 334 moveto
-439 324 lineto
-435.5 334 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 334 moveto
-439 324 lineto
-435.5 334 lineto
-closepath stroke
-grestore
-% Proof_trees
-gsave
-0.502 1.000 0.820 nodecolor
-439 234 45.1757 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 234 45.1757 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 229 moveto 65 -0.5 (Proof_trees) alignedtext
-grestore
-% Logic->Proof_trees
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 288 moveto
-439 280 439 271 439 262 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 262 moveto
-439 252 lineto
-435.5 262 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 262 moveto
-439 252 lineto
-435.5 262 lineto
-closepath stroke
-grestore
-% Proof_type
-gsave
-0.502 1.000 0.820 nodecolor
-439 162 44.1757 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 162 44.1757 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 157 moveto 63 -0.5 (Proof_type) alignedtext
-grestore
-% Proof_trees->Proof_type
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 216 moveto
-439 208 439 199 439 190 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 190 moveto
-439 180 lineto
-435.5 190 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 190 moveto
-439 180 lineto
-435.5 190 lineto
-closepath stroke
-grestore
-% Decl_expr
-gsave
-0.502 1.000 0.820 nodecolor
-439 90 42.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 90 42.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 85 moveto 58 -0.5 (Decl_expr) alignedtext
-grestore
-% Proof_type->Decl_expr
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 144 moveto
-439 136 439 127 439 118 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 118 moveto
-439 108 lineto
-435.5 118 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 118 moveto
-439 108 lineto
-435.5 118 lineto
-closepath stroke
-grestore
-% Tacexpr
-gsave
-0.502 1.000 0.820 nodecolor
-439 18 36.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-439 18 36.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-439 13 moveto 46 -0.5 (Tacexpr) alignedtext
-grestore
-% Decl_expr->Tacexpr
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 439 72 moveto
-439 64 439 55 439 46 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 442.5 46 moveto
-439 36 lineto
-435.5 46 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 442.5 46 moveto
-439 36 lineto
-435.5 46 lineto
-closepath stroke
-grestore
-% Tactic_debug
-gsave
-0.502 1.000 0.820 nodecolor
-133 450 51.1777 18 ellipse_path fill
-0.870968 setlinewidth
-filled
-0.502 1.000 0.820 nodecolor
-133 450 51.1777 18 ellipse_path stroke
-0.000 0.000 0.000 nodecolor
-14.00 /Times-Roman set_font
-133 445 moveto 76 -0.5 (Tactic_debug) alignedtext
-grestore
-% Tactic_debug->Refiner
-gsave
-0.870968 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 176 440 moveto
-234 426 339 401 398 387 curveto
-stroke
-0.000 0.000 0.000 edgecolor
-newpath 398.881 390.393 moveto
-408 385 lineto
-397.508 383.529 lineto
-closepath fill
-0.870968 setlinewidth
-solid
-0.000 0.000 0.000 edgecolor
-newpath 398.881 390.393 moveto
-408 385 lineto
-397.508 383.529 lineto
-closepath stroke
-grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-%%BoundingBox: 36 36 576 753
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/syntax.mly b/dev/ocamlweb-doc/syntax.mly
deleted file mode 100644
index bfc7d5cc..00000000
--- a/dev/ocamlweb-doc/syntax.mly
+++ /dev/null
@@ -1,224 +0,0 @@
-%{
-open Ast
-open Parse
-%}
-
-%token <string> META INT IDENT
-%token <string> OPER
-%token LPAR RPAR BAR COMMA COLON BANG FUN DOT RARROW LET COLONEQ IN IF
-%token THEN ELSE EVAL AT FOR PROP SET TYPE WILDCARD FIX
-%token COFIX MATCH WITH END AND LBRACE RBRACE STRUCT AS SIMPL PERCENT
-%token EOF
-
-%start main
-%type <Ast.constr_ast> main
-
-%start constr
-%type <Ast.constr_ast> constr
-
-%start simple_constr
-%type <Ast.constr_ast> simple_constr
-
-%%
-
-main:
-          constr EOF { $1 }
-;
-
-
-paren_constr:
-          constr COMMA paren_constr  { Pair($1,$3) }
-        | constr                     { $1 }
-;
-
-constr:
-          binder_constr  { $1 }
-        | oper_constr    { close_stack $1 }
-;
-
-binder_constr:
-          BANG ne_binders DOT constr              { Prod($2, $4) }
-        | FUN ne_binders type_cstr RARROW constr  { Lambda($2,mk_cast $5 $3) }
-        | LET IDENT binders type_cstr COLONEQ constr IN constr
-            { Let($2,mk_lambda $3 (mk_cast $6 $4),$8) }
-        | LET LPAR comma_binders RPAR COLONEQ constr IN constr
-            { LetCase($3,$6,$8) }
-        | IF constr THEN constr ELSE constr       { IfCase($2,$4,$6) }
-        | fix_constr                              { $1 }
-        | EVAL rfun IN constr                     { Eval($2,$4) }
-;
-
-comma_binders:
-          ne_comma_binders  { $1 }
-        |                   { [] }
-;
-
-ne_comma_binders:
-          binder COMMA ne_comma_binders  { $1 :: $3 }
-        | binder                         { [$1] }
-;
-
-rfun:
-          SIMPL  { Simpl }
-;
-
-
-/* 2 Conflits shift/reduce */
-oper_constr:
-          oper_constr oper appl_constr
-            { parse_term $3 (parse_oper $2 $1) }
-        | oper_constr oper binder_constr
-            { parse_term $3 (parse_oper $2 $1) }
-        | oper_constr oper  { parse_oper $2 $1 }
-        |                   { empty }
-        | appl_constr       { parse_term $1 empty }
-;
-
-oper:
-          OPER {$1}
-        | COLON {":"}
-;
-
-appl_constr:
-          simple_constr ne_appl_args  { Appl($1,$2) }
-        | AT global simple_constrs    { ApplExpl($2,$3) }
-        | simple_constr               { $1 }
-;
-
-appl_arg:
-          AT INT COLONEQ simple_constr  { (Some $2,$4) }
-        | simple_constr                 { (None,$1) }
-;
-
-ne_appl_args:
-          appl_arg               { [$1] }
-        | appl_arg ne_appl_args  { $1::$2 }
-;
-
-simple_constr:
-          atomic_constr                           { $1 }
-        | match_constr                            { $1 }
-        | LPAR paren_constr RPAR                  { $2 }
-        | simple_constr PERCENT IDENT { Scope($3,$1) }
-;
-
-simple_constrs:
-          simple_constr simple_constrs  { $1::$2 }
-        |                               { [] }
-;
-
-atomic_constr:
-          global    { Qualid $1 }
-        | PROP      { Prop }
-        | SET       { Set }
-        | TYPE      { Type }
-        | INT       { Int $1 }
-        | WILDCARD  { Hole }
-        | META      { Meta $1 }
-;
-
-global:
-          IDENT DOT global  { $1 :: $3 }
-        | IDENT             { [$1] }
-;
-
-/* Conflit normal */
-fix_constr:
-          fix_kw fix_decl
-            { let (id,_,_,_,_ as fx) = $2 in Fixp($1,[fx],id) }
-        | fix_kw fix_decl fix_decls FOR IDENT  { Fixp($1, $2::$3, $5) }
-;
-
-fix_kw: FIX {Fix} | COFIX {CoFix}
-;
-
-fix_decl:
-          IDENT binders type_cstr annot COLONEQ constr  { ($1,$2,$3,$4,$6) }
-;
-
-fix_decls:
-          AND fix_decl fix_decls  { $2::$3 }
-        | AND fix_decl            { [$2] }
-;
-
-annot:
-          LBRACE STRUCT IDENT RBRACE  { Some $3 }
-        |                             { None }
-;
-
-match_constr:
-          MATCH case_items case_type WITH branches END  { Match($2,$3,$5) }
-;
-
-case_items:
-          case_item                   { [$1] }
-        | case_item COMMA case_items  { $1::$3 }
-;
-
-case_item:
-          constr pred_pattern { ($1,$2) }
-;
-
-case_type:
-          RARROW constr  { Some $2 }
-        |                { None }
-;
-
-pred_pattern:
-          AS IDENT COLON constr  { (Some $2, Some $4) }
-        | AS IDENT               { (Some $2, None) }
-        | COLON constr           { (None, Some $2) }
-        |                        { (None,None) }
-;
-
-branches:
-          BAR branch_list  { $2 }
-        | branch_list      { $1 }
-        |                  { [] }
-;
-
-branch_list:
-          patterns RARROW constr                  { [$1, $3] }
-        | patterns RARROW constr BAR branch_list  { ($1,$3)::$5 }
-;
-
-patterns:
-          pattern                 { [$1] }
-        | pattern COMMA patterns  { $1::$3 }
-;
-
-pattern:
-          pattern AS IDENT       { PatAs($1,$3) }
-        | pattern COLON constr   { PatType($1,$3) }
-        | IDENT simple_patterns  { PatConstr($1,$2) }
-        | simple_pattern         { $1 }
-;
-
-simple_pattern:
-          IDENT              { PatVar $1 }
-        | LPAR pattern RPAR  { $2 }
-;
-
-simple_patterns:
-          simple_pattern                  { [$1] }
-        | simple_pattern simple_patterns  { $1::$2 }
-;
-
-binder:
-          IDENT                 { ($1,Hole) }
-        | LPAR IDENT type_cstr RPAR  { ($2,$3) }
-;
-
-binders:
-          ne_binders  { $1 }
-        |             { [] }
-
-ne_binders:
-          binder             { [$1] }
-        | binder ne_binders  { $1::$2 }
-;
-
-type_cstr:
-          COLON constr  { $2 }
-        |               { Hole }
-;
diff --git a/dev/ocamlweb-doc/tactics.dep.ps b/dev/ocamlweb-doc/tactics.dep.ps
deleted file mode 100644
index f4de22b7..00000000
--- a/dev/ocamlweb-doc/tactics.dep.ps
+++ /dev/null
@@ -1,991 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
-%%For: (herbelin) Hugo Herbelin
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: 35 35 577 165
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-
-EncodingVector
-  dup 306 /AE
-  dup 301 /Aacute
-  dup 302 /Acircumflex
-  dup 304 /Adieresis
-  dup 300 /Agrave
-  dup 305 /Aring
-  dup 303 /Atilde
-  dup 307 /Ccedilla
-  dup 311 /Eacute
-  dup 312 /Ecircumflex
-  dup 313 /Edieresis
-  dup 310 /Egrave
-  dup 315 /Iacute
-  dup 316 /Icircumflex
-  dup 317 /Idieresis
-  dup 314 /Igrave
-  dup 334 /Udieresis
-  dup 335 /Yacute
-  dup 376 /thorn
-  dup 337 /germandbls
-  dup 341 /aacute
-  dup 342 /acircumflex
-  dup 344 /adieresis
-  dup 346 /ae
-  dup 340 /agrave
-  dup 345 /aring
-  dup 347 /ccedilla
-  dup 351 /eacute
-  dup 352 /ecircumflex
-  dup 353 /edieresis
-  dup 350 /egrave
-  dup 355 /iacute
-  dup 356 /icircumflex
-  dup 357 /idieresis
-  dup 354 /igrave
-  dup 360 /dcroat
-  dup 361 /ntilde
-  dup 363 /oacute
-  dup 364 /ocircumflex
-  dup 366 /odieresis
-  dup 362 /ograve
-  dup 365 /otilde
-  dup 370 /oslash
-  dup 372 /uacute
-  dup 373 /ucircumflex
-  dup 374 /udieresis
-  dup 371 /ugrave
-  dup 375 /yacute
-  dup 377 /ydieresis  
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-	dup 1 exch div /InvScaleFactor exch def
-	dup scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-%%Page: 1 1
-%%PageBoundingBox: 36 36 577 165
-%%PageOrientation: Portrait
-gsave
-35 35 542 130 boxprim clip newpath
-36 36 translate
-0 0 1 beginpage
-0.4696 set_scale
-0 0 translate 0 rotate
-0.000 0.000 0.000 graphcolor
-14.00 /Times-Roman set_font
-
-%	Extraargs
-gsave 10 dict begin
-483 110 40 18 ellipse_path
-stroke
-gsave 10 dict begin
-455 105 moveto
-(Extraargs)
-[8.4 6.96 3.84 4.56 6.24 6.24 4.32 6.96 5.52]
-xshow
-end grestore
-end grestore
-
-%	Setoid_replace
-gsave 10 dict begin
-615 64 54 18 ellipse_path
-stroke
-gsave 10 dict begin
-573 59 moveto
-(Setoid_replace)
-[7.68 6 3.84 6.96 3.84 6.96 6.96 4.56 6.24 6.96 3.84 6.24 6.24 6.24]
-xshow
-end grestore
-end grestore
-
-%	Extraargs -> Setoid_replace
-newpath 515 99 moveto
-531 93 550 87 567 81 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 569 84 moveto
-577 77 lineto
-566 77 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 569 84 moveto
-577 77 lineto
-566 77 lineto
-closepath
-stroke
-end grestore
-
-%	Tactics
-gsave 10 dict begin
-884 110 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-864 105 moveto
-(Tactics)
-[7.44 6.24 6.24 3.84 3.84 6.24 5.52]
-xshow
-end grestore
-end grestore
-
-%	Setoid_replace -> Tactics
-newpath 669 66 moveto
-709 68 764 72 810 83 curveto
-823 85 837 90 848 94 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 847 98 moveto
-858 98 lineto
-850 91 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 847 98 moveto
-858 98 lineto
-850 91 lineto
-closepath
-stroke
-end grestore
-
-%	Termdn
-gsave 10 dict begin
-998 256 35 18 ellipse_path
-stroke
-gsave 10 dict begin
-976 251 moveto
-(Termdn)
-[7.2 6.24 4.8 10.8 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Dn
-gsave 10 dict begin
-1112 256 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-1102 251 moveto
-(Dn)
-[10.08 6.96]
-xshow
-end grestore
-end grestore
-
-%	Termdn -> Dn
-newpath 1033 256 moveto
-1047 256 1061 256 1075 256 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1075 260 moveto
-1085 256 lineto
-1075 253 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1075 260 moveto
-1085 256 lineto
-1075 253 lineto
-closepath
-stroke
-end grestore
-
-%	Hipattern
-gsave 10 dict begin
-998 110 40 18 ellipse_path
-stroke
-gsave 10 dict begin
-971 105 moveto
-(Hipattern)
-[10.08 3.84 6.96 6.24 3.84 3.84 6.24 4.8 6.96]
-xshow
-end grestore
-end grestore
-
-%	Tactics -> Hipattern
-newpath 917 110 moveto
-927 110 938 110 948 110 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 948 114 moveto
-958 110 lineto
-948 107 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 948 114 moveto
-958 110 lineto
-948 107 lineto
-closepath
-stroke
-end grestore
-
-%	Tacticals
-gsave 10 dict begin
-1112 110 38 18 ellipse_path
-stroke
-gsave 10 dict begin
-1087 105 moveto
-(Tacticals)
-[7.44 6.24 6.24 3.84 3.84 6.24 6.24 3.84 5.52]
-xshow
-end grestore
-end grestore
-
-%	Hipattern -> Tacticals
-newpath 1038 110 moveto
-1047 110 1055 110 1064 110 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1064 114 moveto
-1074 110 lineto
-1064 107 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1064 114 moveto
-1074 110 lineto
-1064 107 lineto
-closepath
-stroke
-end grestore
-
-%	Tacinterp
-gsave 10 dict begin
-170 191 39 18 ellipse_path
-stroke
-gsave 10 dict begin
-143 186 moveto
-(Tacinterp)
-[7.44 6.24 6.24 3.84 6.96 3.84 6.24 4.8 6.96]
-xshow
-end grestore
-end grestore
-
-%	Auto
-gsave 10 dict begin
-483 218 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-468 213 moveto
-(Auto)
-[9.6 6.96 3.84 6.96]
-xshow
-end grestore
-end grestore
-
-%	Tacinterp -> Auto
-newpath 209 194 moveto
-269 200 386 210 445 215 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 445 218 moveto
-455 216 lineto
-445 212 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 445 218 moveto
-455 216 lineto
-445 212 lineto
-closepath
-stroke
-end grestore
-
-%	Leminv
-gsave 10 dict begin
-281 166 35 18 ellipse_path
-stroke
-gsave 10 dict begin
-259 161 moveto
-(Leminv)
-[8.4 6.24 10.8 3.84 6.48 6.96]
-xshow
-end grestore
-end grestore
-
-%	Tacinterp -> Leminv
-newpath 205 183 moveto
-216 181 228 178 239 175 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 240 178 moveto
-249 173 lineto
-239 172 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 240 178 moveto
-249 173 lineto
-239 172 lineto
-closepath
-stroke
-end grestore
-
-%	Hiddentac
-gsave 10 dict begin
-615 164 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-585 159 moveto
-(Hiddentac)
-[10.08 3.84 6.96 6.96 6.24 6.96 4.08 6.24 6.24]
-xshow
-end grestore
-end grestore
-
-%	Auto -> Hiddentac
-newpath 507 208 moveto
-526 200 553 189 574 181 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 576 184 moveto
-584 177 lineto
-573 177 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 576 184 moveto
-584 177 lineto
-573 177 lineto
-closepath
-stroke
-end grestore
-
-%	Dhyp
-gsave 10 dict begin
-615 218 29 18 ellipse_path
-stroke
-gsave 10 dict begin
-599 213 moveto
-(Dhyp)
-[10.08 6.48 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Auto -> Dhyp
-newpath 511 218 moveto
-530 218 555 218 576 218 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 576 222 moveto
-586 218 lineto
-576 215 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 576 222 moveto
-586 218 lineto
-576 215 lineto
-closepath
-stroke
-end grestore
-
-%	Inv
-gsave 10 dict begin
-379 164 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-369 159 moveto
-(Inv)
-[4.56 6.48 6.96]
-xshow
-end grestore
-end grestore
-
-%	Leminv -> Inv
-newpath 316 165 moveto
-324 165 333 165 342 165 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 342 169 moveto
-352 165 lineto
-342 162 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 342 169 moveto
-352 165 lineto
-342 162 lineto
-closepath
-stroke
-end grestore
-
-%	Refine
-gsave 10 dict begin
-758 110 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-739 105 moveto
-(Refine)
-[9.12 6.24 4.8 3.84 6.96 6.24]
-xshow
-end grestore
-end grestore
-
-%	Refine -> Tactics
-newpath 790 110 moveto
-805 110 824 110 841 110 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 841 114 moveto
-851 110 lineto
-841 107 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 841 114 moveto
-851 110 lineto
-841 107 lineto
-closepath
-stroke
-end grestore
-
-%	Nbtermdn
-gsave 10 dict begin
-758 256 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-729 251 moveto
-(Nbtermdn)
-[10.08 6.96 3.84 6.24 4.8 10.8 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Btermdn
-gsave 10 dict begin
-884 256 38 18 ellipse_path
-stroke
-gsave 10 dict begin
-859 251 moveto
-(Btermdn)
-[9.36 3.84 6.24 4.8 10.8 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Nbtermdn -> Btermdn
-newpath 800 256 moveto
-812 256 824 256 836 256 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 836 260 moveto
-846 256 lineto
-836 253 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 836 260 moveto
-846 256 lineto
-836 253 lineto
-closepath
-stroke
-end grestore
-
-%	Btermdn -> Termdn
-newpath 922 256 moveto
-932 256 943 256 953 256 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 953 260 moveto
-963 256 lineto
-953 253 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 953 260 moveto
-963 256 lineto
-953 253 lineto
-closepath
-stroke
-end grestore
-
-%	Elim
-gsave 10 dict begin
-483 164 27 18 ellipse_path
-stroke
-gsave 10 dict begin
-468 159 moveto
-(Elim)
-[8.4 3.84 3.84 10.8]
-xshow
-end grestore
-end grestore
-
-%	Inv -> Elim
-newpath 406 164 moveto
-418 164 432 164 445 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 445 168 moveto
-455 164 lineto
-445 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 445 168 moveto
-455 164 lineto
-445 161 lineto
-closepath
-stroke
-end grestore
-
-%	Equality
-gsave 10 dict begin
-483 56 37 18 ellipse_path
-stroke
-gsave 10 dict begin
-459 51 moveto
-(Equality)
-[8.4 6.72 6.96 6.24 3.84 3.84 3.84 6.96]
-xshow
-end grestore
-end grestore
-
-%	Inv -> Equality
-newpath 390 147 moveto
-401 130 421 102 442 83 curveto
-445 80 448 78 451 76 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 453 79 moveto
-459 70 lineto
-449 73 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 453 79 moveto
-459 70 lineto
-449 73 lineto
-closepath
-stroke
-end grestore
-
-%	Elim -> Hiddentac
-newpath 511 164 moveto
-526 164 545 164 562 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 562 168 moveto
-572 164 lineto
-562 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 562 168 moveto
-572 164 lineto
-562 161 lineto
-closepath
-stroke
-end grestore
-
-%	Equality -> Setoid_replace
-newpath 520 58 moveto
-530 59 540 60 551 60 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 551 63 moveto
-561 61 lineto
-551 57 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 551 63 moveto
-561 61 lineto
-551 57 lineto
-closepath
-stroke
-end grestore
-
-%	Evar_tactics
-gsave 10 dict begin
-758 164 48 18 ellipse_path
-stroke
-gsave 10 dict begin
-722 159 moveto
-(Evar_tactics)
-[8.4 6.72 6.24 4.56 6.96 4.08 6.24 6.24 3.84 3.84 6.24 5.52]
-xshow
-end grestore
-end grestore
-
-%	Hiddentac -> Evar_tactics
-newpath 658 164 moveto
-671 164 685 164 699 164 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 699 168 moveto
-709 164 lineto
-699 161 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 699 168 moveto
-709 164 lineto
-699 161 lineto
-closepath
-stroke
-end grestore
-
-%	Evar_tactics -> Tactics
-newpath 790 150 moveto
-808 142 830 132 849 125 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 850 128 moveto
-858 121 lineto
-847 122 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 850 128 moveto
-858 121 lineto
-847 122 lineto
-closepath
-stroke
-end grestore
-
-%	Dhyp -> Tactics
-newpath 644 219 moveto
-684 220 756 217 810 191 curveto
-844 175 855 163 872 137 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 875 138 moveto
-877 128 lineto
-869 135 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 875 138 moveto
-877 128 lineto
-869 135 lineto
-closepath
-stroke
-end grestore
-
-%	Dhyp -> Nbtermdn
-newpath 642 225 moveto
-662 230 689 238 712 244 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 712 247 moveto
-722 246 lineto
-713 241 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 712 247 moveto
-722 246 lineto
-713 241 lineto
-closepath
-stroke
-end grestore
-
-%	Contradiction
-gsave 10 dict begin
-758 18 51 18 ellipse_path
-stroke
-gsave 10 dict begin
-719 13 moveto
-(Contradiction)
-[9.36 6.96 6.96 3.84 4.56 6.24 6.96 3.84 6.24 3.84 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Contradiction -> Tactics
-newpath 784 34 moveto
-793 39 802 44 810 50 curveto
-827 62 845 76 859 88 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 857 91 moveto
-867 95 lineto
-862 86 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 857 91 moveto
-867 95 lineto
-862 86 lineto
-closepath
-stroke
-end grestore
-
-%	Autorewrite
-gsave 10 dict begin
-47 191 47 18 ellipse_path
-stroke
-gsave 10 dict begin
-13 186 moveto
-(Autorewrite)
-[9.6 6.96 3.84 6.96 4.56 5.76 10.08 4.8 3.84 3.84 6.24]
-xshow
-end grestore
-end grestore
-
-%	Autorewrite -> Tacinterp
-newpath 94 191 moveto
-102 191 111 191 120 191 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 120 195 moveto
-130 191 lineto
-120 188 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 120 195 moveto
-130 191 lineto
-120 188 lineto
-closepath
-stroke
-end grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-end
-restore
-%%EOF
diff --git a/dev/ocamlweb-doc/toplevel.dep.ps b/dev/ocamlweb-doc/toplevel.dep.ps
deleted file mode 100644
index e0355aac..00000000
--- a/dev/ocamlweb-doc/toplevel.dep.ps
+++ /dev/null
@@ -1,971 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
-%%For: (herbelin) Hugo Herbelin
-%%Title: G
-%%Pages: (atend)
-%%BoundingBox: 35 35 577 166
-%%EndComments
-save
-%%BeginProlog
-/DotDict 200 dict def
-DotDict begin
-
-/setupLatin1 {
-mark
-/EncodingVector 256 array def
- EncodingVector 0
-
-ISOLatin1Encoding 0 255 getinterval putinterval
-
-EncodingVector
-  dup 306 /AE
-  dup 301 /Aacute
-  dup 302 /Acircumflex
-  dup 304 /Adieresis
-  dup 300 /Agrave
-  dup 305 /Aring
-  dup 303 /Atilde
-  dup 307 /Ccedilla
-  dup 311 /Eacute
-  dup 312 /Ecircumflex
-  dup 313 /Edieresis
-  dup 310 /Egrave
-  dup 315 /Iacute
-  dup 316 /Icircumflex
-  dup 317 /Idieresis
-  dup 314 /Igrave
-  dup 334 /Udieresis
-  dup 335 /Yacute
-  dup 376 /thorn
-  dup 337 /germandbls
-  dup 341 /aacute
-  dup 342 /acircumflex
-  dup 344 /adieresis
-  dup 346 /ae
-  dup 340 /agrave
-  dup 345 /aring
-  dup 347 /ccedilla
-  dup 351 /eacute
-  dup 352 /ecircumflex
-  dup 353 /edieresis
-  dup 350 /egrave
-  dup 355 /iacute
-  dup 356 /icircumflex
-  dup 357 /idieresis
-  dup 354 /igrave
-  dup 360 /dcroat
-  dup 361 /ntilde
-  dup 363 /oacute
-  dup 364 /ocircumflex
-  dup 366 /odieresis
-  dup 362 /ograve
-  dup 365 /otilde
-  dup 370 /oslash
-  dup 372 /uacute
-  dup 373 /ucircumflex
-  dup 374 /udieresis
-  dup 371 /ugrave
-  dup 375 /yacute
-  dup 377 /ydieresis  
-
-% Set up ISO Latin 1 character encoding
-/starnetISO {
-        dup dup findfont dup length dict begin
-        { 1 index /FID ne { def }{ pop pop } ifelse
-        } forall
-        /Encoding EncodingVector def
-        currentdict end definefont
-} def
-/Times-Roman starnetISO def
-/Times-Italic starnetISO def
-/Times-Bold starnetISO def
-/Times-BoldItalic starnetISO def
-/Helvetica starnetISO def
-/Helvetica-Oblique starnetISO def
-/Helvetica-Bold starnetISO def
-/Helvetica-BoldOblique starnetISO def
-/Courier starnetISO def
-/Courier-Oblique starnetISO def
-/Courier-Bold starnetISO def
-/Courier-BoldOblique starnetISO def
-cleartomark
-} bind def
-
-%%BeginResource: procset graphviz 0 0
-/coord-font-family /Times-Roman def
-/default-font-family /Times-Roman def
-/coordfont coord-font-family findfont 8 scalefont def
-
-/InvScaleFactor 1.0 def
-/set_scale {
-	dup 1 exch div /InvScaleFactor exch def
-	dup scale
-} bind def
-
-% styles
-/solid { [] 0 setdash } bind def
-/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
-/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
-/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
-/bold { 2 setlinewidth } bind def
-/filled { } bind def
-/unfilled { } bind def
-/rounded { } bind def
-/diagonals { } bind def
-
-% hooks for setting color 
-/nodecolor { sethsbcolor } bind def
-/edgecolor { sethsbcolor } bind def
-/graphcolor { sethsbcolor } bind def
-/nopcolor {pop pop pop} bind def
-
-/beginpage {	% i j npages
-	/npages exch def
-	/j exch def
-	/i exch def
-	/str 10 string def
-	npages 1 gt {
-		gsave
-			coordfont setfont
-			0 0 moveto
-			(\() show i str cvs show (,) show j str cvs show (\)) show
-		grestore
-	} if
-} bind def
-
-/set_font {
-	findfont exch
-	scalefont setfont
-} def
-
-% draw aligned label in bounding box aligned to current point
-/alignedtext {			% width adj text
-	/text exch def
-	/adj exch def
-	/width exch def
-	gsave
-		width 0 gt {
-			text stringwidth pop adj mul 0 rmoveto
-		} if
-		[] 0 setdash
-		text show
-	grestore
-} def
-
-/boxprim {				% xcorner ycorner xsize ysize
-		4 2 roll
-		moveto
-		2 copy
-		exch 0 rlineto
-		0 exch rlineto
-		pop neg 0 rlineto
-		closepath
-} bind def
-
-/ellipse_path {
-	/ry exch def
-	/rx exch def
-	/y exch def
-	/x exch def
-	matrix currentmatrix
-	newpath
-	x y translate
-	rx ry scale
-	0 0 1 0 360 arc
-	setmatrix
-} bind def
-
-/endpage { showpage } bind def
-/showpage { } def
-
-/layercolorseq
-	[	% layer color sequence - darkest to lightest
-		[0 0 0]
-		[.2 .8 .8]
-		[.4 .8 .8]
-		[.6 .8 .8]
-		[.8 .8 .8]
-	]
-def
-
-/layerlen layercolorseq length def
-
-/setlayer {/maxlayer exch def /curlayer exch def
-	layercolorseq curlayer 1 sub layerlen mod get
-	aload pop sethsbcolor
-	/nodecolor {nopcolor} def
-	/edgecolor {nopcolor} def
-	/graphcolor {nopcolor} def
-} bind def
-
-/onlayer { curlayer ne {invis} if } def
-
-/onlayers {
-	/myupper exch def
-	/mylower exch def
-	curlayer mylower lt
-	curlayer myupper gt
-	or
-	{invis} if
-} def
-
-/curlayer 0 def
-
-%%EndResource
-%%EndProlog
-%%BeginSetup
-14 default-font-family set_font
-1 setmiterlimit
-% /arrowlength 10 def
-% /arrowwidth 5 def
-
-% make sure pdfmark is harmless for PS-interpreters other than Distiller
-/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
-% make '<<' and '>>' safe on PS Level 1 devices
-/languagelevel where {pop languagelevel}{1} ifelse
-2 lt {
-    userdict (<<) cvn ([) cvn load put
-    userdict (>>) cvn ([) cvn load put
-} if
-
-%%EndSetup
-%%Page: 1 1
-%%PageBoundingBox: 36 36 577 166
-%%PageOrientation: Portrait
-gsave
-35 35 542 131 boxprim clip newpath
-36 36 translate
-0 0 1 beginpage
-0.4180 set_scale
-0 0 translate 0 rotate
-0.000 0.000 0.000 graphcolor
-14.00 /Times-Roman set_font
-
-%	Vernac
-gsave 10 dict begin
-562 145 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-541 140 moveto
-(Vernac)
-[8.88 6.24 4.8 6.96 6.24 6.24]
-xshow
-end grestore
-end grestore
-
-%	Vernacentries
-gsave 10 dict begin
-724 158 52 18 ellipse_path
-stroke
-gsave 10 dict begin
-685 153 moveto
-(Vernacentries)
-[8.88 6.24 4.8 6.96 6.24 6.24 6.24 6.96 3.84 4.8 3.84 6.24 5.52]
-xshow
-end grestore
-end grestore
-
-%	Vernac -> Vernacentries
-newpath 595 148 moveto
-615 149 640 151 663 153 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 663 156 moveto
-673 154 lineto
-663 150 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 663 156 moveto
-673 154 lineto
-663 150 lineto
-closepath
-stroke
-end grestore
-
-%	Vernacinterp
-gsave 10 dict begin
-862 158 50 18 ellipse_path
-stroke
-gsave 10 dict begin
-825 153 moveto
-(Vernacinterp)
-[8.88 6.24 4.8 6.96 6.24 6.24 3.84 6.96 3.84 6.24 4.8 6.96]
-xshow
-end grestore
-end grestore
-
-%	Vernacentries -> Vernacinterp
-newpath 776 158 moveto
-785 158 793 158 802 158 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 802 162 moveto
-812 158 lineto
-802 155 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 802 162 moveto
-812 158 lineto
-802 155 lineto
-closepath
-stroke
-end grestore
-
-%	Discharge
-gsave 10 dict begin
-862 212 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-833 207 moveto
-(Discharge)
-[10.08 3.84 5.52 6 6.96 6.24 4.32 6.72 6.24]
-xshow
-end grestore
-end grestore
-
-%	Vernacentries -> Discharge
-newpath 758 171 moveto
-777 179 801 188 822 196 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 820 199 moveto
-831 200 lineto
-823 193 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 820 199 moveto
-831 200 lineto
-823 193 lineto
-closepath
-stroke
-end grestore
-
-%	Mltop
-gsave 10 dict begin
-862 104 31 18 ellipse_path
-stroke
-gsave 10 dict begin
-844 99 moveto
-(Mltop)
-[12.48 3.84 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Vernacentries -> Mltop
-newpath 758 145 moveto
-779 137 805 126 826 118 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 828 121 moveto
-836 114 lineto
-825 114 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 828 121 moveto
-836 114 lineto
-825 114 lineto
-closepath
-stroke
-end grestore
-
-%	Record
-gsave 10 dict begin
-862 281 33 18 ellipse_path
-stroke
-gsave 10 dict begin
-842 276 moveto
-(Record)
-[9.12 6.24 6.24 6.96 4.32 6.96]
-xshow
-end grestore
-end grestore
-
-%	Vernacentries -> Record
-newpath 742 175 moveto
-760 192 788 217 812 239 curveto
-819 246 828 253 835 259 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 833 262 moveto
-843 266 lineto
-838 257 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 833 262 moveto
-843 266 lineto
-838 257 lineto
-closepath
-stroke
-end grestore
-
-%	Himsg
-gsave 10 dict begin
-991 85 32 18 ellipse_path
-stroke
-gsave 10 dict begin
-971 80 moveto
-(Himsg)
-[10.08 3.84 10.8 5.52 6.96]
-xshow
-end grestore
-end grestore
-
-%	Vernacinterp -> Himsg
-newpath 890 143 moveto
-897 139 905 135 912 131 curveto
-929 123 946 112 960 103 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 962 106 moveto
-969 98 lineto
-959 100 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 962 106 moveto
-969 98 lineto
-959 100 lineto
-closepath
-stroke
-end grestore
-
-%	Vernacexpr
-gsave 10 dict begin
-1246 221 45 18 ellipse_path
-stroke
-gsave 10 dict begin
-1213 216 moveto
-(Vernacexpr)
-[8.88 6.24 4.8 6.96 6.24 6.24 5.76 6.96 6.96 4.56]
-xshow
-end grestore
-end grestore
-
-%	Vernacinterp -> Vernacexpr
-newpath 912 159 moveto
-947 160 994 163 1034 169 curveto
-1092 178 1158 195 1200 207 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1199 210 moveto
-1210 210 lineto
-1201 204 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1199 210 moveto
-1210 210 lineto
-1201 204 lineto
-closepath
-stroke
-end grestore
-
-%	Class
-gsave 10 dict begin
-1117 238 28 18 ellipse_path
-stroke
-gsave 10 dict begin
-1101 233 moveto
-(Class)
-[9.36 3.84 6.24 5.52 5.52]
-xshow
-end grestore
-end grestore
-
-%	Discharge -> Class
-newpath 902 217 moveto
-917 219 933 221 948 223 curveto
-992 228 1044 232 1079 235 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1079 238 moveto
-1089 236 lineto
-1079 232 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1079 238 moveto
-1089 236 lineto
-1079 232 lineto
-closepath
-stroke
-end grestore
-
-%	Recordobj
-gsave 10 dict begin
-991 196 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-962 191 moveto
-(Recordobj)
-[9.12 6.24 6.24 6.96 4.32 6.96 6.96 6.96 3.84]
-xshow
-end grestore
-end grestore
-
-%	Discharge -> Recordobj
-newpath 902 207 moveto
-914 205 927 204 940 202 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 940 205 moveto
-950 201 lineto
-940 199 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 940 205 moveto
-950 201 lineto
-940 199 lineto
-closepath
-stroke
-end grestore
-
-%	Command
-gsave 10 dict begin
-991 288 42 18 ellipse_path
-stroke
-gsave 10 dict begin
-961 283 moveto
-(Command)
-[9.36 6.96 10.8 10.8 6.24 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Record -> Command
-newpath 895 283 moveto
-908 284 923 285 938 285 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 938 288 moveto
-948 286 lineto
-938 282 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 938 288 moveto
-948 286 lineto
-938 282 lineto
-closepath
-stroke
-end grestore
-
-%	Toplevel
-gsave 10 dict begin
-255 72 37 18 ellipse_path
-stroke
-gsave 10 dict begin
-231 67 moveto
-(Toplevel)
-[7.2 6.96 6.96 3.84 5.76 6.48 6.24 3.84]
-xshow
-end grestore
-end grestore
-
-%	Protectedtoplevel
-gsave 10 dict begin
-390 72 61 18 ellipse_path
-stroke
-gsave 10 dict begin
-341 67 moveto
-(Protectedtoplevel)
-[7.68 4.56 6.72 3.84 6.24 6.24 3.84 6.24 6.96 3.84 6.96 6.96 3.84 5.76 6.48 6.24 3.84]
-xshow
-end grestore
-end grestore
-
-%	Toplevel -> Protectedtoplevel
-newpath 292 72 moveto
-300 72 309 72 318 72 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 318 76 moveto
-328 72 lineto
-318 69 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 318 76 moveto
-328 72 lineto
-318 69 lineto
-closepath
-stroke
-end grestore
-
-%	Protectedtoplevel -> Vernac
-newpath 425 87 moveto
-455 100 497 117 527 130 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 525 133 moveto
-536 134 lineto
-528 127 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 525 133 moveto
-536 134 lineto
-528 127 lineto
-closepath
-stroke
-end grestore
-
-%	Cerrors
-gsave 10 dict begin
-724 65 34 18 ellipse_path
-stroke
-gsave 10 dict begin
-702 60 moveto
-(Cerrors)
-[9.36 6.24 5.04 4.56 6.96 4.56 5.52]
-xshow
-end grestore
-end grestore
-
-%	Protectedtoplevel -> Cerrors
-newpath 452 71 moveto
-518 70 621 67 679 66 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 679 70 moveto
-689 66 lineto
-679 63 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 679 70 moveto
-689 66 lineto
-679 63 lineto
-closepath
-stroke
-end grestore
-
-%	Line_oriented_parser
-gsave 10 dict begin
-562 26 73 18 ellipse_path
-stroke
-gsave 10 dict begin
-501 21 moveto
-(Line_oriented_parser)
-[8.4 3.84 6.96 6.24 6.96 6.96 4.8 3.84 6.24 6.96 3.84 6.24 6.96 6.96 6.96 6.24 4.56 5.52 6.24 4.56]
-xshow
-end grestore
-end grestore
-
-%	Protectedtoplevel -> Line_oriented_parser
-newpath 436 60 moveto
-457 55 481 48 502 42 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 503 45 moveto
-512 39 lineto
-501 39 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 503 45 moveto
-512 39 lineto
-501 39 lineto
-closepath
-stroke
-end grestore
-
-%	Metasyntax
-gsave 10 dict begin
-1117 292 46 18 ellipse_path
-stroke
-gsave 10 dict begin
-1083 287 moveto
-(Metasyntax)
-[12.48 6 4.08 6.24 5.52 6.96 6.96 4.08 6.24 6.96]
-xshow
-end grestore
-end grestore
-
-%	Command -> Metasyntax
-newpath 1034 289 moveto
-1043 290 1052 290 1061 290 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1061 293 moveto
-1071 291 lineto
-1061 287 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1061 293 moveto
-1071 291 lineto
-1061 287 lineto
-closepath
-stroke
-end grestore
-
-%	Command -> Class
-newpath 1022 276 moveto
-1041 268 1065 259 1084 252 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1085 255 moveto
-1093 248 lineto
-1082 249 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1085 255 moveto
-1093 248 lineto
-1082 249 lineto
-closepath
-stroke
-end grestore
-
-%	Cerrors -> Himsg
-newpath 758 67 moveto
-796 69 859 73 912 77 curveto
-924 78 937 79 949 80 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 949 83 moveto
-959 81 lineto
-949 77 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 949 83 moveto
-959 81 lineto
-949 77 lineto
-closepath
-stroke
-end grestore
-
-%	Minicoq
-gsave 10 dict begin
-38 126 37 18 ellipse_path
-stroke
-gsave 10 dict begin
-13 121 moveto
-(Minicoq)
-[12.48 3.84 6.96 3.84 6.24 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Fhimsg
-gsave 10 dict begin
-147 126 34 18 ellipse_path
-stroke
-gsave 10 dict begin
-125 121 moveto
-(Fhimsg)
-[7.68 6.96 3.84 10.8 5.52 6.96]
-xshow
-end grestore
-end grestore
-
-%	Minicoq -> Fhimsg
-newpath 76 126 moveto
-84 126 93 126 102 126 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 102 130 moveto
-112 126 lineto
-102 123 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 102 130 moveto
-112 126 lineto
-102 123 lineto
-closepath
-stroke
-end grestore
-
-%	Metasyntax -> Vernacexpr
-newpath 1144 277 moveto
-1163 267 1189 252 1210 241 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 1212 244 moveto
-1219 236 lineto
-1209 238 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 1212 244 moveto
-1219 236 lineto
-1209 238 lineto
-closepath
-stroke
-end grestore
-
-%	Coqtop
-gsave 10 dict begin
-38 45 34 18 ellipse_path
-stroke
-gsave 10 dict begin
-17 40 moveto
-(Coqtop)
-[9.36 6.96 6.96 3.84 6.96 6.96]
-xshow
-end grestore
-end grestore
-
-%	Coqinit
-gsave 10 dict begin
-147 72 34 18 ellipse_path
-stroke
-gsave 10 dict begin
-126 67 moveto
-(Coqinit)
-[9.36 6.96 6.96 3.84 6.96 3.84 3.84]
-xshow
-end grestore
-end grestore
-
-%	Coqtop -> Coqinit
-newpath 69 53 moveto
-81 56 94 59 106 62 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 105 65 moveto
-116 65 lineto
-107 59 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 105 65 moveto
-116 65 lineto
-107 59 lineto
-closepath
-stroke
-end grestore
-
-%	Usage
-gsave 10 dict begin
-147 18 31 18 ellipse_path
-stroke
-gsave 10 dict begin
-129 13 moveto
-(Usage)
-[10.08 5.52 6.24 6.72 6.24]
-xshow
-end grestore
-end grestore
-
-%	Coqtop -> Usage
-newpath 69 37 moveto
-81 34 95 31 108 28 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 109 31 moveto
-118 25 lineto
-107 25 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 109 31 moveto
-118 25 lineto
-107 25 lineto
-closepath
-stroke
-end grestore
-
-%	Coqinit -> Toplevel
-newpath 181 72 moveto
-190 72 199 72 208 72 curveto
-stroke
-gsave 10 dict begin
-solid
-1 setlinewidth
-0.000 0.000 0.000 edgecolor
-newpath 208 76 moveto
-218 72 lineto
-208 69 lineto
-closepath
-fill
-0.000 0.000 0.000 edgecolor
-newpath 208 76 moveto
-218 72 lineto
-208 69 lineto
-closepath
-stroke
-end grestore
-endpage
-showpage
-grestore
-%%PageTrailer
-%%EndPage: 1
-%%Trailer
-%%Pages: 1
-end
-restore
-%%EOF
diff --git a/dev/printers.mllib b/dev/printers.mllib
index 889484ee..6a42678e 100644
--- a/dev/printers.mllib
+++ b/dev/printers.mllib
@@ -7,18 +7,16 @@ Flags
 Segmenttree
 Unicodetable
 Util
+Errors
 Bigint
 Hashcons
 Dyn
 System
 Envars
-Bstack
-Edit
-Gset
+Store
 Gmap
 Fset
 Fmap
-Tlm
 Gmapl
 Profile
 Explore
@@ -27,6 +25,7 @@ Rtree
 Heap
 Option
 Dnet
+Hashtbl_alt
 
 Names
 Univ
@@ -71,7 +70,7 @@ Assumptions
 Termops
 Namegen
 Evd
-Rawterm
+Glob_term
 Reductionops
 Inductiveops
 Retyping
@@ -81,6 +80,7 @@ Evarutil
 Term_dnet
 Recordops
 Evarconv
+Arguments_renaming
 Typing
 Pattern
 Matching
@@ -94,8 +94,9 @@ Coercion
 Unification
 Cases
 Pretyping
-Clenv
+Declaremods
 
+Tok
 Lexer
 Ppextend
 Genarg
@@ -109,12 +110,17 @@ Syntax_def
 Implicit_quantifiers
 Smartlocate
 Constrintern
-Proof_trees
+Modintern
 Tacexpr
 Proof_type
+Goal
 Logic
 Refiner
+Clenv
 Evar_refiner
+Proofview
+Proof
+Proof_global
 Pfedit
 Tactic_debug
 Decl_mode
diff --git a/dev/tools/change-header b/dev/tools/change-header
new file mode 100755
index 00000000..61cc8666
--- /dev/null
+++ b/dev/tools/change-header
@@ -0,0 +1,55 @@
+#!/bin/sh
+
+#This script changes the header of .ml* files
+
+if [ ! $# = 2 ]; then
+  echo Usage: change-header old-header-file new-header-file
+  exit 1
+fi
+
+oldheader=$1
+newheader=$2
+
+if [ ! -f $oldheader ]; then echo Cannot read file $oldheader; exit 1; fi
+if [ ! -f $newheader ]; then echo Cannot read file $newheader; exit 1; fi
+
+n=`wc -l $oldheader | sed -e "s/ *\([0-9]*\).*/\1/g"`
+nsucc=`expr $n + 1`
+
+linea='(* -*- coding:utf-8 -*- *)'
+lineb='(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)'
+
+modified=0
+kept=0
+
+for i in `find . -name \*.mli -o -name \*.ml -o -name \*.ml4 -o -name \*.mll -o -name \*.mly -o -name \*.mlp -o -name \*.v`; do
+  headline=`head -n 1 $i`
+  if `echo $headline | grep "(\* -\*- .* \*)" > /dev/null`; then
+      # Has emacs header
+      head -n +$nsucc $i | tail -n $n > $i.head.tmp$$
+      hasheadline=1
+      nnext=`expr $nsucc + 1`
+  else
+      head -n +$n $i > $i.head.tmp$$
+      hasheadline=0
+      nnext=$nsucc
+  fi
+  if diff -a -q $oldheader $i.head.tmp$$ > /dev/null; then
+    echo "$i: header changed"
+    if [ $hasheadline = 1 ]; then
+        echo $headline > $i.tmp$$
+    else
+        touch $i.tmp$$
+    fi
+    cat $newheader >> $i.tmp$$
+    tail -n +$nnext $i >> $i.tmp$$
+    mv $i.tmp$$ $i
+    modified=`expr $modified + 1`
+  else
+    kept=`expr $kept + 1`
+  fi
+  rm $i.head.tmp$$
+done
+
+echo $modified files updated 
+echo $kept files unchanged
diff --git a/dev/tools/univdot b/dev/tools/univdot
deleted file mode 100755
index bb0dd2c8..00000000
--- a/dev/tools/univdot
+++ /dev/null
@@ -1,49 +0,0 @@
-#!/bin/sh
-
-usage() {
-    echo ""
-    echo "usage: univdot [INPUT] [OUTPUT]"
-    echo ""
-    echo "takes the output of Dump Universes \"file\" command"
-    echo "and transforms it to the dot format"
-    echo ""
-    echo "Coq> Dump Universes \"univ.raw\"."
-    echo ""
-    echo "user@host> univdot univ.raw | dot -Tps > univ.ps" 
-    echo ""
-}
-    
-
-# these are dot edge attributes to draw arrows corresponding 
-# to > >= and = edges of the universe graph
-
-GT="[color=red]"
-GE="[color=blue]"
-EQ="[color=black]"
-
-
-# input/output redirection
-case $# in
-  0) ;;
-  1) case $1 in
-       -h|-help|--help) usage
-               exit 0 ;;
-       *) exec < $1 ;;
-     esac ;;
-  2) exec < $1 > $2 ;;
-  *) usage
-     exit 0;;
-esac
-
-
-# dot header
-echo 'digraph G {\
-  size="7.5,10" ;\
-  rankdir = TB ;'
-
-sed -e "s/^\([^ =>]\+\) > \([^ =>]\+\)/\1 -> \2 $GT/" \
-      -e "s/^\([^ =>]\+\) >= \([^ =>]\+\)/\1 -> \2 $GE/" \
-      -e "s/^\([^ =>]\+\) = \([^ =>]\+\)/\1 -> \2 $EQ/" \
-| sed -e "s/\./_/g" 
-
-echo "}"
\ No newline at end of file
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index 3a6abd43..3fc90761 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,22 +16,20 @@ open Libnames
 open Nameops
 open Sign
 open Univ
-open Proof_trees
 open Environ
 open Printer
 open Tactic_printer
-open Refiner
 open Term
 open Termops
-open Clenv
 open Cerrors
 open Evd
 open Goptions
 open Genarg
 open Mod_subst
-
+open Clenv
 
 let _ = Constrextern.print_evar_arguments := true
+let _ = Constrextern.print_universes := true
 let _ = set_bool_option_value ["Printing";"Matching"] false
 let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
 
@@ -58,9 +56,9 @@ let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x)
 let ppterm = ppconstr
 let ppsconstr x = ppconstr (Declarations.force x)
 let ppconstr_univ x = Constrextern.with_universes ppconstr x
-let pprawconstr = (fun x -> pp(pr_lrawconstr x))
+let ppglob_constr = (fun x -> pp(pr_lglob_constr x))
 let pppattern = (fun x -> pp(pr_constr_pattern x))
-let pptype = (fun x -> pp(pr_ltype x))
+let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e)))
 
 let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
 
@@ -114,22 +112,31 @@ 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 ppevm evd = pp(pr_evar_map (Some 2) evd)
+let ppevmall evd = pp(pr_evar_map None evd)
+let pr_existentialset evars =
+  prlist_with_sep spc pr_meta (ExistentialSet.elements evars)
+let ppexistentialset evars =
+  pp (pr_existentialset evars)
 let ppclenv clenv = pp(pr_clenv clenv)
-let ppgoal g = pp(db_pr_goal g)
+let ppgoalgoal gl = pp(Goal.pr_goal gl)
+let ppgoal g = pp(Printer.pr_goal g)
+(* spiwack: deactivated until a replacement is found
 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))
+(* let ppgoal g = pp(db_pr_goal g) *)
+(* let pr_gls gls = *)
+(*   hov 0 (pr_evar_defs (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it 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))
+(* let pr_glls glls = *)
+(*   hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ *)
+(*          prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) *)
 
-let ppsigmagoal g = pp(pr_goal (sig_it g))
-let prgls gls = pp(pr_gls gls)
-let prglls glls = pp(pr_glls glls)
-let pproof p = pp(print_proof Evd.empty empty_named_context p)
+(* let ppsigmagoal g = pp(pr_goal (sig_it g)) *)
+(* let prgls gls = pp(pr_gls gls) *)
+(* let prglls glls = pp(pr_glls glls) *)
+(* let pproof p = pp(print_proof Evd.empty empty_named_context p) *)
 
 let ppuni u = pp(pr_uni u)
 
@@ -153,6 +160,7 @@ let cast_kind_display k =
   match k with
   | VMcast -> "VMcast"
   | DEFAULTcast -> "DEFAULTcast"
+  | REVERTcast -> "REVERTcast"
 
 let constr_display csr =
   let rec term_display c = match kind_of_term c with
@@ -412,12 +420,12 @@ let _ =
            (fun () -> in_current_context constr_display c)
        | _ -> failwith "Vernac extension: cannot occur")
   with
-    e -> Pp.pp (Cerrors.explain_exn e)
+    e -> Pp.pp (Errors.print e)
 let _ =
-  extend_vernac_command_grammar "PrintConstr"
+  extend_vernac_command_grammar "PrintConstr" None
     [[GramTerminal "PrintConstr";
       GramNonTerminal
-        (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"),
+        (dummy_loc,ConstrArgType,Aentry ("constr","constr"),
 	 Some (Names.id_of_string "c"))]]
 
 let _ =
@@ -429,12 +437,12 @@ let _ =
            (fun () -> in_current_context print_pure_constr c)
        | _ -> failwith "Vernac extension: cannot occur")
   with
-    e -> Pp.pp (Cerrors.explain_exn e)
+    e -> Pp.pp (Errors.print e)
 let _ =
-  extend_vernac_command_grammar "PrintPureConstr"
+  extend_vernac_command_grammar "PrintPureConstr" None
     [[GramTerminal "PrintPureConstr";
       GramNonTerminal
-        (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"),
+        (dummy_loc,ConstrArgType,Aentry ("constr","constr"),
 	 Some (Names.id_of_string "c"))]]
 
 (* Setting printer of unbound global reference *)
diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex
index 46ba24da..6630be06 100644
--- a/dev/v8-syntax/syntax-v8.tex
+++ b/dev/v8-syntax/syntax-v8.tex
@@ -977,7 +977,6 @@ $$
 \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{ident}
 \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{string}
 \nlsep \TERM{Declare}~\TERM{ML}~\TERM{Module}~\PLUS{\NT{string}}
-\nlsep \TERM{Dump}~\TERM{Universes}~\OPT{\NT{string}}
 \nlsep \TERM{Locate}~\NT{locatable}
 \nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{LoadPath}~\NT{string}~\OPT{\NT{as-dirpath}}
 \nlsep \TERM{Remove}~\TERM{LoadPath}~\NT{string}
@@ -1179,8 +1178,6 @@ $$
 \nlsep \TERM{Show}~\TERM{Intros}
 %% Correctness: obsolete ?
 %%\nlsep \TERM{Show}~\TERM{Programs}
-\nlsep \TERM{Explain}~\TERM{Proof}~\OPT{\TERM{Tree}}~\STAR{\NT{num}}
-%% Go not documented
 \nlsep \TERM{Hint}~\OPT{\TERM{Local}}~\NT{hint}~\OPT{\NT{inbases}}
 %% PrintConstr not documented
 \end{rules}
diff --git a/doc/common/macros.tex b/doc/common/macros.tex
index d745f34a..f0fb0883 100755
--- a/doc/common/macros.tex
+++ b/doc/common/macros.tex
@@ -520,8 +520,6 @@
         {\begin{center}\begin{rulebox}}
         {\end{rulebox}\end{center}}
 
-% $Id: macros.tex 13091 2010-06-08 13:56:19Z herbelin $ 
-
 
 %%% Local Variables: 
 %%% mode: latex
diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html
index c3091b4e..f4809a48 100644
--- a/doc/common/styles/html/coqremote/cover.html
+++ b/doc/common/styles/html/coqremote/cover.html
@@ -1,10 +1,9 @@
-<!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" lang="en" xml:lang="en">
+<HTML>
 
-<head>
+<HEAD>
+<TITLE>Cover Page</TITLE>
 
-<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
 <title>Reference Manual | The Coq Proof Assistant</title>
 
 <link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
@@ -18,9 +17,9 @@
 <style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/style.css";</style>
 <style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/coqdoc.css";</style>
 
-</head>
+</HEAD>
 
-<body>
+<BODY>
 
 <div id="container">
 <div id="headertop">
@@ -28,6 +27,7 @@
 
   <ul class="links-menu">
     <li><a href="http://coq.inria.fr/" class="active">Home</a></li>
+
     <li><a href="http://coq.inria.fr/about-coq" title="More about coq">About Coq</a></li>    
     <li><a href="http://coq.inria.fr/download">Get Coq</a></li>
     <li><a href="http://coq.inria.fr/documentation">Documentation</a></li>
@@ -54,27 +54,29 @@
 <h1 style="text-align: center; font-weight:bold; font-size: 300%; line-height: 2ex">Reference Manual</h1>
   
 <h2 style="text-align:center; font-size: 120%">
-  Version 8.3<a name="text1"></a><sup><a href="#note1"><span style="font-size: 80%">1</span></a></sup>
+  Version trunk<a name="text1"></a><a href="#note1"><SUP><span style="font-size: 80%">1</span></SUP></a>
 
 <br/><br/><br/><br/><br/><br/>
 <span style="text-align: center; font-size: 120%; ">The Coq Development Team</span>
 <br/><br/><br/><br/><br/><br/>
-</h2>
+
 
 <div style="text-align: left; font-size: 80%; text-indent: 0pt">
 <ul style="list-style: none; margin-left: 0pt">
   <li>V7.x © INRIA 1999-2004</li>
-  <li>V8.x © INRIA 2004-2010</li>
+  <li>V8.0 © INRIA 2004-2006</li>
+  <li>V8.1 © INRIA 2006-2008</li>
+  <li>V8.2 © INRIA 2008-2009</li>
 </ul>
 
 <p style="text-indent: 0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p>
 </div>
 <br/>
 
-<hr style="width: 75%"/>
+<hr width="75%" size=1>
 <div style="text-align: left; font-size: 80%; text-indent: 0pt">
 <dl>
-  <dt><a name="note1" href="toc.html#text1">1</a></dt>
+  <dt><a name="note1" href="toc.html#text1">1</a>
   <dd>This research was partly supported by IST working group ``Types''</dd>
 </dl>
 </div>
diff --git a/doc/common/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html
deleted file mode 100644
index 2b4e0de0..00000000
--- a/doc/common/styles/html/coqremote/footer.html
+++ /dev/null
@@ -1,43 +0,0 @@
-<div id="sidebarWrapper">
-<div id="sidebar">
-
-<div class="block">
-<h2 class="title">Navigation</h2>
-<div class="content">
-
-<ul class="menu">
-
-<li class="leaf">Standard Library
-  <ul class="menu">
-  <li><a href="index.html">Table of contents</a></li>
-  <li><a href="genindex.html">Index</a></li>
-  </ul>
-</li>
-
-</ul>
-
-</div>
-</div>
-
-</div>
-</div>
-
-
-</div>
-
-<div id="footer">
-<div id="nav-footer">
-  <ul class="links-menu-footer">
-    <li><a href="mailto:www-coq_@_lix.polytechnique.fr">webmaster</a></li>
-    <li><a href="http://validator.w3.org/check?uri=referer">xhtml valid</a></li>
-    <li><a href="http://jigsaw.w3.org/css-validator/check/referer">CSS valid</a></li>
-  </ul>
-
-</div>
-</div>
-
-</div>
-
-</body>
-</html>
-
diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html
deleted file mode 100644
index 025e1d3a..00000000
--- a/doc/common/styles/html/coqremote/header.html
+++ /dev/null
@@ -1,49 +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" lang="en" xml:lang="en">
-
-<head>
-<meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>
-<title>Standard Library | The Coq Proof Assistant</title>
-
-<link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/node/node.css";</style>
-
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/defaults.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/system.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/user/user.css";</style>
-
-<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/style.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/coqdoc.css";</style>
-
-</head>
-
-<body>
-
-<div id="container">
-<div id="headertop">
-<div id="nav">
-  <ul class="links-menu">
-    <li><a href="http://coq.inria.fr/" class="active">Home</a></li>
-    
-    <li><a href="http://coq.inria.fr/about-coq" title="More about coq">About Coq</a></li>    
-    <li><a href="http://coq.inria.fr/download">Get Coq</a></li>
-    <li><a href="http://coq.inria.fr/documentation">Documentation</a></li>
-    <li><a href="http://coq.inria.fr/community">Community</a></li>
-  </ul>
-</div>
-</div>
-
-<div id="header">
-
-<div id="logoWrapper">
-
-<div id="logo"><a href="http://coq.inria.fr/" title="Home"><img src="http://coq.inria.fr/files/barron_logo.png" alt="Home" /></a>
-</div>
-<div id="siteName"><a href="http://coq.inria.fr/" title="Home">The Coq Proof Assistant</a>
-</div>
-
-</div>
-</div>
-
-<div id="content">
-
diff --git a/doc/common/styles/html/coqremote/styles.hva b/doc/common/styles/html/coqremote/styles.hva
index ec14840b..82f18681 100644
--- a/doc/common/styles/html/coqremote/styles.hva
+++ b/doc/common/styles/html/coqremote/styles.hva
@@ -2,16 +2,16 @@
 \begin{rawhtml}
 <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
 
-<LINK rel="shortcut icon" href="favicon.ico" type="image/x-icon">
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/modules/node/node.css";</STYLE>
+<link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
+<style type="text/css" media="all">@import "http://coq.inria.fr/modules/node/node.css";</style>
 
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/modules/system/defaults.css";</STYLE>
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/modules/system/system.css";</STYLE>
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/modules/user/user.css";</STYLE>
+<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/defaults.css";</style>
+<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/system.css";</style>
+<style type="text/css" media="all">@import "http://coq.inria.fr/modules/user/user.css";</style>
 
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/style.css";</STYLE>
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/coqdoc.css";</STYLE>
-<STYLE type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/hevea.css";</STYLE>
+<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/style.css";</style>
+<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/coqdoc.css";</style>
+<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/hevea.css";</style>
 \end{rawhtml}}
 
 % for HeVeA
@@ -35,7 +35,7 @@
 
 <div id="logoWrapper">
 
-<div id="logo"><a href="http://coq.inria.fr/" title="Home"><img src="http://coq.inria.fr/files/barron_logo.png" alt="Home"></a>
+<div id="logo"><a href="http://coq.inria.fr/" title="Home"><img src="http://coq.inria.fr/files/barron_logo.png" alt="Home" /></a>
 </div>
 <div id="siteName"><a href="http://coq.inria.fr/" title="Home">The Coq Proof Assistant</a>
 </div>
@@ -79,6 +79,8 @@
 
 </div>
 
+</div>
+
 <div id="footer">
 <div id="nav-footer">
   <ul class="links-menu-footer">
diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html
index b377396d..75b938f9 100644
--- a/doc/common/styles/html/simple/cover.html
+++ b/doc/common/styles/html/simple/cover.html
@@ -25,7 +25,7 @@
 <h1 style="font-weight:bold; font-size: 300%; line-height: 2ex">Reference Manual</h1>
 
 <h2 style="font-size: 120%">
-  Version 8.3<a name="text1"></a><a href="#note1"><sup><span style="font-size: 80%">1</span></sup></a></h2>
+  Version 8.2<a name="text1"></a><a href="#note1"><sup><span style="font-size: 80%">1</span></sup></a></h2>
 
 <br/><br/><br/><br/><br/><br/>
 <p><span style="text-align: center; font-size: 120%; ">The Coq Development Team</span></p>
@@ -35,7 +35,9 @@
 <div style="text-align: left; font-size: 80%; text-indent: 0pt">
 <ul style="list-style: none; margin-left: 0pt">
   <li>V7.x © INRIA 1999-2004</li>
-  <li>V8.x © INRIA 2004-2010</li>
+  <li>V8.0 © INRIA 2004-2006</li>
+  <li>V8.1 © INRIA 2006-2008</li>
+  <li>V8.2 © INRIA 2008-2009</li>
 </ul>
 
 <p style="text-indent: 0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p>
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/common/styles/html/simple/styles.hva b/doc/common/styles/html/simple/styles.hva
index a2d46f3e..76935cb1 100644
--- a/doc/common/styles/html/simple/styles.hva
+++ b/doc/common/styles/html/simple/styles.hva
@@ -1,7 +1,6 @@
 \renewcommand{\@meta}{
 \begin{rawhtml}
 <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
-<title>Reference Manual | The Coq Proof Assistant</title>
 
 <link rel="stylesheet" type="text/css" href="style.css">
 <link rel="stylesheet" type="text/css" href="coqdoc.css">
diff --git a/doc/common/title.tex b/doc/common/title.tex
index 38ec0e55..1dc52432 100755
--- a/doc/common/title.tex
+++ b/doc/common/title.tex
@@ -25,12 +25,12 @@
 The Coq Proof Assistant\\[12pt]
 #1\\[20pt]
 \Large\today\\[20pt]
-Version \coqversion%\footnote[1]{This research was partly supported by IST working group ``Types''}
+Version \coqversion\footnote[1]{This research was partly supported by IST working group ``Types''}
 
 \vspace{0pt plus .5fill}
 #2
 \par\vfill
-The Coq Development Team
+TypiCal Project (formerly LogiCal)
 
 \vspace*{15pt}
 \end{center}
@@ -45,7 +45,7 @@ V\coqversion, \today
 %END LATEX
 \copyright INRIA 1999-2004 ({\Coq} versions 7.x)
 
-\copyright INRIA 2004-2011 ({\Coq} versions 8.x)
+\copyright INRIA 2004-2009 ({\Coq} versions 8.x)
 
 #3
 \end{flushleft}
@@ -70,4 +70,3 @@ V\coqversion, \today
 % TeX-master: ""
 % End: 
 
-% $Id: title.tex 14641 2011-11-06 11:59:10Z herbelin $ 
diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex
index bd6f7dbf..c0f8c087 100644
--- a/doc/faq/FAQ.tex
+++ b/doc/faq/FAQ.tex
@@ -22,7 +22,6 @@
   \usepackage[dvips]{graphicx}
 \fi
 
-\input{../common/version.tex}
 %\input{../macros.tex}
 
 % Making hevea happy
@@ -134,7 +133,7 @@
 
 %%%%%%% Coq pour les nuls %%%%%%%
 
-\title{Coq Version {\coqversion} for the Clueless\\
+\title{Coq Version 8.3 for the Clueless\\
   \large(\protect\ref{lastquestion}
   \ Hints)
 }
@@ -166,7 +165,7 @@ proofs in \Coq. Since we are singularly short-minded, we wrote the
 answers we found on bits of papers to have them at hand whenever the
 situation occurs again. This is pretty much the result of that: a
 collection of tips one can refer to when proofs become intricate. Yes,
-this means we won't take the blame for the shortcomings of this
+it means we won't take the blame for the shortcomings of this
 FAQ. But if you want to contribute and send in your own question and
 answers, feel free to write to us\ldots
 
@@ -372,7 +371,7 @@ downloadable postscripts.
 
 \Question{Where can I find this FAQ on the web?}
 
-This FAQ is available online at \ahref{http://coq.inria.fr/faq}{\url{http://coq.inria.fr/faq}}.
+This FAQ is available online at \ahref{http://coq.inria.fr/doc/faq.html}{\url{http://coq.inria.fr/doc/faq.html}}.
 
 \Question{How can I submit suggestions / improvements / additions for this FAQ?}
 
@@ -380,20 +379,20 @@ This FAQ is unfinished (in the sense that there are some obvious
 sections that are missing). Please send contributions to Coq-Club.
 
 \Question{Is there any mailing list about {\Coq}?} 
-The main {\Coq} mailing list is \url{coq-club@inria.fr}, which
+The main {\Coq} mailing list is \url{coq-club@pauillac.inria.fr}, which
 broadcasts questions and suggestions about the implementation, the
 logical formalism or proof developments. See
-\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{https://sympa-roc.inria.fr/wws/info/coq-club}} for
+\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{http://pauillac.inria.fr/mailman/listinfo/coq-club}} for
 subscription. For bugs reports see question \ref{coqbug}.
 
 \Question{Where can I find an archive of the list?}
 The archives of the {\Coq} mailing list are available at
-\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{https://sympa-roc.inria.fr/wws/arc/coq-club}}.
+\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{http://coq.inria.fr/pipermail/coq-club}}.
 
 
 \Question{How can I be kept informed of new releases of {\Coq}?}
 
-New versions of {\Coq} are announced on the coq-club mailing list.
+New versions of {\Coq} are announced on the coq-club mailing list. If you only want to receive information about new releases, you can subscribe to {\Coq} on \ahref{http://freshmeat.net/projects/coq/}{\url{http://freshmeat.net/projects/coq/}}.
 
 
 \Question{Is there any book about {\Coq}?}
@@ -417,7 +416,7 @@ You can also find large developments using
 
 \Question{How can I report a bug?}\label{coqbug}
 
-You can use the web interface accessible at \ahref{http://coq.inria.fr/bugs}{\url{http://coq.inria.fr/bugs}}.
+You can use the web interface accessible at \ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link ``contacts''.
 
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -432,7 +431,7 @@ You can use the web interface accessible at \ahref{http://coq.inria.fr/bugs}{\ur
 The sources of {\Coq} can be found online in the tar.gz'ed packages
 (\ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link
 ``download''). Development sources can be accessed at
-\ahref{https://gforge.inria.fr/scm/?group_id=269}{\url{https://gforge.inria.fr/scm/?group_id=269}}
+\ahref{http://coq.gforge.inria.fr/}{\url{http://coq.gforge.inria.fr/}}
 
 \Question{On which platform is {\Coq} available?}
 Compiled binaries are available for Linux, MacOS X, and Windows. The
@@ -666,9 +665,10 @@ where both excluded-middle and the axiom of description are valid (see
 file \vfile{\LogicClassicalDescription}{ClassicalDescription} for a
 proof that excluded-middle and description implies the double negation
 of excluded-middle in {\Set} and file {\tt Hurkens\_Set.v} from the
-user contribution {\tt Rocq/PARADOXES} for a proof that
-impredicativity of {\Set} implies the simple negation of
-excluded-middle in {\Set}).
+user contribution {\tt Paradoxes} at
+\ahref{http://coq.inria.fr/contribs}{\url{http://coq.inria.fr/contribs}}
+for a proof that impredicativity of {\Set} implies the simple negation
+of excluded-middle in {\Set}).
 
 \Question{Is {\Type} impredicative?}
 
@@ -1509,7 +1509,7 @@ apply the elimination scheme using the \verb=using= option of
 
 The short answer : You should use {\texttt le\_lt\_dec n p} instead.\\
 
-That's right, you can't.
+The long answer: That's right, you can't.
 If you type for instance the following ``definition'':
 \begin{coq_eval}
 Reset Initial.
@@ -1627,7 +1627,7 @@ certified programs which need to compare natural numbers, and is not
 designed to compare quickly two numbers.
 
 Nevertheless, the \emph{extraction} of \texttt{le\_lt\_dec} towards 
-\emph{Ocaml} or \emph{Haskell}, is a reasonable program for comparing two
+\emph{OCaml} or \emph{Haskell}, is a reasonable program for comparing two
 natural numbers in Peano form in linear time.
 
 It is also possible to keep your boolean function as a decision procedure,
@@ -1700,7 +1700,7 @@ Lemma Rwf : well_founded R.
 \item Define the step function (which needs proofs that recursive
 calls are on smaller arguments).
 
-\begin{coq_example*}
+\begin{verbatim}
 Definition split (l : list nat) 
    : {l1: list nat | R l1 l} * {l2 : list nat | R l2 l}
    := (* ... *) .
@@ -1710,7 +1710,7 @@ Definition merge_step (l : list nat) (f: forall l':list nat, R l' l -> list nat)
   let (l1,H1) := lH1 in
   let (l2,H2) := lH2 in
   concat (f l1 H1) (f l2 H2).
-\end{coq_example*}
+\end{verbatim}
 
 \item Define the recursive function by fixpoint on the step function.
 
@@ -1890,13 +1890,15 @@ because ``$^2$'' is an iso-latin character. If you really want this kind of nota
 
 \Question{Why ``no associativity'' and  ``left associativity'' at the same level does not work?}
 
-Because we relie on camlp4 for syntactical analysis and camlp4 does not really implement no associativity. By default, non associative operators are defined as right associative.
+Because we relie on Camlp4 for syntactical analysis and Camlp4 does not really
+implement no associativity. By default, non associative operators are defined
+as right associative.
 
 
 
 \Question{How can I know the associativity associated with a level?}
 
-You can do ``Print Grammar constr'', and decode the output from camlp4, good luck !
+You can do ``Print Grammar constr'', and decode the output from Camlp4, good luck !
 
 \section{Modules}
 
@@ -1991,13 +1993,81 @@ todo
 \Question{How can I define static and dynamic code?}
 \fi
 
-\section{Tactics written in Ocaml}
+\section{Tactics written in OCaml}
 
 \Question{Can you show me an example of a tactic written in OCaml?}
 
-You have some examples of tactics written in Ocaml in the ``plugins'' directory of {\Coq} sources. 
-
-
+Have a look at the skeleton ``Hello World'' tactic from the next question. 
+You also have some examples of tactics written in OCaml in the ``plugins'' directory of {\Coq} sources. 
+
+\Question{Is there a skeleton of OCaml tactic I can reuse somewhere?}
+
+The following steps describe how to write a simplistic ``Hello world'' OCaml
+tactic. This takes the form of a dynamically loadable OCaml module, which will
+be invoked from the Coq toplevel.
+\begin{enumerate}
+\item In the \verb+plugins+ directory of the Coq source location, create a
+directory \verb+hello+. Proceed to create a grammar and OCaml file, respectively
+\verb+plugins/hello/g_hello.ml4+ and \verb+plugins/hello/coq_hello.ml+,
+containing:
+  \begin{itemize}
+  \item in \verb+g_hello.ml4+:
+\begin{verbatim}
+(*i camlp4deps: "parsing/grammar.cma" i*)
+TACTIC EXTEND Hello
+| [ "hello" ] -> [ Coq_hello.printHello ]
+END
+\end{verbatim}
+  \item in \verb+coq_hello.ml+:
+\begin{verbatim}
+let printHello gl =
+Tacticals.tclIDTAC_MESSAGE (Pp.str "Hello world") gl
+  \end{verbatim}
+  \end{itemize}
+\item Create a file \verb+plugins/hello/hello_plugin.mllib+, containing the
+names of the OCaml modules bundled in the dynamic library:
+\begin{verbatim}
+Coq_hello
+G_hello
+\end{verbatim}
+\item Append the following lines in \verb+plugins/plugins{byte,opt}.itarget+:
+\begin{itemize}
+  \item in \verb+pluginsopt.itarget+:
+\begin{verbatim}
+hello/hello_plugin.cmxa
+\end{verbatim}
+  \item in \verb+pluginsbyte.itarget+:
+\begin{verbatim}
+hello/hello_plugin.cma
+\end{verbatim}
+\end{itemize}
+\item In the root directory of the Coq source location, modify the file
+\verb+Makefile.common+:
+  \begin{itemize}
+  \item add \verb+hello+ to the \verb+SRCDIR+ definition (second argument of the
+  \verb+addprefix+ function);
+  \item in the section ``Object and Source files'', add \verb+HELLOCMA:=plugins/hello/hello_plugin.cma+;
+  \item add \verb+$(HELLOCMA)+ to the \verb+PLUGINSCMA+ definition.
+  \end{itemize}
+\item Modify the file \verb+Makefile.build+, adding in section ``3) plugins'' the
+line:
+\begin{verbatim}
+hello: $(HELLOCMA)
+\end{verbatim}
+\item From the command line, run \verb+make hello+, then \verb+make plugins/hello/hello_plugin.cmxs+.
+\end{enumerate}
+The call to the tactic \verb+hello+ from a Coq script has to be preceded by
+\verb+Declare ML Module "hello_plugin"+, which will load the dynamic object
+\verb+hello_plugin.cmxs+. For instance:
+\begin{verbatim}
+Declare ML Module "hello_plugin".
+Variable A:Prop.
+Goal A-> A.
+Proof.
+hello.
+auto.
+Qed.
+\end{verbatim}
 
 
 \section{Case studies}
@@ -2238,7 +2308,8 @@ You can use this bibtex entry:
 @Manual{Coq:manual,
   title =        {The Coq proof assistant reference manual},
   author =       {\mbox{The Coq development team}},
-  note =         {Version 8.3},
+  organization = {LogiCal Project},
+  note =         {Version 8.2},
   year =         {2009},
   url =          "http://coq.inria.fr"
 }
@@ -2276,8 +2347,8 @@ Depending on your configuration, use either one of these two methods
 \begin{itemize}
 
 \item Insert \texttt{gtk-key-theme-name = "Emacs"}
-    in your \texttt{.coqide-gtk2rc} file. It may be in the current dir
-    or in \verb#$HOME# dir. This is done by default.
+    in your \texttt{coqide-gtk2rc} file. It should be in
+    \verb#$XDG_CONFIG_DIRS/coq# dir. This is done by default.
 
 \item If in Gnome, run the gnome configuration editor (\texttt{gconf-editor})
 and set key \texttt{gtk-key-theme} to \texttt{Emacs} in the category
@@ -2323,21 +2394,32 @@ pretty simple notations.
 	2200 is the hexadecimal code for forall in unicode charts and is encoded as 	
 	in UTF-8.
 	2203 is for exists. See \ahref{http://www.unicode.org}{\url{http://www.unicode.org}} for more codes.
-\item Second solution: rebind \verb#<AltGr>a# to forall and \verb#<AltGr>e# to exists. 
-	Under X11, you need to use something like
+\item Second solution: rebind \verb#<AltGr>a# to forall and \verb#<AltGr>e# to exists.
+
+       Under X11, one can add those lines in the file ~/.xmodmaprc :
+
 \begin{verbatim}
-		xmodmap -e "keycode  24 = a A F13 F13" 
-		xmodmap -e "keycode  26 = e E F14 F14"
+! forall
+keycode  24 = a A a A U2200 NoSymbol U2200 NoSymbol
+! exists
+keycode  26 = e E e E U2203 NoSymbol U2203 NoSymbol
 \end{verbatim}
-	and then to add   
+and then run xmodmap ~/.xmodmaprc.
+
+	Alternatively, if your version of \verb=xmodmap= does not support unicode, you need to use something like
 \begin{verbatim}
-		bind "F13" {"insert-at-cursor" ("")}
-		bind "F14" {"insert-at-cursor" ("")}
+xmodmap -e "keycode  24 = a A F13 F13"
+xmodmap -e "keycode  26 = e E F14 F14"
 \end{verbatim}
-	to your "binding "text"" section in \verb#.coqiderc-gtk2rc.#
-	The strange ("") argument is the UTF-8 encoding for
-	0x2200. 
-	You can compute these encodings using the lablgtk2 toplevel with 
+	and then to add
+
+\verb=bind "F13" {"insert-at-cursor" ("=$\forall$\verb=")}=\\
+\verb=bind "F14" {"insert-at-cursor" ("=$\exists$\verb=")}=
+
+	to your "binding "text"" section in \verb#coqiderc-gtk2rc#.
+	The last arguments to {\tt bind} between "" are
+        the UTF-8 encodings for 0x2200 and 0x2203.
+	You can compute these encodings using the lablgtk2 toplevel with
 \begin{verbatim}		
 Glib.Utf8.from_unichar 0x2200;;
 \end{verbatim}
@@ -2345,17 +2427,11 @@ Glib.Utf8.from_unichar 0x2200;;
 	do not need .
 \end{itemize}
 
-\Question{How to build a custom {\CoqIde} with user ml code?}
- Use 
-	coqmktop -ide -byte m1.cmo...mi.cmo
-    or 
-	coqmktop -ide -opt m1.cmx...mi.cmx
-
 \Question{How to customize the shortcuts for menus?}
  Two solutions are offered:
 \begin{itemize}
-\item Edit \$HOME/.coqide.keys by hand or
-\item Add "gtk-can-change-accels = 1" in your .coqide-gtk2rc file. Then
+\item Edit \verb+$XDG_CONFIG_HOME/coq/coqide.keys+ (which is usually \verb+$HOME/.config/coq/coqide.keys+) by hand or
+\item Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then
     from \CoqIde, you may select a menu entry and press the desired 
     shortcut. 
 \end{itemize}
@@ -2375,9 +2451,9 @@ Glib.Utf8.from_unichar 0x2200;;
 Some users may experiment problems with unwanted automatic
 templates while using Coqide. This is due to a change in the
 modifiers keys available through GTK. The straightest way to get
-rid of the problem is to edit by hand your .coqiderc (either
-\verb|/home/<user>/.coqiderc| under Linux, or \\
-\verb|C:\Documents and Settings\<user>\.coqiderc| under Windows) 
+rid of the problem is to edit by hand your coqiderc (either
+\verb|/home/<user>/.config/coq/coqiderc| under Linux, or \\
+\verb|C:\Documents and Settings\<user>\.config\coq\coqiderc| under Windows) 
     and replace any occurence of \texttt{MOD4} by \texttt{MOD1}.
 
 
diff --git a/doc/faq/fk.bib b/doc/faq/fk.bib
index 976b36b0..d41ab7f0 100644
--- a/doc/faq/fk.bib
+++ b/doc/faq/fk.bib
@@ -1117,9 +1117,10 @@ cedures.},
 @Manual{Coq:manual,
   title =        {The Coq proof assistant reference manual},
   author =       {\mbox{The Coq development team}},
-  note =         {Version 8.3},
-  year =         {2010},
-  url =          "http://coq.inria.fr/doc"
+  organization = {LogiCal Project},
+  note =         {Version 8.0},
+  year =         {2004},
+  url =          "http://coq.inria.fr"
 }
 
 @string{jfp = "Journal of Functional Programming"}
diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex
index f427609f..20ff649a 100644
--- a/doc/refman/Classes.tex
+++ b/doc/refman/Classes.tex
@@ -10,7 +10,7 @@
 \label{typeclasses}
 
 \begin{flushleft}
-  \em The status of Type Classes is experimental.
+  \em The status of Type Classes is (extremely) experimental.
 \end{flushleft}
 
 This chapter presents a quick reference of the commands related to type
@@ -128,7 +128,9 @@ particular support for type classes:
   methods. In the example above, \texttt{A} and \texttt{eqa} should be
   set maximally implicit.
 \item They support implicit quantification on partialy applied type
-  classes.
+  classes (\S \ref{implicit-generalization}).
+  Any argument not given as part of a type class binder will be
+  automatically generalized.
 \item They also support implicit quantification on superclasses
   (\S \ref{classes:superclasses})
 \end{itemize}
@@ -141,19 +143,6 @@ Definition neqb_impl `{eqa : EqDec A} (x y : A) := negb (eqb x y).
 Here \texttt{A} is implicitly generalized, and the resulting function
 is equivalent to the one above.
 
-The parsing of generalized type-class binders is different from regular
-binders:
-\begin{itemize}
-\item Implicit arguments of the class type are ignored.
-\item Superclasses arguments are automatically generalized.
-\item Any remaining arguments not given as part of a type class binder
-  will be automatically generalized. In other words, the rightmost
-  parameters are automatically generalized if not mentionned.
-\end{itemize}
-
-One can switch off this special treatment using the $!$ mark in front of
-the class name (see example below).
-
 \asection{Parameterized Instances}
 
 One can declare parameterized instances as in \Haskell simply by giving
@@ -242,9 +231,9 @@ Definition le_eqb `{Ord A} (x y : A) := andb (le x y) (le y x).
 \end{coq_example*}
 
 In some cases, to be able to specify sharing of structures, one may want to give
-explicitly the superclasses. It is possible to do it directly in regular
-generalized binders, and using the \texttt{!} modifier in class
-binders. For example:
+explicitly the superclasses. It is is possible to do it directly in regular
+binders, and using the \texttt{!} modifier in class binders. For
+example:
 \begin{coq_example*}
 Definition lt `{eqa : EqDec A, ! Ord eqa} (x y : A) := 
   andb (le x y) (neqb x y).
@@ -378,6 +367,12 @@ instances at the end of sections, or declaring structure projections as
 instances. This is almost equivalent to {\tt Hint Resolve {\ident} :
   typeclass\_instances}.
 
+\begin{Variants}
+\item {\tt Existing Instances {\ident}$_1$ \ldots {\ident}$_n$}
+  \comindex{Existing Instances}
+  With this command, several existing instances can be declared at once.
+\end{Variants}
+
 \subsection{\tt Context {\binder$_1$ \ldots \binder$_n$}}
 \comindex{Context}
 \label{Context}
diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex
index cc9cf5c8..ee289ee7 100644
--- a/doc/refman/Extraction.tex
+++ b/doc/refman/Extraction.tex
@@ -469,9 +469,9 @@ mandatory. It only enhances readability of extracted code.
 You can then copy-paste the output to a file {\tt euclid.ml} or let 
 \Coq\ do it for you with the following command: 
 
-\begin{coq_example}
+\begin{verbatim}
 Extraction "euclid" eucl_dev.
-\end{coq_example}
+\end{verbatim}
 
 Let us play the resulting program:
 
@@ -543,8 +543,6 @@ Some pathological examples of extraction are grouped in the file
  After compilation those two examples run nonetheless,
  thanks to the correction of the extraction~\cite{Let02}. 
 
-% $Id: Extraction.tex 14575 2011-10-18 15:49:01Z letouzey $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/Micromega.tex b/doc/refman/Micromega.tex
index 2fe7c2f7..5f9ed443 100644
--- a/doc/refman/Micromega.tex
+++ b/doc/refman/Micromega.tex
@@ -1,33 +1,24 @@
-\achapter{Micromega : tactics for solving arithmetics goals over ordered rings}
+\achapter{Micromega : tactics for solving arithmetic goals over ordered rings}
 \aauthor{Frédéric Besson and Evgeny Makarov}
 \newtheorem{theorem}{Theorem}
 
-For using the tactics out-of-the-box, read Section~\ref{sec:psatz-hurry}.
-%
-Section~\ref{sec:psatz-back} presents some background explaining the proof principle for solving polynomials goals.
-%
-Section~\ref{sec:lia} explains how to get a complete procedure for linear integer arithmetic.
-
-\asection{The {\tt psatz} tactic in a hurry}
-\tacindex{psatz}
+ 
+\asection{Short description of the tactics}
+\tacindex{psatz}  \tacindex{lra} 
 \label{sec:psatz-hurry}
-Load the {\tt Psatz} module ({\tt Require Psatz}.).  This module defines the tactics:
-{\tt lia}, {\tt psatzl D}, %{\tt sos D} 
-and {\tt psatz D n} where {\tt D} is {\tt Z}, {\tt Q} or {\tt R} and {\tt n} is an optional integer limiting the proof search depth.
-  % 
-  \begin{itemize}
-  \item The {\tt psatzl} tactic solves linear goals using an embedded (naive) linear programming prover \emph{i.e.},
-    fourier elimination.
-  \item The {\tt psatz} tactic solves polynomial goals using John Harrison's Hol light driver to the external prover {\tt cspd}\footnote{Sources and binaries can be found at \url{https://projects.coin-or.org/Csdp}}. Note that the {\tt csdp} driver is generating 
-    a \emph{proof cache} thus allowing to rerun scripts even without {\tt csdp}. 
-  \item The {\tt lia} (linear integer arithmetic) tactic is specialised to solve linear goals over $\mathbb{Z}$.
-    It extends {\tt psatzl Z} and exploits the discreetness of $\mathbb{Z}$.
-%%   \item The {\tt sos} tactic is another Hol light driver to the {\tt csdp} prover.  In theory, it is less general than
-%%     {\tt psatz}. In practice, even when {\tt psatz} fails, it can be worth a try -- see
-%%     Section~\ref{sec:psatz-back} for details.
-  \end{itemize}
-
-These tactics solve propositional formulas parameterised by atomic arithmetics expressions
+The {\tt Psatz} module ({\tt Require Psatz.}) gives access to several tactics for solving arithmetic goals over
+ {\tt Z}\footnote{Support for {\tt nat} and {\tt N} is obtained by pre-processing the goal with the {\tt zify} tactic.}, {\tt Q} and {\tt R}:
+\begin{itemize}
+\item {\tt lia} is a decision procedure for linear integer arithmetic (see Section~\ref{sec:lia});
+\item {\tt nia} is an incomplete proof procedure for integer non-linear arithmetic (see Section~\ref{sec:nia});
+\item {\tt lra} is a decision procedure for linear (real or rational) arithmetic goals (see Section~\ref{sec:lra});
+\item {\tt psatz D n} where {\tt D} is {\tt Z}, {\tt Q} or {\tt R} and {\tt n} is an optional integer limiting the proof search depth is
+is an incomplete proof procedure for non-linear arithmetic. It is based on John Harrison's Hol light driver to the external prover {\tt cspd}\footnote{Sources and binaries can be found at \url{https://projects.coin-or.org/Csdp}}. 
+   Note that the {\tt csdp} driver is generating 
+   a \emph{proof cache} thus allowing to rerun scripts even without {\tt csdp} (see Section~\ref{sec:psatz}). 
+\end{itemize}
+
+The tactics solve propositional formulas parameterised by atomic arithmetics expressions
 interpreted over a domain $D \in \{\mathbb{Z}, \mathbb{Q}, \mathbb{R} \}$.
 The syntax of the formulas is the following:
 \[
@@ -39,21 +30,29 @@ The syntax of the formulas is the following:
  \]
  where $c$ is a numeric constant, $x\in D$ is a numeric variable and the operators $-$, $+$, $\times$, are
  respectively subtraction, addition, product, $p \verb!^!n $ is exponentiation by a constant $n$, $P$ is an
- arbitrary proposition. %that is mostly ignored.
-%%
-%% Over $\mathbb{Z}$, $c$ is an integer ($c \in \mathtt{Z}$), over $\mathbb{Q}$, $c$ is 
-The following table details for each domain $D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}$ the range of constants $c$ and exponent $n$.
-\[
-\begin{array}{|c|c|c|c|}
-  \hline
-  &\mathbb{Z} & \mathbb{Q} & \mathbb{R} \\
-  \hline
-  c &\mathtt{Z} & \mathtt{Q} & \{R1, R0\} \\
-  \hline
-  n &\mathtt{Z} & \mathtt{Z} & \mathtt{nat}\\
-  \hline
-\end{array}
-\]
+ arbitrary proposition.
+ %
+ For {\tt Q}, equality is not leibnitz equality {\tt =} but the equality of rationals {\tt ==}.
+
+For {\tt Z} (resp. {\tt Q} ), $c$ ranges over integer constants (resp. rational constants).
+%% The following table details for each domain $D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}$ the range of constants $c$ and exponent $n$.
+%% \[
+%% \begin{array}{|c|c|c|c|}
+%%   \hline
+%%   &\mathbb{Z} & \mathbb{Q} & \mathbb{R} \\
+%%   \hline
+%%   c &\mathtt{Z} & \mathtt{Q} & (see below) \\
+%%   \hline
+%%   n &\mathtt{Z} & \mathtt{Z} & \mathtt{nat}\\
+%%   \hline
+%% \end{array}
+%% \]
+For {\tt R}, the tactic recognises as real constants the following expressions:
+\begin{verbatim}
+c ::= R0 | R1 | Rmul(c,c) | Rplus(c,c) | Rminus(c,c) | IZR z | IQR q | Rdiv(c,c) | Rinv c
+\end{verbatim}
+where ${\tt z}$ is a constant in {\tt Z} and {\tt q} is a constant in {\tt Q}.
+This includes integer constants written using the decimal notation \emph{i.e.,} {\tt c\%R}.
 
 \asection{\emph{Positivstellensatz} refutations}
 \label{sec:psatz-back}
@@ -87,6 +86,26 @@ For each conjunct $C_i$, the tactic calls a oracle which searches for $-1$ withi
 Upon success, the oracle returns a \emph{cone expression} that is normalised by the {\tt ring} tactic (see chapter~\ref{ring}) and checked to be
 $-1$.
 
+
+\asection{{\tt lra} : a decision procedure for linear real and rational arithmetic}
+\label{sec:lra}
+The {\tt lra} tactic is searching for \emph{linear} refutations using
+Fourier elimination\footnote{More efficient linear programming techniques could equally be employed}.  As a
+result, this tactic explores a subset of the $Cone$ defined as:
+\[
+LinCone(S) =\left\{ \left. \sum_{p \in S} \alpha_p \times p\ \right|\ \alpha_p \mbox{ are positive constants} \right\}
+\]
+The deductive power of {\tt lra} is the combined deductive power of {\tt ring\_simplify} and {\tt fourier}.
+%
+There is also an overlap with the {\tt field} tactic {\emph e.g.}, {\tt x = 10 * x / 10} is solved by {\tt lra}.
+
+\asection{ {\tt psatz} : a proof procedure for non-linear arithmetic}
+\label{sec:psatz}
+The {\tt psatz} tactic explores the $Cone$ by increasing degrees -- hence the depth parameter $n$.
+In theory, such a proof search is complete -- if the goal is provable the search eventually stops.
+Unfortunately, the external oracle is using numeric (approximate) optimisation techniques that might miss a
+refutation. 
+
 To illustrate the working of the tactic, consider we wish to prove the following Coq goal.\\
 \begin{coq_eval}
   Require Import ZArith Psatz.
@@ -104,30 +123,21 @@ expression belongs to $Cone(\{-x^2, x -1\})$.  Moreover, by running {\tt ring} w
 Theorem~\ref{thm:psatz}, the goal is valid.
 %
 
-\paragraph{The {\tt psatzl} tactic} is searching for \emph{linear} refutations using a fourier
-elimination\footnote{More efficient linear programming techniques could equally be employed}.
-As a result, this tactic explore a subset of the $Cone$  defined as:
-\[
-LinCone(S) =\left\{ \left. \sum_{p \in S} \alpha_p \times p\ \right|\ \alpha_p \mbox{ are positive constants} \right\}
-\]
-Basically, the deductive power of {\tt psatzl} is the combined deductive power of {\tt ring\_simplify} and {\tt fourier}.
-
-\paragraph{The {\tt psatz} tactic} explores the $Cone$ by increasing degrees -- hence the depth parameter $n$.
-In theory, such a proof search is complete -- if the goal is provable the search eventually stops.
-Unfortunately, the external oracle is using numeric (approximate) optimisation techniques that might miss a
-refutation. 
-
 %% \paragraph{The {\tt sos} tactic} -- where {\tt sos} stands for \emph{sum of squares} -- tries to prove that a
 %% single polynomial $p$ is positive by expressing it as a sum of squares \emph{i.e.,} $\sum_{i\in S} p_i^2$.
 %% This amounts to searching for $p$ in the cone without generators \emph{i.e.}, $Cone(\{\})$.
 %
 
-\asection{ {\tt lia} : the linear integer arithmetic tactic }
+\asection{ {\tt lia} : a tactic for linear integer arithmetic }
 \tacindex{lia}
 \label{sec:lia}
 
 The tactic {\tt lia} offers an alternative to the {\tt omega} and {\tt romega} tactic (see
-Chapter~\ref{OmegaChapter}). It solves goals that {\tt omega} and {\tt romega} do not solve, such as the
+Chapter~\ref{OmegaChapter}). 
+%
+Rougthly speaking, the deductive power of {\tt lia} is the combined deductive power of {\tt ring\_simplify} and {\tt omega}.
+%
+However, it solves linear goals that {\tt omega} and {\tt romega} do not solve, such as the
 following so-called \emph{omega nightmare}~\cite{TheOmegaPaper}.
 \begin{coq_example*}
   Goal forall x y, 
@@ -153,7 +163,7 @@ The canonical exemple is {\tt 2 * x = 1 -> False} which is a theorem of $\mathbb
 To remedy this weakness, the {\tt lia} tactic is using recursively a combination of:
 %
 \begin{itemize}
-\item linear \emph{positivstellensatz} refutations \emph{i.e.}, {\tt psatzl Z};
+\item linear \emph{positivstellensatz} refutations;
 \item cutting plane proofs;
 \item case split.
 \end{itemize}
@@ -189,7 +199,21 @@ Our current oracle tries to find an expression $e$ with a small range $[c_1,c_2]
 We generate $c_2 - c_1$ subgoals which contexts are enriched with an equation $e = i$ for $i \in [c_1,c_2]$ and
 recursively search for a proof.
 
-% This technique is used to solve so-called \emph{Omega nightmare}
+\asection{ {\tt nia} : a proof procedure for non-linear integer arithmetic}
+\tacindex{nia}
+\label{sec:nia}
+The {\tt nia} tactic is an {\emph experimental} proof procedure for non-linear  integer arithmetic.
+%
+The tactic performs a limited amount of non-linear reasoning before running the
+linear prover of {\tt lia}.
+This pre-processing does the following:
+\begin{itemize}
+\item If the context contains an arithmetic expression of the form $e[x^2]$ where $x$ is a
+  monomial, the context is enriched with $x^2\ge 0$;
+\item For all pairs of hypotheses $e_1\ge 0$, $e_2 \ge 0$, the context is enriched with $e_1 \times e_2 \ge 0$.
+\end{itemize}
+After pre-processing, the linear prover of {\tt lia} is searching for a proof by abstracting monomials by variables.
+
 
 
 %%% Local Variables: 
diff --git a/doc/refman/Nsatz.tex b/doc/refman/Nsatz.tex
index 794e461f..3ecc7e65 100644
--- a/doc/refman/Nsatz.tex
+++ b/doc/refman/Nsatz.tex
@@ -54,19 +54,17 @@ performed using {\em Type Classes}
 (see \ref{typeclasses})
 .
 
-The \texttt{Nsatz} module defines the generic tactic
-\texttt{nsatz}, which uses the low-level tactic \texttt{nsatz\_domainpv}: \\
+The \texttt{Nsatz} module defines the tactic
+\texttt{nsatz}, which can be used without arguments: \\
 \vspace*{3mm}
-\texttt{nsatz\_domainpv pretac rmax strategy lparam lvar simpltac domain}
-
+\texttt{nsatz}\\
+or with the syntax: \\
+\vspace*{3mm}
+\texttt{nsatz with radicalmax:={\em number}\%N strategy:={\em number}\%Z parameters:={\em list of variables} variables:={\em list of variables}}\\
 where:
 
 \begin{itemize}
-    \item \texttt{pretac} is a tactic depending on the ring A; its goal is to
-make apparent the generic operations of a domain (ring\_eq, ring\_plus, etc),
-both in the goal and the hypotheses; it is executed first. By default it is \texttt{ltac:idtac}.
-
-    \item \texttt{rmax} is a bound when for searching r s.t.$c (P-Q)^r =
+    \item \texttt{radicalmax} is a bound when for searching r s.t.$c (P-Q)^r =
 \sum_{i=1..s} S_i (P_i - Q_i)$
 	
     \item \texttt{strategy} gives the order on variables $X_1,...X_n$ and
@@ -80,7 +78,7 @@ the strategy used in Buchberger algorithm (see
 	        \item   strategy = 3: pure lexicographic order and sugar strategy.
 	\end{itemize}
 
-	\item \texttt{lparam} is the list of variables
+	\item \texttt{parameters} is the list of variables
 $X_{i_1},\ldots,X_{i_k}$  among $X_1,...,X_n$ which are considered as
    parameters: computation will be performed with rational fractions in these
    variables, i.e. polynomials are considered with coefficients in
@@ -88,21 +86,14 @@ $R(X_{i_1},\ldots,X_{i_k})$. In this case, the coefficient $c$ can be a non
 constant polynomial in $X_{i_1},\ldots,X_{i_k}$, and the tactic produces a goal
 which states that $c$ is not zero.
 
-	\item \texttt{lvar} is the list of the variables
-in the decreasing order in which they will be used in Buchberger algorithm. If \texttt{lvar} = {(@nil
+	\item \texttt{variables} is the list of the variables
+in the decreasing order in which they will be used in Buchberger algorithm. If \texttt{variables} = {(@nil
 R)}, then \texttt{lvar} is replaced by all the variables which are not in
-lparam.
-
-    \item \texttt{simpltac} is a tactic depending on the ring A; its goal is to
-simplify goals and make apparent the generic operations of a domain after
-simplifications. By default it is \texttt{ltac:simpl}.
-
- \item \texttt{domain} is the object of type Domain representing A, its
-operations and properties of integral domain.
+parameters.
 
 \end{itemize}
 
-See file \texttt{Nsatz.v} for examples.
+See file \texttt{Nsatz.v} for many examples, specially in geometry.
 
 %%% Local Variables: 
 %%% mode: latex
diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex
index b41014ab..96073d71 100644
--- a/doc/refman/Program.tex
+++ b/doc/refman/Program.tex
@@ -3,11 +3,7 @@
 \aauthor{Matthieu Sozeau}
 \index{Program}
 
-\begin{flushleft}
-  \em The status of \Program\ is experimental.
-\end{flushleft}
-
-We present here the new \Program\ tactic commands, used to build certified
+We present here the \Program\ tactic commands, used to build certified
 \Coq\ programs, elaborating them from their algorithmic skeleton and a
 rich specification \cite{Sozeau06}. It can be sought of as a dual of extraction
 (see Chapter~\ref{Extraction}). The goal of \Program~is to program as in a regular
@@ -73,6 +69,8 @@ will be first rewrote to:
   works with the previous mechanism.
 \end{itemize}
 
+\subsection{Syntactic control over equalities}
+\label{ProgramSyntax}
 To give more control over the generation of equalities, the typechecker will
 fall back directly to \Coq's usual typing of dependent pattern-matching
 if a {\tt return} or {\tt in} clause is specified. Likewise,
@@ -89,9 +87,18 @@ Program Definition id (n : nat) : { x : nat | x = n } :=
   else S (pred n).
 \end{coq_example}
 
-Finally, the let tupling construct {\tt let (x1, ..., xn) := t in b}
+The let tupling construct {\tt let (x1, ..., xn) := t in b}
 does not produce an equality, contrary to the let pattern construct 
 {\tt let '(x1, ..., xn) := t in b}.
+Also, {\tt {\term}:>} explicitly asks the system to coerce {\tt \term} to its
+support type. It can be useful in notations, for example:
+\begin{coq_example}
+Notation " x `= y " := (@eq _ (x :>) (y :>)) (only parsing).
+\end{coq_example}
+
+This notation denotes equality on subset types using equality on their
+support types, avoiding uses of proof-irrelevance that would come up
+when reasoning with equality on the subset types themselves. 
 
 The next two commands are similar to their standard counterparts
 Definition (see Section~\ref{Basic-definitions}) and Fixpoint (see Section~\ref{Fixpoint}) in that
diff --git a/doc/refman/RefMan-add.tex b/doc/refman/RefMan-add.tex
index 9d7ca7b1..2094c9d2 100644
--- a/doc/refman/RefMan-add.tex
+++ b/doc/refman/RefMan-add.tex
@@ -51,8 +51,6 @@ can be found in the document {\tt Polynom.dvi}
 %anomalous behavior, please check first whether it has been already
 %reported in this document.
 
-% $Id: RefMan-add.tex 10061 2007-08-08 13:14:05Z msozeau $ 
-
 
 %%% Local Variables: 
 %%% mode: latex
diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex
index dab164e7..9660a04b 100644
--- a/doc/refman/RefMan-cic.tex
+++ b/doc/refman/RefMan-cic.tex
@@ -1706,8 +1706,6 @@ impredicative system for sort \Set{} become~:
      
 
 
-% $Id: RefMan-cic.tex 13029 2010-05-28 11:49:12Z herbelin $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-coi.tex b/doc/refman/RefMan-coi.tex
index b0f0212e..619a8ee1 100644
--- a/doc/refman/RefMan-coi.tex
+++ b/doc/refman/RefMan-coi.tex
@@ -403,4 +403,3 @@ See \cite{Gimenez95b} for a complete description about this development.
 
 %\end{document}
 
-% $Id: RefMan-coi.tex 10421 2008-01-05 14:06:51Z herbelin $ 
diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex
index 13a4219a..a40c210e 100644
--- a/doc/refman/RefMan-com.tex
+++ b/doc/refman/RefMan-com.tex
@@ -34,11 +34,6 @@ toplevel (to allow the dynamic link of tactics).  You can switch to
 the Caml toplevel with the command \verb!Drop.!, and come back to the
 \Coq~toplevel with the command \verb!Toplevel.loop();;!.
 
-% The command \verb!coqtop -searchisos! runs the search tool {\sf
-%   Coq\_SearchIsos} (see Section~\ref{coqsearchisos},
-% page~\pageref{coqsearchisos}) and, as the \Coq~system, can be combined
-% with the option \verb!-opt!.
-
 \section{Batch compilation ({\tt coqc})}
 The {\tt coqc} command takes a name {\em file} as argument.  Then it
 looks for a vernacular file named {\em file}{\tt .v}, and tries to
@@ -58,12 +53,15 @@ native-code versions of the system.
 \section[Resource file]{Resource file\index{Resource file}}
 
 When \Coq\ is launched, with either {\tt coqtop} or {\tt coqc}, the
-resource file \verb:$HOME/.coqrc.7.0: is loaded, where \verb:$HOME: is
-the home directory of the user.  If this file is not found, then the
-file \verb:$HOME/.coqrc: is searched. You can also specify an
+resource file \verb:$XDG_CONFIG_HOME/coq/coqrc.xxx: is loaded, where
+\verb:$XDG_CONFIG_HOME: is the configuration directory of the user (by
+default its home directory \verb!/.config! and \verb:xxx: is the version
+number (e.g. 8.3).  If this file is not found, then the file
+\verb:$XDG_CONFIG_HOME/coqrc: is searched. You can also specify an
 arbitrary name for the resource file (see option \verb:-init-file:
-below), or the name of another user to load the resource file of
-someone else (see option \verb:-user:).
+below), or the name of another user to load the resource file of someone
+else (see option \verb:-user:).
+
 
 This file may contain, for instance, \verb:Add LoadPath: commands to add
 directories to the load path of \Coq.
@@ -73,9 +71,11 @@ option \verb:-q:.
 \section[Environment variables]{Environment variables\label{EnvVariables}
 \index{Environment variables}}
 
-There are three environment variables used by the \Coq\ system.
+There are four environment variables used by the \Coq\ system.
 \verb:$COQBIN: for the directory where the binaries are,
-\verb:$COQLIB: for the directory where the standard library is, and 
+\verb:$COQLIB: for the directory where the standard library is,
+\verb:$COQPATH: for a list of directories seperated by \verb|:|
+(\verb|;| on windows) to add to the load path, and
 \verb:$COQTOP: for the directory of the sources. The latter is useful
 only for developers that are writing their own tactics and are using
 \texttt{coq\_makefile} (see \ref{Makefile}). If \verb:$COQBIN: or
@@ -83,6 +83,11 @@ only for developers that are writing their own tactics and are using
 (defined at installation time). So these variables are useful only if
 you move the \Coq\ binaries and library after installation.
 
+Coq will also honor \verb:$XDG_DATA_HOME: and \verb:$XDG_DATA_DIRS: (see
+\url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}).
+Coq adds \verb:${XDG_DATA_HOME}/coq: and \verb:${XDG_DATA_DIRS}/coq: to its
+search path.
+
 \section[Options]{Options\index{Options of the command line}
 \label{vmoption}
 \label{coqoptions}}
@@ -173,11 +178,6 @@ The following command-line options are recognized by the commands {\tt
 
   Cause \Coq~not to load the resource file.
 
-\item[{\tt -user} {\em username}]\ 
-
-  Take resource file of user {\em username} (that is 
-  \verb+~+{\em username}{\tt /.coqrc.7.0}) instead of yours.
-
 \item[{\tt -load-ml-source} {\em file}]\ 
 
   Load the Caml source file {\em file}.
@@ -263,9 +263,25 @@ The following command-line options are recognized by the commands {\tt
  
 \item[{\tt -dont-load-proofs}]\ 
 
-  This avoids loading in memory the proofs of opaque theorems
-  resulting in a smaller memory requirement and faster compilation;
-  warning: this invalidates some features such as the extraction tool.
+  Warning: this is an unsafe mode.
+  Instead of loading in memory the proofs of opaque theorems, they are
+  treated as axioms. This results in smaller memory requirement and
+  faster compilation, but the behavior of the system might slightly change
+  (for instance during module subtyping), and some features won't be
+  available (for example {\tt Print Assumptions}).
+
+\item[{\tt -lazy-load-proofs}]\
+
+  This is the default behavior. Proofs of opaque theorems aren't
+  loaded immediately in memory, but only when necessary, for instance
+  during some module subtyping or {\tt Print Assumptions}. This should be
+  almost as fast and efficient as {\tt -dont-load-proofs}, with none
+  of its drawbacks.
+
+\item[{\tt -force-load-proofs}]\
+
+  Proofs of opaque theorems are loaded in memory as soon as the
+  corresponding {\tt Require} is done. This used to be Coq's default behavior.
 
 \item[{\tt -vm}]\ 
 
@@ -376,8 +392,6 @@ makes more disk access. It is also less secure since an attacker might
 have replaced the compiled library $A$ after it has been read by the
 first command, but before it has been read by the second command.
 
-% $Id: RefMan-com.tex 12443 2009-10-29 16:17:29Z gmelquio $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex
index c0e578fe..2da5bec1 100644
--- a/doc/refman/RefMan-ext.tex
+++ b/doc/refman/RefMan-ext.tex
@@ -200,6 +200,20 @@ Definition b := {| x := 5; y := 3 |}.
 Definition c := {| y := 3; x := 5 |}.
 \end{coq_example}
 
+This syntax can be disabled globally for printing by
+\begin{quote}
+{\tt Unset Printing Records.}
+\end{quote}
+For a given type, one can override this using either
+\begin{quote}
+{\tt Add Printing Record {\ident}.}
+\end{quote}
+to get record syntax or
+\begin{quote}
+{\tt Add Printing Constructor {\ident}.}
+\end{quote}
+to get constructor syntax.
+
 This syntax can also be used for pattern matching.
 
 \begin{coq_example}
@@ -675,7 +689,15 @@ Function plus (n m : nat) {struct n} : nat :=
 \paragraph[Limitations]{Limitations\label{sec:Function-limitations}}
 \term$_0$ must be build as a \emph{pure pattern-matching tree}
 (\texttt{match...with}) with applications only \emph{at the end} of
-each branch.  For now dependent cases are not treated.
+each branch.  
+
+Function does not support partial application of the function being defined. Thus, the following example cannot be accepted due to the presence of partial application of \ident{wrong} into the body of \ident{wrong}~:
+\begin{coq_example*}
+  Function wrong (C:nat) {\ldots} : nat := 
+    List.hd(List.map wrong (C::nil)).
+\end{coq_example*}
+
+For now dependent cases are not treated for non structurally terminating functions.
 
 
 
@@ -1119,14 +1141,14 @@ possible, the correct argument will be automatically generated.
 \end{ErrMsgs}
 
 \subsection{Declaration of implicit arguments for a constant
-\comindex{Implicit Arguments}}
+\comindex{Arguments}}
 \label{ImplicitArguments}
 
 In case one wants that some arguments of a given object (constant,
 inductive types, constructors, assumptions, local or not) are always
 inferred by Coq, one may declare once and for all which are the expected
 implicit arguments of this object. There are two ways to do this,
-a-priori and a-posteriori. 
+a priori and a posteriori.
 
 \subsubsection{Implicit Argument Binders}
 
@@ -1166,44 +1188,44 @@ Print list.
 One can always specify the parameter if it is not uniform using the
 usual implicit arguments disambiguation syntax.
 
-\subsubsection{The Implicit Arguments Vernacular Command}
+\subsubsection{Declaring Implicit Arguments}
 
-To set implicit arguments for a constant a-posteriori, one can use the
+To set implicit arguments for a constant a posteriori, one can use the
 command:
 \begin{quote}
-\tt Implicit Arguments {\qualid} [ \nelist{\possiblybracketedident}{} ]
+\tt Arguments {\qualid} \nelist{\possiblybracketedident}{}
 \end{quote}
-where the list of {\possiblybracketedident} is the list of parameters
-to be declared implicit, each of the identifier of the list being
-optionally surrounded by square brackets, then meaning that this
-parameter has to be maximally inserted.
+where the list of {\possiblybracketedident} is the list of all arguments of
+{\qualid} where the ones to be declared implicit are surrounded by
+square brackets and the ones to be declared as maximally inserted implicits
+are surrounded by curly braces.
 
 After the above declaration is issued, implicit arguments can just (and
 have to) be skipped in any expression involving an application of
 {\qualid}.
 
 \begin{Variants}
-\item {\tt Global Implicit Arguments {\qualid} [ \nelist{\possiblybracketedident}{} ]
-\comindex{Global Implicit Arguments}}
+\item {\tt Global Arguments {\qualid} \nelist{\possiblybracketedident}{}
+\comindex{Global Arguments}}
 
-Tells to recompute the implicit arguments of {\qualid} after ending of
+Tell to recompute the implicit arguments of {\qualid} after ending of
 the current section if any, enforcing the implicit arguments known
 from inside the section to be the ones declared by the command.
 
-\item {\tt Local Implicit Arguments {\qualid} [ \nelist{\possiblybracketedident}{} ]
-\comindex{Local Implicit Arguments}}
+\item {\tt Local Arguments {\qualid} \nelist{\possiblybracketedident}{}
+\comindex{Local Arguments}}
 
-When in a module, tells not to activate the implicit arguments of
-{\qualid} declared by this commands to contexts that requires the
+When in a module, tell not to activate the implicit arguments of
+{\qualid} declared by this command to contexts that require the
 module.
 
-\item {\tt \zeroone{Global {\sl |} Local} Implicit Arguments {\qualid} \sequence{[ \nelist{\possiblybracketedident}{} ]}{}}
+\item {\tt \zeroone{Global {\sl |} Local} Arguments {\qualid} \sequence{\nelist{\possiblybracketedident}{}}{,}}
 
 For names of constants, inductive types, constructors, lemmas which
 can only be applied to a fixed number of arguments (this excludes for
-instance constants whose type is polymorphic), multiple lists
-of implicit arguments can be given. These lists must be of different
-length, and, depending on the number of arguments {\qualid} is applied
+instance constants whose type is polymorphic), multiple 
+implicit arguments decflarations can be given. 
+Depending on the number of arguments {\qualid} is applied
 to in practice, the longest applicable list of implicit arguments is
 used to select which implicit arguments are inserted.
 
@@ -1223,17 +1245,17 @@ Inductive list (A:Type) : Type :=
 \end{coq_example*}
 \begin{coq_example}
 Check (cons nat 3 (nil nat)).
-Implicit Arguments cons [A].
-Implicit Arguments nil [A].
+Arguments cons [A] _ _.
+Arguments nil [A].
 Check (cons 3 nil).
 Fixpoint map (A B:Type) (f:A->B) (l:list A) : list B :=
   match l with nil => nil | cons a t => cons (f a) (map A B f t) end.
 Fixpoint length (A:Type) (l:list A) : nat :=
   match l with nil => 0 | cons _ m => S (length A m) end.
-Implicit Arguments map [A B].
-Implicit Arguments length [[A]]. (* A has to be maximally inserted *)
+Arguments map [A B] f l.
+Arguments length {A} l. (* A has to be maximally inserted *)
 Check (fun l:list (list nat) => map length l).
-Implicit Arguments map [A B] [A] [].
+Arguments map [A B] f l, [A] B f l, A B f l.
 Check (fun l => map length l = map (list nat) nat length l).
 \end{coq_example}
 
@@ -1248,8 +1270,8 @@ implicit arguments of {\qualid}.
 {\Coq} can also automatically detect what are the implicit arguments
 of a defined object. The command is just
 \begin{quote}
-{\tt Implicit Arguments {\qualid}
-\comindex{Implicit Arguments}}
+{\tt Arguments {\qualid} : default implicits
+\comindex{Arguments}}
 \end{quote}
 The auto-detection is governed by options telling if strict,
 contextual, or reversible-pattern implicit arguments must be
@@ -1258,16 +1280,16 @@ Sections~\ref{SetStrictImplicit},~\ref{SetContextualImplicit},~\ref{SetReversibl
 and also~\ref{SetMaximalImplicitInsertion}).
 
 \begin{Variants}
-\item {\tt Global Implicit Arguments {\qualid}
-\comindex{Global Implicit Arguments}}
+\item {\tt Global Arguments {\qualid} : default implicits
+\comindex{Global Arguments}}
 
-Tells to recompute the implicit arguments of {\qualid} after ending of
+Tell to recompute the implicit arguments of {\qualid} after ending of
 the current section if any.
 
-\item {\tt Local Implicit Arguments {\qualid}
-\comindex{Local Implicit Arguments}}
+\item {\tt Local Arguments {\qualid} : default implicits
+\comindex{Local Arguments}}
 
-When in a module, tells not to activate the implicit arguments of
+When in a module, tell not to activate the implicit arguments of
 {\qualid} computed by this declaration to contexts that requires the
 module.
 
@@ -1283,12 +1305,12 @@ Inductive list (A:Set) : Set :=
   | cons : A -> list A -> list A.
 \end{coq_example*}
 \begin{coq_example}
-Implicit Arguments cons.
+Arguments cons : default implicits.
 Print Implicit cons.
-Implicit Arguments nil.
+Arguments nil : default implicits.
 Print Implicit nil.
 Set Contextual Implicit.
-Implicit Arguments nil.
+Arguments nil : default implicits.
 Print Implicit nil.
 \end{coq_example}
 
@@ -1304,7 +1326,7 @@ Definition Relation := X -> X -> Prop.
 Definition Transitivity (R:Relation) :=
   forall x y:X, R x y -> forall z:X, R y z -> R x z.
 Variables (R : Relation) (p : Transitivity R).
-Implicit Arguments p.
+Arguments p : default implicits.
 \end{coq_example*}
 \begin{coq_example}
 Print p.
@@ -1317,6 +1339,21 @@ Variables (a b c : X) (r1 : R a b) (r2 : R b c).
 Check (p r1 r2).
 \end{coq_example}
 
+Implicit arguments can be cleared with the following syntax:
+
+\begin{quote}
+{\tt Arguments {\qualid} : clear implicits
+\comindex{Arguments}}
+\end{quote}
+
+In the following example implict arguments declarations for the {\tt nil}
+constant are cleared:
+\begin{coq_example}
+Arguments cons : clear implicits.
+Print Implicit cons.
+\end{coq_example}
+
+
 \subsection{Mode for automatic declaration of implicit arguments
 \label{Auto-implicit}
 \comindex{Set Implicit Arguments}
@@ -1410,7 +1447,7 @@ Implicit Insertion}.
 \subsection{Explicit applications
 \index{Explicitly given implicit arguments}
 \label{Implicits-explicitation}
-\index{qualid@{\qualid}}}
+\index{qualid@{\qualid}} \index{\symbol{64}}}
 
 In presence of non strict or contextual argument, or in presence of
 partial applications, the synthesis of implicit arguments may fail, so
@@ -1442,6 +1479,28 @@ Check (p r1 (z:=c)).
 Check (p (x:=a) (y:=b) r1 (z:=c) r2).
 \end{coq_example}
 
+\subsection{Renaming implicit arguments
+\comindex{Arguments}
+}
+
+Implicit arguments names can be redefined using the following syntax:
+\begin{quote}
+{\tt Arguments {\qualid} \nelist{\name}{}  : rename}
+\end{quote}
+
+Without the {\tt rename} flag, {\tt Arguments} can be used to assert
+that a given constant has the expected number of arguments and that
+these arguments are named as expected.
+
+\noindent {\bf Example (continued): }
+\begin{coq_example}
+Arguments p [s t] _ [u] _: rename.
+Check (p r1 (u:=c)).
+Check (p (s:=a) (t:=b) r1 (u:=c) r2).
+Fail Arguments p [s t] _ [w] _.
+\end{coq_example}
+
+
 \subsection{Displaying what the implicit arguments are
 \comindex{Print Implicit}
 \label{PrintImplicit}}
@@ -1622,7 +1681,7 @@ the generalized variables. Inside implicit generalization
 delimiters, free variables in the current context are automatically
 quantified using a product or a lambda abstraction to generate a closed
 term. In the following statement for example, the variables \texttt{n}
-and \texttt{m} are automatically generalized and become explicit
+and \texttt{m} are autamatically generalized and become explicit
 arguments of the lemma as we are using \verb|`( )|:
 
 \begin{coq_example}
@@ -1638,7 +1697,7 @@ generalizations when mistyping identifiers. There are three variants of
 the command:
 
 \begin{quote}
-{\tt (Global)? Generalizable (All|No) Variable(s)? ({\ident$_1$ \ident$_n$})?.}
+{\tt Generalizable (All|No) Variable(s)? ({\ident$_1$ \ident$_n$})?.}
 \end{quote}
 
 \begin{Variants}
@@ -1742,13 +1801,25 @@ of the occurrences of {\Type}, use
 \end{quote}
 
 \comindex{Print Universes}
+\comindex{Print Sorted Universes}
 
 The constraints on the internal level of the occurrences of {\Type}
 (see Section~\ref{Sorts}) can be printed using the command
 \begin{quote}
-{\tt Print Universes.}
+{\tt Print \zeroone{Sorted} Universes.}
 \end{quote}
+If the optional {\tt Sorted} option is given, each universe will be
+made equivalent to a numbered label reflecting its level (with a
+linear ordering) in the universe hierarchy.
 
+This command also accepts an optional output filename:
+\begin{quote}
+\tt Print \zeroone{Sorted} Universes {\str}.
+\end{quote}
+If {\str} ends in \texttt{.dot} or \texttt{.gv}, the constraints are
+printed in the DOT language, and can be processed by Graphviz
+tools. The format is unspecified if {\str} doesn't end in
+\texttt{.dot} or \texttt{.gv}.
 
 %%% Local Variables: 
 %%% mode: latex
diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex
index d1489591..204fa90d 100644
--- a/doc/refman/RefMan-gal.tex
+++ b/doc/refman/RefMan-gal.tex
@@ -217,12 +217,12 @@ possible one (among all tokens defined at this moment), and so on.
 
 \subsection{Syntax of terms}
 
-Figures \ref{term-syntax} and \ref{term-syntax-aux} describe the basic
-set of terms which form the {\em Calculus of Inductive Constructions}
-(also called \CIC). The formal presentation of {\CIC} is given in
-Chapter \ref{Cic}. Extensions of this syntax are given in chapter
-\ref{Gallina-extension}. How to customize the syntax is described in
-Chapter \ref{Addoc-syntax}.
+Figures \ref{term-syntax} and \ref{term-syntax-aux} describe the basic syntax of
+the terms of the {\em Calculus of Inductive Constructions} (also
+called \CIC). The formal presentation of {\CIC} is given in Chapter
+\ref{Cic}. Extensions of this syntax are given in chapter
+\ref{Gallina-extension}. How to customize the syntax is described in Chapter
+\ref{Addoc-syntax}.
 
 \begin{figure}[htbp]
 \begin{centerframe}
@@ -240,9 +240,13 @@ Chapter \ref{Addoc-syntax}.
  & $|$ & {\tt let} {\tt (} \sequence{\name}{,} {\tt )} \zeroone{\ifitem}
          {\tt :=} {\term}
          {\tt in} {\term}  &(\ref{caseanalysis}, \ref{Mult-match})\\
+ & $|$ & {\tt let '} {\pattern} \zeroone{{\tt in} {\term}} {\tt :=} {\term}
+        \zeroone{\returntype} {\tt in} {\term} & (\ref{caseanalysis}, \ref{Mult-match})\\
  & $|$ & {\tt if} {\term} \zeroone{\ifitem} {\tt then} {\term}
          {\tt else} {\term} &(\ref{caseanalysis}, \ref{Mult-match})\\
  & $|$ & {\term} {\tt :} {\term} &(\ref{typecast})\\
+ & $|$ & {\term} {\tt <:} {\term} &(\ref{typecast})\\
+ & $|$ & {\term} {\tt :>} &(\ref{ProgramSyntax})\\
  & $|$ & {\term} {\tt ->} {\term} &(\ref{products})\\
  & $|$ & {\term} \nelist{\termarg}{}&(\ref{applications})\\
  & $|$ & {\tt @} {\qualid} \sequence{\term}{}
@@ -256,6 +260,7 @@ Chapter \ref{Addoc-syntax}.
  & $|$ & {\sort} &(\ref{Gallina-sorts})\\
  & $|$ & {\num} &(\ref{numerals})\\
  & $|$ & {\_} &(\ref{hole})\\
+ & $|$ & {\tt (} {\term} {\tt )} & \\
  & & &\\
 {\termarg} & ::= & {\term} &\\
  & $|$ & {\tt (} {\ident} {\tt :=} {\term} {\tt )}
@@ -496,6 +501,10 @@ arguments is used for making explicit the value of implicit arguments
 The expression ``{\term}~{\tt :}~{\type}'' is a type cast
 expression. It enforces the type of {\term} to be {\type}.
 
+``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine (as if option
+{\tt Virtual Machine} were on, see \ref{SetVirtualMachine}) for checking that
+{\term} has type {\type}.
+
 \subsection{Inferable subterms
 \label{hole}
 \index{\_}}
diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex
index 5d9c8c16..f061ef18 100644
--- a/doc/refman/RefMan-ide.tex
+++ b/doc/refman/RefMan-ide.tex
@@ -261,32 +261,26 @@ CONTROL and the SHIFT keys, and type the hexadecimal code of the
 symbol required, for example \verb|2200| for the $\forall$ symbol.
 A list of symbol codes is available at \url{http://www.unicode.org}. 
 
-This method obviously doesn't scale, that's why the preferred
-alternative is to use an Input Method Editor. On POSIX systems (Linux
-distributions, BSD variants and MacOS X), you can use \texttt{uim} to
-support \LaTeX{}-style edition and, if using X Windows, you can also use
-the XCompose method (XIM). How to use \texttt{uim} is documented below.
-
-If you have \texttt{uim} 1.5.x, first manually copy the files located
-in directory {\tt ide/uim} of the Coq source distribution to the
-{\tt uim} directory of input methods which typically is {\tt
-  /usr/share/uim}. Execute {\tt uim-module-manager -{-}register
-  coqide}. Then, execute \texttt{uim-pref-gtk} as regular user and set
-the default Input Method to "CoqIDE" in the "Global Settings" group
-(don't forget to tick the checkbox "Specify default IM"; you may also
-have to first edit the set of "Enabled input method" to add CoqIDE to
-the set). You can now execute CoqIDE with the following commands
-(assuming you use a Bourne-style shell):
+This method obviously doesn't scale, that's why the preferred alternative is to
+use an Input Method Editor. On POSIX systems (Linux distros, BSD variants and
+MacOS X), you can use \texttt{uim} version 1.6 or later which provides a \LaTeX{}-style
+input method.
+
+To configure \texttt{uim}, execute \texttt{uim-pref-gtk} as your regular user.
+In the "Global Settings" group set the default Input Method to "ELatin" (don't
+forget to tick the checkbox "Specify default IM"). In the "ELatin" group set the
+layout to "TeX", and remember the content of the "[ELatin] on" field (by default
+"<Control>\textbackslash"). You can now execute CoqIDE with the following commands (assuming
+you use a Bourne-style shell):
 
 \begin{verbatim}
 $ export GTK_IM_MODULE=uim
 $ coqide
 \end{verbatim}
 
-If you then type the sequence "\verb=\Gamma=", you will see the sequence being
-replaced by $\Gamma$ as soon as you  type the second "a".
-
-If you have \texttt{uim} 1.6.x, the \LaTeX{} input method is built-in. You just have to execute \texttt{uim-pref-gtk} and choose "ELatin" as default Input Method in the "Global Settings". Then, in the "ELatin" group set the layout to "TeX", and remember the content of the "[ELatin] on" field (by default "<Control>$\backslash$"). Proceed then as above.
+Activate the ELatin Input Method with Ctrl-\textbackslash, then type the
+sequence "\verb=\Gamma=". You will see the sequence being
+replaced by $\Gamma$ as soon as you type the second "a".
 
 \subsection[Character encoding for saved files]{Character encoding for saved files\label{sec:coqidecharencoding}}
 
@@ -305,23 +299,6 @@ each dot is an hexadecimal digit: the number between braces is the
 hexadecimal UNICODE index for the missing character.
 
 
-\section{Building a custom \CoqIDE{} with user \textsc{ML} code}
-
-You can do this as described in Section~\ref{Coqmktop} for a
-custom coq text toplevel, simply by adding 
-option \verb|-ide| to \verb|coqmktop|, that is something like
-\begin{quote}
-\texttt{coqmktop -ide -byte $m_1$.cmo \ldots{} $m_n$.cmo}
-\end{quote}
-or 
-\begin{quote}
-\texttt{coqmktop -ide -opt $m_1$.cmx \ldots{} $m_n$.cmx}
-\end{quote}
-
-    
-
-% $Id: RefMan-ide.tex 13701 2010-12-10 07:48:30Z herbelin $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-ind.tex b/doc/refman/RefMan-ind.tex
index af4257ca..95944240 100644
--- a/doc/refman/RefMan-ind.tex
+++ b/doc/refman/RefMan-ind.tex
@@ -508,4 +508,3 @@ Check tree_forest_mutind.
 
 %\end{document}
 
-% $Id: RefMan-ind.tex 10421 2008-01-05 14:06:51Z herbelin $ 
diff --git a/doc/refman/RefMan-int.tex b/doc/refman/RefMan-int.tex
index 7b531409..6d2c37f7 100644
--- a/doc/refman/RefMan-int.tex
+++ b/doc/refman/RefMan-int.tex
@@ -140,8 +140,6 @@ is given in the additional document {\tt Library.ps}.
 \end{description}
 
 
-% $Id: RefMan-int.tex 11307 2008-08-06 08:38:57Z jnarboux $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex
index 2c8abc88..31c6fef4 100644
--- a/doc/refman/RefMan-lib.tex
+++ b/doc/refman/RefMan-lib.tex
@@ -809,7 +809,8 @@ subdirectories:
 \begin{tabular}{lp{12cm}}
   {\bf Logic}   & Classical logic and dependent equality \\
   {\bf Arith}   & Basic Peano arithmetic \\
-  {\bf NArith}  & Basic positive integer arithmetic \\
+  {\bf PArith}  & Basic positive integer arithmetic \\
+  {\bf NArith}  & Basic binary natural number arithmetic \\
   {\bf ZArith}  & Basic relative integer arithmetic \\
   {\bf Numbers} & Various approaches to natural, integer and cyclic numbers (currently axiomatically and on top of 2$^{31}$ binary words) \\
   {\bf Bool}    & Booleans (basic functions and results) \\
@@ -996,7 +997,7 @@ Abort.
 \end{coq_eval}
 
 \item {\tt split\_Rabs} allows to unfold {\tt Rabs} constant and splits 
-corresponding conjonctions.
+corresponding conjunctions.
 \tacindex{split\_Rabs}
 
 \begin{coq_example*}
@@ -1094,8 +1095,6 @@ description, etc.) and the possibility to download them one by one.
 You will also find informations on how to submit a new
 contribution.
 
-% $Id: RefMan-lib.tex 13091 2010-06-08 13:56:19Z herbelin $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex
index d8747254..38ad9aa8 100644
--- a/doc/refman/RefMan-ltac.tex
+++ b/doc/refman/RefMan-ltac.tex
@@ -100,6 +100,7 @@ is understood as
 & | & {\tt progress} {\tacexprpref}\\
 & | & {\tt repeat} {\tacexprpref}\\
 & | & {\tt try} {\tacexprpref}\\
+& | & {\tt timeout} {\it (}{\naturalnumber} {\it |} {\ident}{\it )} {\tacexprpref}\\
 & | & {\tacexprinf} \\
 \\
 {\tacexprinf} & ::= &
@@ -446,6 +447,28 @@ This is a combination of the previous variants.
 
 \ErrMsg \errindex{Tactic Failure {\it message} (level $n$)}.
 
+\subsubsection[Timeout]{Timeout\tacindex{timeout}
+\index{Tacticals!timeout@{\tt timeout}}}
+
+We can force a tactic to stop if it has not finished after a certain
+amount of time:
+\begin{quote}
+{\tt timeout} {\num} {\tacexpr}
+\end{quote}
+{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is
+normally applied, except that it is interrupted after ${\num}$ seconds
+if it is still running. In this case the outcome is a failure.
+
+Warning: For the moment, {\tt timeout} is based on elapsed time in
+seconds, which is very
+machine-dependent: a script that works on a quick machine may fail
+on a slow one. The converse is even possible if you combine a
+{\tt timeout} with some other tacticals. This tactical is hence
+proposed only for convenience during debug or other development
+phases, we strongly advise you to not leave any {\tt timeout} in
+final scripts. Note also that this tactical isn't available on
+the native Windows port of Coq.
+
 \subsubsection[Local definitions]{Local definitions\index{Ltac!let}
 \index{Ltac!let rec}
 \index{let!in Ltac}
@@ -568,11 +591,10 @@ pattern:
 \begin{quote}
 {\tt context} {\ident} {\tt [} {\cpattern} {\tt ]}
 \end{quote}
-It matches any term which one subterm matches {\cpattern}. If there is
-a match, the optional {\ident} is assign the ``matched context'', that
-is the initial term where the matched subterm is replaced by a
-hole. The definition of {\tt context} in expressions below will show
-how to use such term contexts.
+It matches any term with a subterm matching {\cpattern}. If there is
+a match, the optional {\ident} is assigned the ``matched context'', i.e.
+the initial term where the matched subterm is replaced by a
+hole. The example below will show how to use such term contexts.
 
 If the evaluation of the right-hand-side of a valid match fails, the
 next matching subterm is tried. If no further subterm matches, the
@@ -606,7 +628,7 @@ Alternatively, one may now use the following variant of {\tt context}:
 The behavior of {\tt appcontext} is the same as the one of {\tt
   context}, except that a matching subterm could be a partial
 part of a longer application. For instance, in {\tt (f 1 2)},
-an {\tt appcontext [f ?x]} will find the matching subterm {\tt (f 1)}.
+an {\tt appcontext [f ?x]} will find the matching subterm {\tt (f 1)}. 
 
 \end{Variants}
 
diff --git a/doc/refman/RefMan-modr.tex b/doc/refman/RefMan-modr.tex
index b2ea232c..9ab8aded 100644
--- a/doc/refman/RefMan-modr.tex
+++ b/doc/refman/RefMan-modr.tex
@@ -556,8 +556,6 @@ In the rules below we assume $\Gamma_P$ is $[p_1:P_1;\ldots;p_r:P_r]$,
 % \end{itemize}
 
 
-% $Id: RefMan-modr.tex 11197 2008-07-01 13:05:41Z soubiran $
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex
index 025788f5..5b1ad198 100644
--- a/doc/refman/RefMan-oth.tex
+++ b/doc/refman/RefMan-oth.tex
@@ -225,8 +225,7 @@ a subterm that matches the pattern {\termpattern} (holes of the
 pattern are either denoted by ``{\texttt \_}'' or
 by ``{\texttt ?{\ident}}'' when non linear patterns are expected).
 
-\item {\tt SearchAbout [ \nelist{\zeroone{-}{\termpatternorstr}}{}
-].}\\
+\item {\tt SearchAbout \nelist{\zeroone{-}{\termpatternorstr}}{}.}\\
 
 \noindent where {\termpatternorstr} is a
 {\termpattern} or a {\str}, or a {\str} followed by a scope
@@ -241,25 +240,24 @@ search excludes the objects that mention that {\termpattern} or that
 {\str}.
 
 \item
-\begin{tabular}[t]{@{}l}
-  {\tt SearchAbout {\termpatternorstr} inside {\module$_1$} \ldots{} {\module$_n$}.} \\
-  {\tt SearchAbout [ \nelist{{\termpatternorstr}}{} ]
+  {\tt SearchAbout \nelist{{\termpatternorstr}}{}
     inside {\module$_1$} \ldots{} {\module$_n$}.}
-\end{tabular}
 
 This restricts the search to constructions defined in modules
 {\module$_1$} \ldots{} {\module$_n$}.
 
 \item
-\begin{tabular}[t]{@{}l}
-  {\tt SearchAbout {\termpatternorstr} outside {\module$_1$}...{\module$_n$}.} \\
-  {\tt SearchAbout [ \nelist{{\termpatternorstr}}{} ]
+  {\tt SearchAbout \nelist{{\termpatternorstr}}{}
      outside {\module$_1$}...{\module$_n$}.}
-\end{tabular}
 
 This restricts the search to constructions not defined in modules
 {\module$_1$} \ldots{} {\module$_n$}.
 
+\item {\tt SearchAbout [ ... ]. }
+
+For compatibility with older versions, the list of objects to search
+may be enclosed by optional {\tt [  ]} delimiters.
+
 \end{Variants}
 
 \examples
@@ -268,8 +266,8 @@ This restricts the search to constructions not defined in modules
 Require Import ZArith.
 \end{coq_example*}
 \begin{coq_example}
-SearchAbout [ Zmult Zplus "distr" ].
-SearchAbout [ "+"%Z "*"%Z "distr" -positive -Prop].
+SearchAbout Zmult Zplus "distr".
+SearchAbout "+"%Z "*"%Z "distr" -positive -Prop.
 SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas.
 \end{coq_example}
 
@@ -338,16 +336,6 @@ This restricts the search to constructions not defined in modules
 
 \end{Variants}
 
-% \subsection[\tt SearchIsos {\term}.]{\tt SearchIsos {\term}.\comindex{SearchIsos}}
-% \label{searchisos}
-% \texttt{SearchIsos} searches terms by their type modulo isomorphism.
-% This command displays the full name of all constants, variables,
-% inductive types, and inductive constructors of the current
-% context whose type is isomorphic to {\term} modulo the contextual part of the
-% following axiomatization (the mutual inductive types with one constructor,
-% without implicit arguments, and for which projections exist, are regarded as a
-% sequence of $\sa{}$):
-
 
 % \begin{tabbing}
 % \ \ \ \ \=11.\ \=\kill
@@ -632,6 +620,12 @@ files is only possible under the bytecode version of {\tt coqtop}
 \ref{Addoc-coqc}), or when Coq has been compiled with a version of
 Objective Caml that supports native {\tt Dynlink} ($\ge$ 3.11).
 
+\begin{Variants}
+\item {\tt Local Declare ML Module {\str$_1$} .. {\str$_n$}.}\\
+  This variant is not exported to the modules that import the module
+  where they occur, even if outside a section.
+\end{Variants}
+
 \begin{ErrMsgs}
 \item \errindex{File not found on loadpath : \str}
 \item \errindex{Loading of ML object file forbidden in a native Coq}
@@ -938,7 +932,7 @@ a {\tt Timeout} are unaffected.
 
 \subsection[\tt Unset Default Timeout.]{\tt Unset Default Timeout.\comindex{Unset Default Timeout}}
 
-This command turns off the use of a defaut timeout.
+This command turns off the use of a default timeout.
 
 \subsection[\tt Test Default Timeout.]{\tt Test Default Timeout.\comindex{Test Default Timeout}}
 
@@ -978,12 +972,6 @@ time of writing this documentation, the default value is 50).
 \subsection[\tt Test Printing Depth.]{\tt Test Printing Depth.\comindex{Test Printing Depth}}
 This command displays the current nesting depth used for display.
 
-%\subsection{\tt Explain ...}
-%Not yet documented.
-
-%\subsection{\tt Go ...}
-%Not yet documented.
-
 %\subsection{\tt Abstraction ...}
 %Not yet documented.
 
@@ -997,7 +985,7 @@ compares applicative terms while the other is a brute-force but efficient
 algorithm that first normalizes the terms before comparing them.  The
 second algorithm is based on a bytecode representation of terms
 similar to the bytecode representation used in the ZINC virtual
-machine~\cite{Leroy90}. It is specially useful for intensive
+machine~\cite{Leroy90}. It is especially useful for intensive
 computation of algebraic values, such as numbers, and for reflexion-based
 tactics. The commands to fine-tune the reduction strategies and the
 lazy conversion algorithm are described first.
@@ -1188,8 +1176,6 @@ control the scope of their effect. There are four kinds of commands:
 \end{itemize}
 
 
-% $Id: RefMan-oth.tex 13923 2011-03-21 16:25:20Z letouzey $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex
index a2cdb5ec..29de89d8 100644
--- a/doc/refman/RefMan-pre.tex
+++ b/doc/refman/RefMan-pre.tex
@@ -673,7 +673,7 @@ Yves Bertot, Jean-Christophe Filliâtre, Pierre Courtieu and
 Julien Forest acted as maintainers of features they implemented in
 previous versions of Coq.
 
-Julien Narboux contributed to CoqIDE.
+Julien Narboux contributed to {\CoqIDE}.
 Nicolas Tabareau made the adaptation of the interface of the old
 ``setoid rewrite'' tactic to the new version. Lionel Mamane worked on
 the interaction between Coq and its external interfaces. With Samuel
@@ -750,7 +750,7 @@ standard and more robust basis.
 Though invisible from outside, Arnaud Spiwack improved the general
 process of management of existential variables. Pierre Letouzey and
 Stéphane Glondu improved the compilation scheme of the Coq archive.
-Vincent Gross provided support to CoqIDE. Jean-Marc Notin provided
+Vincent Gross provided support to {\CoqIDE}. Jean-Marc Notin provided
 support for benchmarking and archiving.
 
 Many users helped by reporting problems, providing patches, suggesting
@@ -768,6 +768,150 @@ Paris, April 2010\\
 Hugo Herbelin\\
 \end{flushright}
 
+\section*{Credits: version 8.4}
+
+{\Coq} version 8.4 contains the result of three long-term projects: a
+new modular library of arithmetic by Pierre Letouzey, a new proof
+engine by Arnaud Spiwack and a new communication protocol for {\CoqIDE}
+by Vincent Gross.
+
+The new modular library of arithmetic extends, generalizes and
+unifies the existing libraries on Peano arithmetic (types {\tt nat},
+{\tt N} and {\tt BigN}), positive arithmetic (type {\tt positive}),
+integer arithmetic ({\tt Z} and {\tt BigZ}) and machine word
+arithmetic (type {\tt Int31}). It provides with unified notations
+(e.g. systematic use of {\tt add} and {\tt mul} for denoting the
+addition and multiplication operators), systematic and generic
+development of operators and properties of these operators for all the
+types mentioned above, including gcd, pcm, power, square root, base 2
+logarithm, division, modulo, bitwise operations, logical shifts,
+comparisons, iterators, ...
+
+The most visible feature of the new proof engine is the support for
+structured scripts (bullets and proof brackets) but, even if yet not
+user-available, the new engine also provides the basis for refining
+existential variables using tactics, for applying tactics to several
+goals simultaneously, for reordering goals, all features which are
+planned for the next release.
+
+Before version 8.4, {\CoqIDE} was linked to {\Coq} with the graphical
+interface living in a separate thread. From version 8.4, {\CoqIDE} is a
+separate process communicating with {\Coq} through a textual
+channel. This allows for a more robust interfacing, the ability to
+interrupt {\Coq} without interrupting the interface, and the ability to
+manage several sessions in parallel. Relying on the infrastructure
+work made by Vincent Gross, Pierre Letouzey, Pierre Boutillier and
+Pierre-Marie P\'edrot contributed many various refinements of {\CoqIDE}.
+
+{\Coq} 8.4 also comes with a bunch of many various smaller-scale changes
+and improvements regarding the different components of the system.
+
+The underlying logic has been extended with $\eta$-conversion thanks
+to Hugo Herbelin, St\'ephane Glondu and Benjamin Gr\'egoire. The
+addition of $\eta$-conversion is justified by the confidence that the
+formulation of the Calculus of Inductive Constructions based on typed
+equality (such as the one considered in Lee and Werner to build a
+set-theoretic model of CIC~\cite{LeeWerner11}) is applicable to the
+concrete implementation of {\Coq}.
+
+The underlying logic benefited also from a refinement of the guard
+condition for fixpoints by Pierre Boutillier, the point being that it
+is safe to propagate the information about structurally smaller
+arguments through $\beta$-redexes that are blocked by the
+``match'' construction (blocked commutative cuts).
+
+Relying on the added permissiveness of the guard condition, Hugo
+Herbelin could extend the pattern-matching compilation algorithm
+so that matching over a sequence of terms involving
+dependencies of a term or of the indices of the type of a term in the
+type of other terms is systematically supported.
+
+Regarding the high-level specification language, Pierre Boutillier
+introduced the ability to give implicit arguments to anonymous
+functions, Hugo Herbelin introduced the ability to define notations
+with several binders (e.g. \verb=exists x y z, P=), Matthieu Sozeau
+made the type classes inference mechanism more robust and predictable,
+Enrico Tassi introduced a command {\tt Arguments} that generalizes
+{\tt Implicit Arguments} and {\tt Arguments Scope} for assigning
+various properties to arguments of constants. Various improvements in
+the type inference algorithm were provided by Matthieu Sozeau and Hugo
+Herbelin with contributions from Enrico Tassi.
+
+Regarding tactics, Hugo Herbelin introduced support for referring to
+expressions occurring in the goal by pattern in tactics such as {\tt
+  set} or {\tt destruct}. Hugo Herbelin also relied on ideas from
+Chung-Kil Hur's {\tt Heq} plugin to introduce automatic computation of
+occurrences to generalize when using {\tt destruct} and {\tt
+  induction} on types with indices.  St\'ephane Glondu introduced new
+tactics {\tt constr\_eq}, {\tt is\_evar} and {\tt has\_evar} to be
+used when writing complex tactics.  Enrico Tassi added support to
+fine-tuning the behavior of {\tt simpl}. Enrico Tassi added the
+ability to specify over which variables of a section a lemma has
+to be exactly generalized.  Pierre Letouzey added a tactic {\tt
+  timeout} and the interruptibility of {\tt vm\_compute}.  Bug fixes
+and miscellaneous improvements of the tactic language came from Hugo
+Herbelin, Pierre Letouzey and Matthieu Sozeau.
+
+Regarding decision tactics, Lo\"ic Pottier maintained {\tt Nsatz},
+moving in particular to a type-class based reification of goals while
+Fr\'ed\'eric Besson maintained {\tt Micromega}, adding in particular
+support for division.
+
+Regarding vernacular commands, St\'ephane Glondu provided new commands
+to analyze the structure of type universes.
+
+Regarding libraries, a new library about lists of a given length
+(called vectors) has been provided by Pierre Boutillier.
+
+Pierre Corbineau maintained the C-zar proof mode.
+
+Bruno Barras and Benjamin Gr\'egoire maintained the call-by-value
+reduction machines.
+
+The extraction mechanism benefited from several improvements provided by
+Pierre Letouzey.
+
+Pierre Letouzey maintained the module system, with contributions from
+\'Elie Soubiran.
+
+Julien Forest maintained the {\tt Function} command.
+
+Matthieu Sozeau maintained the setoid rewriting mechanism.
+
+{\Coq} related tools have been upgraded too. In particular, {\tt
+  coq\_makefile} has been largely revised by Pierre Boutillier.
+
+Bruno Barras and Pierre Letouzey maintained the {\tt coqchk} checker.
+
+Pierre Courtieu and Arnaud Spiwack contributed new features for using
+{\Coq} through Proof General.
+
+Under the hood, the {\Coq} architecture benefited from improvements in
+terms of efficiency and robustness thanks to Pierre Letouzey and Yann
+R\'egis-Gianas with contributions from St\'ephane Glondu and Matthias
+Puech. The build system is maintained by Pierre Letouzey with
+contributions from St\'ephane Glondu and Pierre Boutillier.
+
+The general maintenance was done by Hugo Herbelin, Pierre Letouzey,
+Pierre Boutillier and St\'ephane Glondu with local contributions from
+Guillaume Melquiond and Julien Narboux.
+
+Packaging tools were provided by Pierre Letouzey (Windows), Pierre
+Boutillier (MacOS), St\'ephane Glondu (Debian). Releasing, testing and
+benchmarking support was provided by Jean-Marc Notin.
+
+Many suggestions for improvements were motivated by feedback from
+users, on either the bug tracker or the coq-club mailing list. Special
+thanks are going to the users who contributed patches, starting with
+Tom Prince. Other patch contributors include C\'edric Auger, David
+Baelde, Dan Grayson, Paolo Herms, Robbert Krebbers, Marc Lasson,
+Hendrik Tews and Eelis van der Weegen.
+
+\begin{flushright}
+Paris, December 2011\\
+Hugo Herbelin\\
+\end{flushright}
+
 %new Makefile
 
 %\newpage
@@ -775,7 +919,7 @@ Hugo Herbelin\\
 % Integration of ZArith lemmas from Sophia and Nijmegen.
 
 
-% $Id: RefMan-pre.tex 13271 2010-07-08 18:10:54Z herbelin $ 
+% $Id: RefMan-pre.tex 14853 2011-12-23 19:59:48Z herbelin $ 
 
 %%% Local Variables: 
 %%% mode: latex
diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex
index 3a8936eb..e5dc669d 100644
--- a/doc/refman/RefMan-pro.tex
+++ b/doc/refman/RefMan-pro.tex
@@ -133,6 +133,24 @@ one gulp, as a proof term (see Section~\ref{exact}).
 
 \SeeAlso {\tt Proof with {\tac}.} in Section~\ref{ProofWith}.
 
+\subsection[\tt Proof using {\ident$_1$ \dots {\ident$_n$}}.]
+{\tt Proof using {\ident$_1$ \dots {\ident$_n$}}.
+\comindex{Proof using} \label{ProofUsing}}
+
+This command applies in proof editing mode. 
+It declares the set of section variables (see~\ref{Variable}) 
+used by the proof. At {\tt Qed} time, the system will assert that 
+the set of section variables actually used in the proof is a subset of
+the declared one.
+
+The set of declared variables is closed under type dependency.
+For example if {\tt T} is variable and {\tt a} is a variable of
+type {\tt T}, the commands {\tt Proof using a} and
+{\tt Proof using T a} are actually equivalent.
+
+\variant {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}.} 
+in Section~\ref{ProofWith}.
+
 \subsection[\tt Abort.]{\tt Abort.\comindex{Abort}}
 
 This command cancels the current proof development, switching back to
@@ -211,7 +229,6 @@ backtracks one step.
 
 \begin{ErrMsgs}
 \item \errindex{No focused proof (No proof-editing in progress)}
-\item \errindex{Undo stack would be exhausted}
 \end{ErrMsgs}
 
 \begin{Variants}
@@ -222,18 +239,6 @@ backtracks one step.
 
 \end{Variants}
 
-\subsection[\tt Set Undo {\num}.]{\tt Set Undo {\num}.\comindex{Set Undo}}
-
-This command changes the maximum number of {\tt Undo}'s that will be
-possible when doing a proof. It only affects proofs started after
-this command, such that if you want to change the current undo limit
-inside a proof, you should first restart this proof.
-
-\subsection[\tt Unset Undo.]{\tt Unset Undo.\comindex{Unset Undo}}
-
-This command resets the default number of possible {\tt Undo} commands
-(which is currently 12).
-
 \subsection[\tt Restart.]{\tt Restart.\comindex{Restart}}
 This command restores the proof editing process to the original goal.
 
@@ -362,8 +367,6 @@ All the hypotheses remains usable in the proof development.
 This command goes back to the default mode which is to print all
 available hypotheses.
 
-% $Id: RefMan-pro.tex 13091 2010-06-08 13:56:19Z herbelin $
-
 
 \subsection[\tt Set Automatic Introduction.]{\tt Set Automatic Introduction.\comindex{Set Automatic Introduction}\comindex{Unset Automatic Introduction}\label{Set Automatic Introduction}}
 
diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex
index 2b0d636e..ea3d55f2 100644
--- a/doc/refman/RefMan-syn.tex
+++ b/doc/refman/RefMan-syn.tex
@@ -345,7 +345,7 @@ Infix "/\" := and (at level 80, right associativity).
 
 \subsection{Reserving notations
 \label{ReservedNotation}
-\comindex{ReservedNotation}}
+\comindex{Reserved Notation}}
 
 A given notation may be used in different contexts. {\Coq} expects all
 uses of the notation to be defined at the same precedence and with the
@@ -774,32 +774,57 @@ To bind a delimiting key to a scope, use the command
 \end{quote}
 
 \subsubsection{Binding arguments of a constant to an interpretation scope
-\comindex{Arguments Scope}}
+\comindex{Arguments}}
 
 It is possible to set in advance that some arguments of a given
 constant have to be interpreted in a given scope. The command is
 \begin{quote}
-{\tt Arguments Scope} {\qualid} {\tt [ \nelist{\optscope}{} ]}
+{\tt Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{}
 \end{quote}
-where the list is a list made either of {\tt \_} or of a scope name.
-Each scope in the list is bound to the corresponding parameter of
-{\qualid} in order.  When interpreting a term, if some of the
+where the list is the list of the arguments of {\qualid} eventually
+annotated with their {\scope}. Grouping round parentheses can
+be used to decorate multiple arguments with the same scope.
+{\scope} can be either a scope name or its delimiting key. For example
+the following command puts the first two arguments of {\tt plus\_fct}
+in the scope delimited by the key {\tt F} ({\tt Rfun\_scope}) and the
+last argument in the scope delimited by the key {\tt R} ({\tt R\_scope}).
+
+\begin{coq_example*}
+Arguments plus_fct (f1 f2)%F x%R.
+\end{coq_example*}
+
+The {\tt Arguments} command accepts scopes decoration to all grouping
+parentheses. In the following example arguments {\tt A} and {\tt B} 
+are marked as maximally inserted implicit arguments and are
+put into the {\tt type\_scope} scope.
+
+\begin{coq_example*}
+Arguments respectful {A B}%type (R R')%signature _ _.
+\end{coq_example*}
+
+When interpreting a term, if some of the
 arguments of {\qualid} are built from a notation, then this notation
 is interpreted in the scope stack extended by the scopes bound (if any)
 to these arguments.
 
+Arguments scopes can be cleared with the following command:
+
+\begin{quote}
+{\tt Arguments {\qualid} : clear scopes}
+\end{quote}
+
 \begin{Variants}
-\item {\tt Global Arguments Scope} {\qualid} {\tt [ \nelist{\optscope}{} ]}
+\item {\tt Global Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{}
 
-This behaves like {\tt Arguments Scope} {\qualid} {\tt [
-\nelist{\optscope}{} ]} but survives when a section is closed instead
+This behaves like {\tt Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{}
+but survives when a section is closed instead
 of stopping working at section closing. Without the {\tt Global} modifier,
 the effect of the command stops when the section it belongs to ends.
 
-\item {\tt Local Arguments Scope} {\qualid} {\tt [ \nelist{\optscope}{} ]}
+\item {\tt Local Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{}
 
-This behaves like {\tt Arguments Scope} {\qualid} {\tt [
-    \nelist{\optscope}{} ]} but does not survive modules and files.
+This behaves like {\tt Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{}
+but does not survive modules and files.
 Without the {\tt Local} modifier, the effect of the command is
 visible from within other modules or files.
 
@@ -861,7 +886,7 @@ declared or defined constant.
 
 We give an overview of the scopes used in the standard library of
 {\Coq}. For a complete list of notations in each scope, use the
-commands {\tt Print Scopes} or {\tt Print Scopes {\scope}}.
+commands {\tt Print Scopes} or {\tt Print Scope {\scope}}.
 
 \subsubsection{\tt type\_scope}
 
@@ -1047,7 +1072,8 @@ at the time of use of the abbreviation.
 %except that abbreviations are used for printing (unless the modifier
 %\verb=(only parsing)= is given) while syntactic definitions were not.
 
-\section{Tactic Notations}
+\section{Tactic Notations
+\comindex{Tactic Notation}}
 
 Tactic notations allow to customize the syntax of the tactics of the
 tactic language\footnote{Tactic notations are just a simplification of
@@ -1140,8 +1166,6 @@ places where a list of the underlying entry can be used: {\nterm{entry}} is
 either {\tt\small constr}, {\tt\small hyp}, {\tt\small integer} or
 {\tt\small int\_or\_var}.
 
-% $Id: RefMan-syn.tex 13329 2010-07-26 11:05:39Z herbelin $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex
index 14d95ab8..198f8f30 100644
--- a/doc/refman/RefMan-tac.tex
+++ b/doc/refman/RefMan-tac.tex
@@ -497,6 +497,89 @@ Section~\ref{pattern} to transform the goal so that it gets the form
 
 \end{Variants}
 
+\subsection{{\tt apply {\term} in {\ident}}
+\tacindex{apply \ldots\ in}}
+
+This tactic applies to any goal.  The argument {\term} is a term
+well-formed in the local context and the argument {\ident} is an
+hypothesis of the context.  The tactic {\tt apply {\term} in {\ident}}
+tries to match the conclusion of the type of {\ident} against a non
+dependent premise of the type of {\term}, trying them from right to
+left.  If it succeeds, the statement of hypothesis {\ident} is
+replaced by the conclusion of the type of {\term}. The tactic also
+returns as many subgoals as the number of other non dependent premises
+in the type of {\term} and of the non dependent premises of the type
+of {\ident}.  If the conclusion of the type of {\term} does not match
+the goal {\em and} the conclusion is an inductive type isomorphic to a
+tuple type, then the tuple is (recursively) decomposed and the first
+component of the tuple of which a non dependent premise matches the
+conclusion of the type of {\ident}. Tuples are decomposed in a
+width-first left-to-right order (for instance if the type of {\tt H1}
+is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A=
+then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt
+  B}). The tactic {\tt apply} relies on first-order pattern-matching
+with dependent types.
+
+\begin{ErrMsgs}
+\item \errindex{Statement without assumptions}
+
+This happens if the type of {\term} has no non dependent premise.
+
+\item \errindex{Unable to apply}
+
+This happens if the conclusion of {\ident} does not match any of the
+non dependent premises of the type of {\term}.
+\end{ErrMsgs}
+
+\begin{Variants}
+\item {\tt apply \nelist{\term}{,} in {\ident}}
+
+This applies each of {\term} in sequence in {\ident}.
+
+\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}}
+
+This does the same but uses the bindings in each {\bindinglist} to 
+instantiate the parameters of the corresponding type of {\term}
+(see syntax of bindings in Section~\ref{Binding-list}).
+
+\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}}
+\tacindex{eapply {\ldots} in}
+
+This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in
+{\ident}} but turns unresolved bindings into existential variables, if
+any, instead of failing.
+
+\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}}
+
+This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in
+{\ident}} then destructs the hypothesis {\ident} along
+{\disjconjintropattern} as {\tt destruct {\ident} as
+{\disjconjintropattern}} would.
+
+\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}}
+
+This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}.
+
+\item {\tt simple apply {\term} in {\ident}}
+\tacindex{simple apply {\ldots} in} 
+\tacindex{simple eapply {\ldots} in} 
+
+This behaves like {\tt apply {\term} in {\ident}} but it reasons
+modulo conversion only on subterms that contain no variables to
+instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H :
+  forall y, id y = y -> True} and {\tt H0 : O = O} then {\tt simple
+  apply H in H0} does not succeed because it would require the
+conversion of {\tt f ?y} and {\tt O} where {\tt ?y} is a variable to
+instantiate.  Tactic {\tt simple apply {\term} in {\ident}} does not
+either traverse tuples as {\tt apply {\term} in {\ident}} does.
+
+\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\
+{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}
+
+This summarizes the different syntactic variants of {\tt apply {\term}
+  in {\ident}} and {\tt eapply {\term} in {\ident}}.
+\end{Variants}
+
 \subsection{{\tt set ( {\ident} {\tt :=} {\term} \tt )}
 \label{tactic:set}
 \tacindex{set}
@@ -508,6 +591,11 @@ hypotheses of the current goal and adds the new definition {\ident
 {\tt :=} \term} to the local context. The default is to make this
 replacement only in the conclusion.
 
+If {\term} has holes (i.e. subexpressions of the form ``\_''), the
+tactic first checks that all subterms matching the pattern are
+compatible before doing the replacement using the leftmost subterm
+matching the pattern.
+
 \begin{Variants}
 
 \item {\tt set (} {\ident} {\tt :=} {\term} {\tt ) in {\occgoalset}}
@@ -543,7 +631,7 @@ Section~\ref{Occurrences clauses}.
   This is a more general form of {\tt remember} that remembers the
   occurrences of {\term} specified by an occurrences set.
 
-\item {\tt pose (  {\ident} {\tt :=} {\term} {\tt )}}
+\item {\tt pose ( {\ident} := {\term} )}
   
   This adds the local definition {\ident} := {\term} to the current
   context without performing any replacement in the goal or in the
@@ -660,89 +748,6 @@ in the list of subgoals remaining to prove.
 
 \end{Variants}
 
-\subsection{{\tt apply {\term} in {\ident}}
-\tacindex{apply \ldots\ in}}
-
-This tactic applies to any goal.  The argument {\term} is a term
-well-formed in the local context and the argument {\ident} is an
-hypothesis of the context.  The tactic {\tt apply {\term} in {\ident}}
-tries to match the conclusion of the type of {\ident} against a non
-dependent premise of the type of {\term}, trying them from right to
-left.  If it succeeds, the statement of hypothesis {\ident} is
-replaced by the conclusion of the type of {\term}. The tactic also
-returns as many subgoals as the number of other non dependent premises
-in the type of {\term} and of the non dependent premises of the type
-of {\ident}.  If the conclusion of the type of {\term} does not match
-the goal {\em and} the conclusion is an inductive type isomorphic to a
-tuple type, then the tuple is (recursively) decomposed and the first
-component of the tuple of which a non dependent premise matches the
-conclusion of the type of {\ident}. Tuples are decomposed in a
-width-first left-to-right order (for instance if the type of {\tt H1}
-is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A=
-then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt
-  B}). The tactic {\tt apply} relies on first-order pattern-matching
-with dependent types.
-
-\begin{ErrMsgs}
-\item \errindex{Statement without assumptions}
-
-This happens if the type of {\term} has no non dependent premise.
-
-\item \errindex{Unable to apply}
-
-This happens if the conclusion of {\ident} does not match any of the
-non dependent premises of the type of {\term}.
-\end{ErrMsgs}
-
-\begin{Variants}
-\item {\tt apply \nelist{\term}{,} in {\ident}}
-
-This applies each of {\term} in sequence in {\ident}.
-
-\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}}
-
-This does the same but uses the bindings in each {\bindinglist} to 
-instantiate the parameters of the corresponding type of {\term}
-(see syntax of bindings in Section~\ref{Binding-list}).
-
-\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}}
-\tacindex{eapply {\ldots} in}
-
-This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in
-{\ident}} but turns unresolved bindings into existential variables, if
-any, instead of failing.
-
-\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}}
-
-This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in
-{\ident}} then destructs the hypothesis {\ident} along
-{\disjconjintropattern} as {\tt destruct {\ident} as
-{\disjconjintropattern}} would.
-
-\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}}
-
-This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}.
-
-\item {\tt simple apply {\term} in {\ident}}
-\tacindex{simple apply {\ldots} in} 
-\tacindex{simple eapply {\ldots} in} 
-
-This behaves like {\tt apply {\term} in {\ident}} but it reasons
-modulo conversion only on subterms that contain no variables to
-instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H :
-  forall y, id y = y -> True} and {\tt H0 : O = O} then {\tt simple
-  apply H in H0} does not succeed because it would require the
-conversion of {\tt f ?y} and {\tt O} where {\tt ?y} is a variable to
-instantiate.  Tactic {\tt simple apply {\term} in {\ident}} does not
-either traverse tuples as {\tt apply {\term} in {\ident}} does.
-
-\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\
-{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}
-
-This summarizes the different syntactic variants of {\tt apply {\term}
-  in {\ident}} and {\tt eapply {\term} in {\ident}}.
-\end{Variants}
-
 \subsection{\tt generalize \term
 \tacindex{generalize}
 \label{generalize}}
@@ -950,7 +955,8 @@ existential variable.
 \tacindex{instantiate}
 \label{instantiate}}
 
-The {\tt instantiate} tactic allows to solve an existential variable
+The {\tt instantiate} tactic allows to refine (see Section~\ref{refine})
+an existential variable
 with the term \term. The \num\  argument is the position of the
 existential variable from right to left in the conclusion. This cannot be
 the number of the existential variable since this number is different
@@ -1296,8 +1302,8 @@ computational expressions (i.e. with few dead code).
 \item {\tt lazy [\qualid$_1$\ldots\qualid$_k$]}\\
       {\tt lazy -[\qualid$_1$\ldots\qualid$_k$]}
 
-  These are respectively synonyms of {\tt cbv beta delta
-  [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt cbv beta delta
+  These are respectively synonyms of {\tt lazy beta delta
+  [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt lazy beta delta
   -[\qualid$_1$\ldots\qualid$_k$] iota zeta}.
 
 \item {\tt vm\_compute} \tacindex{vm\_compute}
@@ -1361,6 +1367,55 @@ by {\tt plus' := plus} is possibly unfolded and reused in the
 recursive calls, but a constant such as {\tt succ := plus (S O)} is
 never unfolded.
 
+The behaviour of {\tt simpl} can be tuned using the {\tt Arguments} vernacular
+command as follows:
+\begin{itemize}
+\item
+A constant can be marked to be never unfolded by {\tt simpl}:
+\begin{coq_example*}
+Arguments minus x y : simpl never
+\end{coq_example*}
+After that command an expression like {\tt (minus (S x) y)} is left untouched by
+the {\tt simpl} tactic.
+\item
+A constant can be marked to be unfolded only if applied to enough arguments.
+The number of arguments required can be specified using
+the {\tt /} symbol in the arguments list of the {\tt Arguments} vernacular
+command.
+\begin{coq_example*}
+Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x).
+Notation "f \o g" := (fcomp f g) (at level 50).
+Arguments fcomp {A B C} f g x /.
+\end{coq_example*}
+After that command the expression {\tt (f \verb+\+o g)} is left untouched by 
+{\tt simpl} while {\tt ((f \verb+\+o g) t)} is reduced to {\tt (f (g t))}.
+The same mechanism can be used to make a constant volatile, i.e. always 
+unfolded by {\tt simpl}.
+\begin{coq_example*}
+Definition volatile := fun x : nat => x.
+Arguments volatile / x.
+\end{coq_example*}
+\item
+A constant can be marked to be unfolded only if an entire set of arguments
+evaluates to a constructor. The {\tt !} symbol can be used to mark such
+arguments.
+\begin{coq_example*}
+Arguments minus !x !y.
+\end{coq_example*}
+After that command, the expression {\tt (minus (S x) y)} is left untouched by
+{\tt simpl}, while {\tt (minus (S x) (S y))} is reduced to {\tt (minus x y)}.
+\item
+A special heuristic to determine if a constant has to be unfolded can be
+activated with the following command:
+\begin{coq_example*}
+Arguments minus x y : simpl nomatch
+\end{coq_example*}
+The heuristic avoids to perform a simplification step that would
+expose a {\tt match} construct in head position. For example the
+expression {\tt (minus (S (S x)) (S y))} is simplified to
+{\tt (minus (S x) y)} even if an extra simplification is possible.
+\end{itemize}
+
 \tacindex{simpl \dots\ in}
 \begin{Variants}
 \item {\tt simpl {\term}}
@@ -1626,18 +1681,16 @@ Section~\ref{Cic-inductive-definitions}).
 \subsection{\tt induction \term
 \tacindex{induction}}
 
-This tactic applies to any goal. The type of the argument {\term} must
-be an inductive constant. Then, the tactic {\tt induction}
-generates subgoals, one for each possible form of {\term}, i.e. one
-for each constructor of the inductive type.
+This tactic applies to any goal. The argument {\term} must be of
+inductive type and the tactic {\tt induction} generates subgoals,
+one for each possible form of {\term}, i.e. one for each constructor
+of the inductive type.
 
-The tactic {\tt induction} automatically replaces every occurrences
-of {\term} in the conclusion and the hypotheses of the goal.  It
-automatically adds induction hypotheses (using names of the form {\tt
-  IHn1}) to the local context. If some hypothesis must not be taken
-into account in the induction hypothesis, then it needs to be removed
-first (you can also use the tactics {\tt elim} or {\tt simple induction},
-see below).
+If the argument is dependent in either the conclusion or some
+hypotheses of the goal, the argument is replaced by the appropriate
+constructor form in each of the resulting subgoals and induction
+hypotheses are added to the local context using names whose prefix is
+{\tt IH}.
 
 There are particular cases:
 
@@ -1649,10 +1702,13 @@ behaves as {\tt intros until {\ident}; induction {\ident}}.
 
 \item If {\term} is a {\num}, then {\tt induction {\num}} behaves as
 {\tt intros until {\num}} followed by {\tt induction} applied to the
-last introduced hypothesis.
+last introduced hypothesis. Remark: For simple induction on a numeral,
+use syntax {\tt induction ({\num})} (not very interesting anyway).
 
-\Rem For simple induction on a numeral, use syntax {\tt induction
-({\num})} (not very interesting anyway).
+\item The argument {\term} can also be a pattern of which holes are
+  denoted by ``\_''. In this case, the tactic checks that all subterms
+  matching the pattern in the conclusion and the hypotheses are
+  compatible and performs induction using this subterm.
 
 \end{itemize}
 
@@ -1840,10 +1896,19 @@ instantiate premises of the type of {\term$_2$}.
 \tacindex{destruct}}
 \label{destruct}
 
-The tactic {\tt destruct} is used to perform case analysis without
-recursion. Its behavior is similar to {\tt induction} except
-that no induction hypothesis is generated.  It applies to any goal and
-the type of {\term} must be inductively defined. There are particular cases:
+This tactic applies to any goal. The argument {\term} must be of
+inductive or coinductive type and the tactic generates subgoals, one
+for each possible form of {\term}, i.e. one for each constructor of
+the inductive or coinductive type. Unlike {\tt induction}, no
+induction hypothesis is generated by {\tt destruct}.
+
+If the argument is dependent in either the conclusion or some
+hypotheses of the goal, the argument is replaced by the appropriate
+constructor form in each of the resulting subgoals, thus performing
+case analysis. If non dependent, the tactic simply exposes the
+inductive or coinductive structure of the argument.
+
+There are special cases:
 
 \begin{itemize}
 
@@ -1853,10 +1918,13 @@ behaves as {\tt intros until {\ident}; destruct {\ident}}.
 
 \item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as
 {\tt intros until {\num}} followed by {\tt destruct} applied to the
-last introduced hypothesis.
+last introduced hypothesis. Remark: For destruction of a numeral, use
+syntax {\tt destruct ({\num})} (not very interesting anyway).
 
-\Rem For destruction of a numeral, use syntax {\tt destruct
-({\num})} (not very interesting anyway).
+\item The argument {\term} can also be a pattern of which holes are
+  denoted by ``\_''. In this case, the tactic checks that all subterms
+  matching the pattern in the conclusion and the hypotheses are
+  compatible and performs case analysis using this subterm.
 
 \end{itemize}
 
@@ -2599,12 +2667,7 @@ This tactic solves a goal of the form
 {\tt forall $x$ $y$:$R$, \{$x$=$y$\}+\{\verb|~|$x$=$y$\}}, where $R$
 is an inductive type such that its constructors do not take proofs or
 functions as arguments, nor objects in dependent types.
-
-\begin{Variants}
-\item {\tt decide equality {\term}$_1$ {\term}$_2$ }.\\
- Solves a goal of the form {\tt \{}\term$_1${\tt =}\term$_2${\tt
-\}+\{\verb|~|}\term$_1${\tt =}\term$_2${\tt \}}.
-\end{Variants}
+It solves goals of the form {\tt \{$x$=$y$\}+\{\verb|~|$x$=$y$\}} as well.
 
 \subsection{\tt compare \term$_1$ \term$_2$
 \tacindex{compare}}
@@ -2696,7 +2759,7 @@ If {\term} is a proof of a statement of conclusion
 then {\tt injection} applies injectivity as deep as possible to
 derive the equality of all the subterms of {\term$_1$} and {\term$_2$}
 placed in the same positions. For example, from {\tt (S
-  (S n))=(S (S (S m))} we may derive {\tt n=(S m)}.  To use this
+  (S n))=(S (S (S m)))} we may derive {\tt n=(S m)}.  To use this
 tactic {\term$_1$} and {\term$_2$} should be elements of an inductive
 set and they should be neither explicitly equal, nor structurally
 different. We mean by this that, if {\tt n$_1$} and {\tt n$_2$} are
@@ -4042,7 +4105,9 @@ databases are non empty and can be used.
 \begin{description}
 
 \item[\tt core] This special database is automatically used by
-  \texttt{auto}. It contains only basic lemmas about negation,
+  \texttt{auto}, except when pseudo-database \texttt{nocore} is
+  given to \texttt{auto}. The \texttt{core} database contains
+  only basic lemmas about negation,
   conjunction, and so on from. Most of the hints in this database come 
   from the \texttt{Init} and \texttt{Logic} directories.
 
@@ -4174,6 +4239,16 @@ e.g. \texttt{Require Import A.}).
 
 \SeeAlso {\tt Proof.} in Section~\ref{BeginProof}.
 
+\begin{Variants}
+\item {\tt Proof with {\tac} using {\ident$_1$ \dots {\ident$_n$}}}
+  Combines in a single line {\tt Proof with} and {\tt Proof using}, 
+  see~\ref{ProofUsing}
+\item {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}}
+  Combines in a single line {\tt Proof with} and {\tt Proof using}, 
+  see~\ref{ProofUsing}
+
+\end{Variants}
+
 \subsubsection[\tt Declare Implicit Tactic {\tac}.]{\tt Declare Implicit Tactic {\tac}.\comindex{Declare Implicit Tactic}}
 
 This command declares a tactic to be used to solve implicit arguments
@@ -4230,7 +4305,8 @@ general principle of mutual induction for objects in type {\term$_i$}.
 \item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}}
 
   Tries to generate a boolean equality and a proof of the
-  decidability of the usual equality.
+  decidability of the usual equality. If \ident$_i$ involves
+  some other inductive types, their equality has to be defined first.
 
 \item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\
   with\\
@@ -4332,8 +4408,6 @@ Chapter~\ref{TacticLanguage} gives examples of more complex
 user-defined tactics.
 
 
-% $Id: RefMan-tac.tex 14762 2011-12-04 20:48:36Z herbelin $ 
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex
index 5f201b67..bda4cff9 100644
--- a/doc/refman/RefMan-uti.tex
+++ b/doc/refman/RefMan-uti.tex
@@ -84,85 +84,42 @@ modules.
 
 The writing of a generic and complete {\tt Makefile} may be a tedious work
 and that's why \Coq\ provides a tool to automate its creation,
-{\tt coq\_makefile}. Given the files to compile, the command {\tt
-coq\_makefile} prints a 
-{\tt Makefile} on the standard output. So one has just to run the
-command:
+{\tt coq\_makefile}.
 
-\begin{quotation}
-\texttt{\% coq\_makefile} {\em file$_1$.v \dots\ file$_n$.v} \texttt{> Makefile}
-\end{quotation}
-
-The resulted {\tt Makefile} has a target {\tt depend} which computes the
-dependencies and puts them in a separate file {\tt .depend}, which is
-included by the {\tt Makefile}. 
-Therefore, you should create such a file before the first invocation
-of make. You can for instance use the command 
-
-\begin{quotation}
-\texttt{\% touch .depend}
-\end{quotation}
-
-Then, to initialize or update the modules dependencies, type in:
+Arguments are explain by \texttt{\% coq\_makefile --help}.  They can be directly
+written in the command line but it is recommended to write them in a file (called
+for example {\tt Make}) and then call {\tt coq\_makefile -f Make -o
+  Makefile}. That means options are in {\tt Make} file and output is {\tt
+  Makefile} This way, {\tt Makefile} will be automatically regenerated if
+something changes in {\tt Make}.
 
+The first time you use this tool, you may be happy with:
 \begin{quotation}
-\texttt{\% make depend}
+\texttt{\% \{ echo '-R .} {\em MyFancyLib} \texttt{' ; find -name '*.v' -print \} >
+  Make \&\& coq\_makefile -f Make -o Makefile}
 \end{quotation}
 
-There is a target {\tt all} to compile all the files {\em file$_1$
-\dots\ file$_n$}, and a generic target to produce a {\tt .vo} file from
-the corresponding {\tt .v} file (so you can do {\tt make} {\em file}{\tt.vo}
-to compile the file {\em file}{\tt.v}).
-
-{\tt coq\_makefile} can also handle the case of ML files and
-subdirectories. For more options type
-
-\begin{quotation}
-\texttt{\% coq\_makefile --help}
-\end{quotation}
+To customize things afterwards, remember:
+\begin{itemize}
+\item Coq files must end in {\tt .v}, caml modules in {\tt .ml4} if they
+  require camlp preproccessing (and in {\tt .ml} otherwise), and caml module signatures in {\tt
+    .mli}.
+\item If you give a directory directly as argument, it is because you provide a
+  Makefile for it in it.
+\item {\tt -R} option is for Coq, {\tt -I} for caml. The same directory can
+  ``included'' by both.
+  Using {\tt -R} option gives a right logical path and a correct installation
+  emplacement to your coq files.
+\item If your files depend on an external library that isn't install somewhere
+  looked by coqc, use {\tt OTHERFLAGS = '-R path/to/lib lib\_name'} option in your {\tt
+    Make} but don't do {\tt -R \dots} directly, the {\em make clean} command would
+  erase it!
+\end{itemize}
 
 \Warning To compile a project containing \ocaml{} files you must keep
 the sources of \Coq{} somewhere and have an environment variable named
 \texttt{COQTOP} that points to that directory.
 
-% \section{{\sf Coq\_SearchIsos}: information retrieval in a \Coq\ proofs
-% library}
-% \label{coqsearchisos}
-% \index{Coq\_SearchIsos@{\sf Coq\_SearchIsos}}
-
-% In the \Coq\ distribution, there is also a separated and independent tool,
-% called {\sf Coq\_SearchIsos}, which allows the search in accordance with {\tt
-% SearchIsos}\index{SearchIsos@{\tt SearchIsos}} (see Section~\ref{searchisos})
-% in a \Coq\ proofs library. More precisely, this program begins, once launched
-% by {\tt coqtop -searchisos}\index{coqtopsearchisos@{\tt
-% coqtop -searchisos}}, loading lightly (by using specifications functions)
-% all the \Coq\ objects files ({\tt .vo}) accessible by the {\tt LoadPath} (see
-% Section~\ref{loadpath}). Next, a prompt appears and four commands are then
-% available:
-
-% \begin{description}
-% \item [{\tt SearchIsos}]\ \\
-%   Scans the fixed context.
-% \item [{\tt Time}]\index{Time@{\tt Time}}\ \\
-%   Turns on the Time Search Display mode (see Section~\ref{time}).
-% \item [{\tt Untime}]\index{Untime@{\tt Untime}}\ \\
-%   Turns off the Time Search Display mode (see Section~\ref{time}).
-% \item [{\tt Quit}]\index{Quit@{\tt Quit}}\ \\
-%   Ends the {\tt coqtop -searchisos} session.
-% \end{description}
-
-% When running {\tt coqtop -searchisos} you can use the two options:
-
-% \begin{description}
-% \item[{\tt -opt}]\ \\
-%   Runs the native-code version of {\sf Coq\_SearchIsos}.
-
-% \item[{\tt -image} {\em file}]\ \\
-%   This option sets the binary image to be used to be {\em file}
-%   instead of the standard one. Not of general use.
-% \end{description}
-
-
 \section[Documenting \Coq\ files with coqdoc]{Documenting \Coq\ files with coqdoc\label{coqdoc}
 \index{Coqdoc@{\sf coqdoc}}}
 
@@ -200,8 +157,8 @@ have been completely produced with {\tt coq-tex}.
 \subsection{The \Coq\ Emacs mode}
 
 \Coq\ comes with a Major mode for \emacs, {\tt coq.el}. This mode provides
-syntax highlighting (assuming your \emacs\ library provides
-{\tt hilit19.el}) and also a rudimentary indentation facility
+syntax highlighting
+and also a rudimentary indentation facility
 in the style of the Caml \emacs\ mode.
 
 Add the following lines to your \verb!.emacs! file:
@@ -232,7 +189,7 @@ Instructions to use it are contained in this file.
 \subsection[Proof General]{Proof General\index{Proof General}}
 
 Proof General is a generic interface for proof assistants based on
-Emacs (or XEmacs). The main idea is that the \Coq\ commands you are
+Emacs. The main idea is that the \Coq\ commands you are
 editing are sent to a \Coq\ toplevel running behind Emacs and the
 answers of the system automatically inserted into other Emacs buffers. 
 Thus you don't need to copy-paste the \Coq\ material from your files
@@ -264,8 +221,6 @@ There are man pages for the commands {\tt coqdep}, {\tt gallina} and
 \RefManCutCommand{ENDREFMAN=\thepage}
 %END LATEX
 
-% $Id: RefMan-uti.tex 11975 2009-03-14 11:29:36Z letouzey $
-
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: t
diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex
index b0ada528..cc42c2ef 100644
--- a/doc/refman/Reference-Manual.tex
+++ b/doc/refman/Reference-Manual.tex
@@ -148,4 +148,3 @@ Options A and B of the licence are {\em not} elected.}
 \end{document}
 
 
-% $Id: Reference-Manual.tex 14090 2011-05-03 13:34:16Z pboutill $ 
diff --git a/doc/refman/Setoid.tex b/doc/refman/Setoid.tex
index 20c8c02b..8e1bb10c 100644
--- a/doc/refman/Setoid.tex
+++ b/doc/refman/Setoid.tex
@@ -710,5 +710,4 @@ using the command \texttt{Typeclasses Opaque} (see \S \ref{TypeclassesTransparen
 %%% Local Variables: 
 %%% mode: latex
 %%% TeX-master: "Reference-Manual"
-%%% compile-command: "make -C ../.. -f Makefile.stage3 doc/refman/Reference-Manual.pdf"
 %%% End: 
diff --git a/doc/refman/biblio.bib b/doc/refman/biblio.bib
index f93b66f9..192a9699 100644
--- a/doc/refman/biblio.bib
+++ b/doc/refman/biblio.bib
@@ -1246,6 +1246,19 @@ Languages},
     publisher = {}
 }
 
+@article{LeeWerner11,
+  author    = {Gyesik Lee and
+               Benjamin Werner},
+  title     = {Proof-irrelevant model of {CC} with predicative induction
+               and judgmental equality},
+  journal   = {Logical Methods in Computer Science},
+  volume    = {7},
+  number    = {4},
+  year      = {2011},
+  ee        = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011},
+  bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
 @Comment{cross-references, must be at end}
 
 @Book{Bastad92,
diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex
index bfd7f3f2..cb32adfc 100755
--- a/doc/stdlib/Library.tex
+++ b/doc/stdlib/Library.tex
@@ -3,6 +3,7 @@
 \usepackage[utf8x]{inputenc}
 \usepackage[T1]{fontenc}
 \usepackage{fullpage}
+\usepackage{amsfonts}
 \usepackage[color]{../../coqdoc}
 
 \input{../common/version}
@@ -61,4 +62,3 @@ you can access from the \Coq\ home page at
 
 \end{document}
 
-% $Id: Library.tex 12363 2009-09-28 15:04:07Z letouzey $ 
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index 541fa1b9..35c13f3b 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.
@@ -109,7 +121,6 @@ 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
@@ -118,31 +129,40 @@ 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>:
+
+  <dt> <b>PArith</b>:
     Binary positive integers
   </dt>
-  <dd> 
-    theories/NArith/BinPos.v
+  <dd>
+    theories/PArith/BinPosDef.v
+    theories/PArith/BinPos.v
+    theories/PArith/Pnat.v
+    theories/PArith/POrderedType.v
+    (theories/PArith/PArith.v)
+  </dd>
+
+  <dt> <b>NArith</b>:
+    Binary natural numbers
+  </dt>
+  <dd>
+    theories/NArith/BinNatDef.v
     theories/NArith/BinNat.v
-    (theories/NArith/NArith.v)
-    theories/NArith/Pnat.v
     theories/NArith/Nnat.v
     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
+    theories/NArith/Ndiv_def.v
+    theories/NArith/Ngcd_def.v
+    theories/NArith/Nsqrt_def.v
+    (theories/NArith/NArith.v)
   </dd>
 
   <dt> <b>ZArith</b>:
        Binary integers
   </dt>
-  <dd> 
+  <dd>
+    theories/ZArith/BinIntDef.v
     theories/ZArith/BinInt.v
     theories/ZArith/Zorder.v
     theories/ZArith/Zcompare.v
@@ -160,20 +180,20 @@ through the <tt>Require Import</tt> command.</p>
     theories/ZArith/Zhints.v
     (theories/ZArith/ZArith_base.v)
     theories/ZArith/Zcomplements.v
-    theories/ZArith/Zsqrt.v
+    theories/ZArith/Zsqrt_compat.v
     theories/ZArith/Zpow_def.v
+    theories/ZArith/Zpow_alt.v
     theories/ZArith/Zpower.v
     theories/ZArith/Zdiv.v
+    theories/ZArith/Zquot.v
+    theories/ZArith/Zeuclid.v
     theories/ZArith/Zlogarithm.v
     (theories/ZArith/ZArith.v)
     theories/ZArith/Zgcd_alt.v
     theories/ZArith/Zwf.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>
 
@@ -198,10 +218,9 @@ through the <tt>Require Import</tt> command.</p>
   <dt> <b>Numbers</b>: 
     An experimental modular architecture for arithmetic
   </dt>
-  <dd>
-    <dl>
-    <dt> <b>&nbsp;&nbsp;Prelude</b>:</dt>
+    <dt> <b>&nbsp;&nbsp;Prelude</b>: 
     <dd>
+    theories/Numbers/BinNums.v
     theories/Numbers/NumPrelude.v
     theories/Numbers/BigNumPrelude.v
     theories/Numbers/NaryFunctions.v
@@ -209,7 +228,6 @@ through the <tt>Require Import</tt> command.</p>
 
     <dt> <b>&nbsp;&nbsp;NatInt</b>:
        Abstract mixed natural/integer/cyclic arithmetic
-    </dt>
     <dd>
     theories/Numbers/NatInt/NZAdd.v
     theories/Numbers/NatInt/NZAddOrder.v
@@ -221,11 +239,17 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/NatInt/NZOrder.v
     theories/Numbers/NatInt/NZDomain.v
     theories/Numbers/NatInt/NZProperties.v
+    theories/Numbers/NatInt/NZParity.v
+    theories/Numbers/NatInt/NZPow.v
+    theories/Numbers/NatInt/NZSqrt.v
+    theories/Numbers/NatInt/NZLog.v
+    theories/Numbers/NatInt/NZGcd.v
+    theories/Numbers/NatInt/NZBits.v
     </dd>
+    </dt>
 
-    <dt> <b>&nbsp;&nbsp;Cyclic</b>:
+    <dt> <b>&nbsp;&nbsp;Cyclic</b>: 
        Abstract and 31-bits-based cyclic arithmetic
-    </dt>
     <dd>
     theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
     theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -244,10 +268,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Cyclic/Int31/Int31.v
     theories/Numbers/Cyclic/ZModulo/ZModulo.v
     </dd>
+    </dt>
 
-    <dt> <b>&nbsp;&nbsp;Natural</b>:
+    <dt> <b>&nbsp;&nbsp;Natural</b>: 
        Abstract and 31-bits-words-based natural arithmetic
-    </dt>
     <dd>
     theories/Numbers/Natural/Abstract/NAdd.v
     theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -260,6 +284,14 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Natural/Abstract/NStrongRec.v
     theories/Numbers/Natural/Abstract/NSub.v
     theories/Numbers/Natural/Abstract/NDiv.v
+    theories/Numbers/Natural/Abstract/NMaxMin.v
+    theories/Numbers/Natural/Abstract/NParity.v
+    theories/Numbers/Natural/Abstract/NPow.v
+    theories/Numbers/Natural/Abstract/NSqrt.v
+    theories/Numbers/Natural/Abstract/NLog.v
+    theories/Numbers/Natural/Abstract/NGcd.v
+    theories/Numbers/Natural/Abstract/NLcm.v
+    theories/Numbers/Natural/Abstract/NBits.v
     theories/Numbers/Natural/Abstract/NProperties.v
     theories/Numbers/Natural/Binary/NBinary.v
     theories/Numbers/Natural/Peano/NPeano.v
@@ -270,10 +302,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Natural/BigN/NMake.v
     theories/Numbers/Natural/BigN/NMake_gen.v
     </dd>
+    </dt>
 
     <dt> <b>&nbsp;&nbsp;Integer</b>: 
        Abstract and concrete (especially 31-bits-words-based) integer arithmetic
-    </dt>
     <dd>
     theories/Numbers/Integer/Abstract/ZAdd.v
     theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -282,11 +314,17 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Integer/Abstract/ZLt.v
     theories/Numbers/Integer/Abstract/ZMul.v
     theories/Numbers/Integer/Abstract/ZMulOrder.v
+    theories/Numbers/Integer/Abstract/ZSgnAbs.v
+    theories/Numbers/Integer/Abstract/ZMaxMin.v
+    theories/Numbers/Integer/Abstract/ZParity.v
+    theories/Numbers/Integer/Abstract/ZPow.v
+    theories/Numbers/Integer/Abstract/ZGcd.v
+    theories/Numbers/Integer/Abstract/ZLcm.v
+    theories/Numbers/Integer/Abstract/ZBits.v
+    theories/Numbers/Integer/Abstract/ZProperties.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
@@ -294,17 +332,17 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Integer/BigZ/BigZ.v
     theories/Numbers/Integer/BigZ/ZMake.v
     </dd>
+    </dt>
 
     <dt><b>&nbsp;&nbsp;Rational</b>:
        Abstract and 31-bits-words-based rational arithmetic
-    </dt>
     <dd>
     theories/Numbers/Rational/SpecViaQ/QSig.v
     theories/Numbers/Rational/BigQ/BigQ.v
     theories/Numbers/Rational/BigQ/QMake.v
     </dd>
-    </dl>
-  </dd>
+    </dt>
+  </dt>
   
   <dt> <b>Relations</b>:
        Relations (definitions and basic results)
@@ -344,7 +382,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Sets/Uniset.v
   </dd>
     
-  <dt> <b>Classes</b>:</dt>
+  <dt> <b>Classes</b>:
   <dd> 
     theories/Classes/Init.v
     theories/Classes/RelationClasses.v
@@ -359,7 +397,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Classes/RelationPairs.v
   </dd>
 
-  <dt> <b>Setoids</b>:</dt>
+  <dt> <b>Setoids</b>:
   <dd> 
     theories/Setoids/Setoid.v
   </dd>
@@ -373,7 +411,6 @@ through the <tt>Require Import</tt> command.</p>
     theories/Lists/SetoidList.v
     theories/Lists/Streams.v
     theories/Lists/StreamMemo.v
-    theories/Lists/TheoryList.v
     theories/Lists/ListTactics.v
   </dd>
 
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 39cedbec..c071c4a2 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 Numbers"
+LIBDIRS="Arith PArith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes Numbers"
 
 rm -f library.files.ls.tmp
 (cd $COQSRC/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp
diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index
index c8782e93..8e496fdd 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 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" 
+LIBDIRS="Init Logic Structures Bool Arith PArith 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/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex
index 723295bf..43c8bf62 100755
--- a/doc/tutorial/Tutorial.tex
+++ b/doc/tutorial/Tutorial.tex
@@ -59,7 +59,7 @@ invocation of \Coq\ delivers a message such as:
 \begin{flushleft}
 \begin{verbatim}
 unix:~> coqtop
-Welcome to Coq 8.3 (October 2010)
+Welcome to Coq 8.2 (January 2009)
 
 Coq < 
 \end{verbatim}
@@ -69,7 +69,7 @@ Coq <
 The first line gives a banner stating the precise version of \Coq~
 used. You should always return this banner when you report an anomaly
 to our bug-tracking system
-\verb|http://coq.inria.fr/bugs|
+\verb|http://logical.futurs.inria.fr/coq-bugs|
 
 \chapter{Basic Predicate Calculus}
 
@@ -1574,4 +1574,3 @@ with \Coq, in order to acquaint yourself with various proof techniques.
 
 \end{document}
 
-% $Id: Tutorial.tex 13547 2010-10-14 12:35:00Z notin $ 
diff --git a/ide/FAQ b/ide/FAQ
index 2079ef6c..f07f229f 100644
--- a/ide/FAQ
+++ b/ide/FAQ
@@ -6,8 +6,8 @@ R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more i
 Q1) How to enable Emacs keybindings?
 R1: Insert 
 	gtk-key-theme-name = "Emacs"
-    in your ".coqide-gtk2rc" file. It may be in the current dir
-    or in $HOME dir. This is done by default.
+    in your "coqide-gtk2rc" file. It should be in $XDG_CONFIG_DIRS/coq dir.
+    This is done by default.
 
 Q2) How to enable antialiased fonts?
 R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2.
@@ -41,7 +41,7 @@ R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script
 	and then to add   
 		bind "F13" {"insert-at-cursor" ("∀")}
 		bind "F14" {"insert-at-cursor" ("∃")}
-	to your "binding "text"" section in .coqiderc-gtk2rc.
+	to your "binding "text"" section in coqiderc-gtk2rc.
 	The strange ("∀") argument is the UTF-8 encoding for
 	0x2200. 
 	You can compute these encodings using the lablgtk2 toplevel with 
@@ -49,21 +49,15 @@ R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script
 	Further symbols can be bound on higher Fxx keys or on even on other keys you
 	do not need .
 
-Q6) How to build a custom CoqIde with user ml code?
-R6) Use 
-	coqmktop -ide -byte m1.cmo...mi.cmo
-    or 
-	coqmktop -ide -opt m1.cmx...mi.cmx
-
-Q7) How to customize the shortcuts for menus?
-R7) Two solutions are offered:
-  - Edit $HOME/.coqide.keys by hand or
-  - Add "gtk-can-change-accels = 1" in your .coqide-gtk2rc file. Then
+Q6) How to customize the shortcuts for menus?
+R6) Two solutions are offered:
+  - Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or
+  - Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then
     from CoqIde, you may select a menu entry and press the desired 
     shortcut. 
 
-Q8) What encoding should I use? What is this \x{iiii} in my file?
-R8) The encoding option is related to the way files are saved. 
+Q7) What encoding should I use? What is this \x{iiii} in my file?
+R7) The encoding option is related to the way files are saved.
  Keep it as UTF-8 until it becomes important for you to exchange files 
  with non UTF-8 aware applications.
  If you choose something else than UTF-8, then missing characters will 
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
index 1df83803..939238d3 100644
--- a/ide/command_windows.ml
+++ b/ide/command_windows.ml
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command_windows.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-class command_window () =
+class command_window coqtop current =
 (*  let window = GWindow.window
 		 ~allow_grow:true ~allow_shrink:true
 		 ~width:500 ~height:250
@@ -76,14 +74,10 @@ object(self)
     notebook#goto_page (notebook#page_num frame#coerce);
     let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
     let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-    let combo = GEdit.combo ~popdown_strings:Coq_commands.state_preserving
-		  ~enable_arrow_keys:true
-		  ~allow_empty:false
-		  ~value_in_list:false (* true is not ok with disable_activate...*)
+    let (combo,_) = GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving
 		  ~packing:hbox#pack
 		  ()
     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"
@@ -97,6 +91,7 @@ object(self)
 	~packing:(vbox#pack ~fill:true ~expand:true) () in
     let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
     let result = GText.view ~packing:r_bin#add () in
+    result#misc#modify_font !current.Preferences.text_font;
     result#misc#set_can_focus true; (* false causes problems for selection *)
     result#set_editable false;
     let callback () =
@@ -106,11 +101,14 @@ object(self)
 	then com ^ " " else com ^ " " ^ entry#text ^" . "
       in
       try
-	ignore(Coq.interp false phrase);
-	result#buffer#set_text
-	  ("Result for command " ^ phrase ^ ":\n" ^ Ideutils.read_stdout ())
+        result#buffer#set_text
+          (match Coq.interp !coqtop ~raw:true phrase with
+             | Interface.Fail (l,str) ->
+                 ("Error while interpreting "^phrase^":\n"^str)
+             | Interface.Good results ->
+                 ("Result for command " ^ phrase ^ ":\n" ^ results))
       with e ->
-	let (s,loc) = Coq.process_exn e in
+	let s = Printexc.to_string e in
 	assert (Glib.Utf8.validate s);
 	result#buffer#set_text s
     in
@@ -137,14 +135,6 @@ object(self)
     self#frame#misc#show ()
 
   initializer
-    ignore (new_page_menu#connect#clicked self#new_command);
+    ignore (new_page_menu#connect#clicked ~callback:self#new_command);
    (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*)
 end
-
-let command_window = ref None
-
-let main () = command_window := Some (new command_window ())
-
-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 0f5c208b..8c7319aa 100644
--- a/ide/command_windows.mli
+++ b/ide/command_windows.mli
@@ -1,22 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command_windows.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 class command_window :
-  unit ->
+  Coq.coqtop ref -> Preferences.pref ref ->
   object
     method new_command : ?command:string -> ?term:string -> unit -> unit
     method frame : GBin.frame
   end
-
- val main : unit -> unit
-
-val command_window : unit -> command_window
-
-
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index 3724f2bf..57699c68 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -1,19 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: config_lexer.mll 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 {
 
   open Lexing
   open Format
-  open Config_parser
-  open Util
+  open Minilib
 
   let string_buffer = Buffer.create 1024
 
@@ -22,34 +19,36 @@
 let space = [' ' '\010' '\013' '\009' '\012']
 let char = ['A'-'Z' 'a'-'z' '_' '0'-'9']
 let ident = char+
+let ignore = space | ('#' [^ '\n']*)
 
-rule token = parse
-  | space+        { token lexbuf }
-  | '#' [^ '\n']* { token lexbuf }
-  | ident { IDENT (lexeme lexbuf) }
-  | '='   { EQUAL }
-  | '"'   { 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)) }
+rule prefs m = parse
+  |ignore* (ident as id) ignore* '=' { let conf = str_list [] lexbuf in
+				 prefs (Stringmap.add id conf m) lexbuf }
   | _     { let c = lexeme_start lexbuf in
-	    eprintf ".coqiderc: invalid character (%d)\n@." c;
-	    token lexbuf }
-  | eof   { EOF }
+	      eprintf "coqiderc: invalid character (%d)\n@." c;
+	      prefs m lexbuf }
+  | eof   { m }
+
+and str_list l = parse
+  | ignore* '"'   { Buffer.reset string_buffer;
+		    Buffer.add_char string_buffer '"';
+		    string lexbuf;
+		    let s = Buffer.contents string_buffer in
+		      str_list ((Scanf.sscanf s "%S" (fun s -> s))::l) lexbuf }
+  |ignore+ { List.rev l}
 
 and string = parse
   | '"'  { Buffer.add_char string_buffer '"' }
   | '\\' '"' | _
          { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf }
-  | eof  { eprintf ".coqiderc: unterminated string\n@." }
+  | eof  { eprintf "coqiderc: unterminated string\n@." }
 
 {
 
   let load_file f =
     let c = open_in f in
     let lb = from_channel c in
-    let m = Config_parser.prefs token lb in
+    let m = prefs Stringmap.empty lb in
     close_in c;
     m
 
diff --git a/ide/config_parser.mly b/ide/config_parser.mly
deleted file mode 100644
index d49e22eb..00000000
--- a/ide/config_parser.mly
+++ /dev/null
@@ -1,43 +0,0 @@
-/************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************/
-
-/* $Id: config_parser.mly 14641 2011-11-06 11:59:10Z herbelin $ */
-
-%{
-
-  open Parsing
-  open Util
-
-%}
-
-%token <string> IDENT STRING
-%token EQUAL EOF
-
-%type <(string list) Util.Stringmap.t> prefs
-%start prefs
-
-%%
-
-prefs:
-  pref_list EOF { $1 }
-;
-
-pref_list:
-   pref_list pref { let (k,d) = $2 in Stringmap.add k d $1 }
- | /* epsilon */  { Stringmap.empty }
-;
-
-pref:
-  IDENT EQUAL string_list { ($1, List.rev $3) }
-;
-
-string_list:
-   string_list STRING { $2 :: $1 }
- | /* epsilon */      { [] }
-;
-
diff --git a/ide/coq.ml b/ide/coq.ml
index 1c6229b4..16a07b01 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -1,53 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Vernac
-open Vernacexpr
-open Pfedit
-open Pp
-open Util
-open Names
-open Term
-open Printer
-open Environ
-open Evarutil
-open Evd
-open Decl_mode
-open Hipattern
-open Tacmach
-open Reductionops
-open Termops
-open Namegen
 open Ideutils
 
-let msg m =
-  let b =  Buffer.create 103 in
-  Pp.msg_with (Format.formatter_of_buffer b) m;
-  Buffer.contents b
-
-let msgnl m =
-  (msg m)^"\n"
-
-let init () =
-  (* To hide goal in lower window.
-     Problem: should not hide "xx is assumed"
-     messages *)
-(**)
-  Flags.make_silent true;
-  (* don't set a too large undo stack because Edit.create allocates an array *)
-  Pfedit.set_undo (Some 5000);
-(**)
-  Coqtop.init_ide ()
-
-
-let i = ref 0
+(** * Version and date *)
 
 let get_version_date () =
   let date =
@@ -55,7 +16,12 @@ let get_version_date () =
     then Coq_config.date
     else "<date not printable>" in
   try
-    let ch = open_in (Coq_config.coqsrc^"/revision") in
+    (* the following makes sense only when running with local layout *)
+    let coqroot = Filename.concat
+      (Filename.dirname Sys.executable_name)
+      Filename.parent_dir_name
+    in
+    let ch = open_in (Filename.concat coqroot "revision") in
     let ver = input_line ch in
     let rev = input_line ch in
     (ver,rev)
@@ -71,656 +37,191 @@ let version () =
       "The Coq Proof Assistant, version %s (%s)\
        \nArchitecture %s running %s operating system\
        \nGtk version is %s\
-       \nThis is the %s version (%s is the best one for this architecture and OS)\
+       \nThis is %s (%s is the best one for this architecture and OS)\
        \n"
       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")
-
-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 ->
-      let fdir =
-        Filename.concat (Envars.coqlib ()) (Filename.concat "theories" s) in
-      prerr_endline (" Comparing to: "^fdir);
-      if is_same_file fdir then (prerr_endline " YES";true)
-      else (prerr_endline"NO";false))
-    Coq_config.theories_dirs
-
-let is_in_loadpath dir =
-  Library.is_in_load_paths (System.physical_path_of_string dir)
-
-let is_in_coq_path f =
+      (Filename.basename Sys.executable_name)
+      Coq_config.best
+
+
+(** * Initial checks by launching test coqtop processes *)
+
+let rec read_all_lines in_chan =
+  try
+    let arg = input_line in_chan in
+    arg::(read_all_lines in_chan)
+  with End_of_file -> []
+
+let filter_coq_opts args =
+  let argstr = String.concat " " (List.map Filename.quote args) in
+  let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in
+  let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
+  let filtered_args = read_all_lines oc in
+  let message = read_all_lines ec in
+  match Unix.close_process_full (oc,ic,ec) with
+    | Unix.WEXITED 0 -> true,filtered_args
+    | Unix.WEXITED 2 -> false,filtered_args
+    | _ -> false,message
+
+exception Coqtop_output of string list
+
+let check_connection args =
   try
-  let base = Filename.chop_extension (Filename.basename f) in
-  let _ = Library.locate_qualified_library false
-	    (Libnames.make_qualid Names.empty_dirpath
-	       (Names.id_of_string base)) in
-  prerr_endline (f ^ " is in coq path");
-  true
-  with _ ->
-    prerr_endline (f ^ " is NOT in coq path");
-    false
-
-let is_in_proof_mode () =
-  match Decl_mode.get_current_mode () with
-      Decl_mode.Mode_none -> false
-    | _ -> true
-
-let user_error_loc l s =
-  raise (Stdpp.Exc_located (l, Util.UserError ("CoqIde", s)))
-
-type printing_state = {
-  mutable printing_implicit : bool;
-  mutable printing_coercions : bool;
-  mutable printing_raw_matching : bool;
-  mutable printing_no_notation : bool;
-  mutable printing_all : bool;
-  mutable printing_evar_instances : bool;
-  mutable printing_universes : bool;
-  mutable printing_full_all : bool
+    let argstr = String.concat " " (List.map Filename.quote args) in
+    let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in
+    let ic = Unix.open_process_in cmd in
+    let lines = read_all_lines ic in
+    match Unix.close_process_in ic with
+    | Unix.WEXITED 0 -> prerr_endline "coqtop seems ok"
+    | _ -> raise (Coqtop_output lines)
+  with
+    | End_of_file ->
+      Minilib.safe_prerr_endline "Cannot start connection with coqtop";
+      exit 1
+    | Coqtop_output lines ->
+      Minilib.safe_prerr_endline "Connection with coqtop failed:";
+      List.iter Minilib.safe_prerr_endline lines;
+      exit 1
+
+(** * The structure describing a coqtop sub-process *)
+
+type coqtop = {
+  pid : int; (* Unix process id *)
+  cout : in_channel ;
+  cin : out_channel ;
+  sup_args : string list;
 }
 
-let printing_state = {
-  printing_implicit = false;
-  printing_coercions = false;
-  printing_raw_matching = false;
-  printing_no_notation = false;
-  printing_all = false;
-  printing_evar_instances = false;
-  printing_universes = false;
-  printing_full_all = false;
-}
+(** * Count of all active coqtops *)
 
-let printing_implicit_data = ["Printing";"Implicit"], false
-let printing_coercions_data = ["Printing";"Coercions"], false
-let printing_raw_matching_data = ["Printing";"Matching"], true
-let printing_no_synth_data = ["Printing";"Synth"], true
-let printing_no_notation_data = ["Printing";"Notations"], true
-let printing_all_data = ["Printing";"All"], false
-let printing_evar_instances_data = ["Printing";"Existential";"Instances"],false
-let printing_universes_data = ["Printing";"Universes"], false
-
-let known_options = ref []
-
-let prepare_option (l,dft) =
-  known_options := l :: !known_options;
-  let set = (String.concat " " ("Set"::l)) ^ "." in
-  let unset = (String.concat " " ("Unset"::l)) ^ "." in
-  if dft then unset,set else set,unset
-
-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
-let with_printing_raw_matching = prepare_option printing_raw_matching_data
-let with_printing_no_synth = prepare_option printing_no_synth_data
-let with_printing_no_notation = prepare_option printing_no_notation_data
-let with_printing_all = prepare_option printing_all_data
-let with_printing_evar_instances = prepare_option printing_evar_instances_data
-let with_printing_universes = prepare_option printing_universes_data
-
-let make_option_commands () =
-  let p = printing_state in
-  (if p.printing_implicit then [with_printing_implicit] else [])@
-  (if p.printing_coercions then [with_printing_coercions] else [])@
-  (if p.printing_raw_matching then [with_printing_raw_matching;with_printing_no_synth] else [])@
-  (if p.printing_no_notation then [with_printing_no_notation] else [])@
-  (if p.printing_all then [with_printing_all] else [])@
-  (if p.printing_evar_instances then [with_printing_evar_instances] else [])@
-  (if p.printing_universes then [with_printing_universes] else [])@
-  (if p.printing_full_all then [with_printing_all;with_printing_evar_instances;with_printing_universes] else [])
-
-let make_option_commands () =
-  let l = make_option_commands () in
-  List.iter (fun (a,b) -> prerr_endline a; prerr_endline b) l;
-  l
-
-type command_attribute =
-    NavigationCommand | QueryCommand | DebugCommand | KnownOptionCommand
-  | OtherStatePreservingCommand | GoalStartingCommand | SolveCommand
-  | ProofEndingCommand
-
-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 _ -> []
-
-  (* Syntax *)
-  | VernacTacticNotation _ -> []
-  | VernacSyntaxExtension _ -> []
-  | VernacDelimiters _ -> []
-  | VernacBindScope _ -> []
-  | VernacOpenCloseScope _ -> []
-  | VernacArgumentsScope _ -> []
-  | VernacInfix _ -> []
-  | VernacNotation _ -> []
-
-  (* Gallina *)
-  | VernacDefinition (_,_,DefineBody _,_) -> []
-  | VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand]
-  | VernacStartTheoremProof _ -> [GoalStartingCommand]
-  | VernacEndProof _ -> [ProofEndingCommand]
-  | VernacExactProof _ -> [ProofEndingCommand]
-
-  | VernacAssumption _ -> []
-  | VernacInductive _ -> []
-  | VernacFixpoint _ -> []
-  | VernacCoFixpoint _ -> []
-  | VernacScheme _ -> []
-  | VernacCombinedScheme _ -> []
-
-  (* Modules *)
-  | VernacDeclareModule _ -> []
-  | VernacDefineModule _  -> []
-  | VernacDeclareModuleType _ -> []
-  | VernacInclude _ -> []
-
-  (* Gallina extensions *)
-  | VernacBeginSection _ -> []
-  | VernacEndSegment _ -> []
-  | VernacRequire _ -> []
-  | VernacImport _ -> []
-  | VernacCanonical _ -> []
-  | VernacCoercion _ -> []
-  | VernacIdentityCoercion _ -> []
-
-  (* Type classes *)
-  | VernacInstance _ -> []
-  | VernacContext _ -> []
-  | VernacDeclareInstance _ -> []
-  | VernacDeclareClass _ -> []
-
-  (* Solving *)
-  | VernacSolve _ -> [SolveCommand]
-  | VernacSolveExistential _ -> [SolveCommand]
-
-  (* MMode *)
-  | VernacDeclProof -> [SolveCommand]
-  | VernacReturn -> [SolveCommand]
-  | VernacProofInstr _ -> [SolveCommand]
-
-  (* Auxiliary file and library management *)
-  | VernacRequireFrom _ -> []
-  | VernacAddLoadPath _ -> []
-  | VernacRemoveLoadPath _ -> []
-  | VernacAddMLPath _ -> []
-  | VernacDeclareMLModule _ -> []
-  | VernacChdir _ -> [OtherStatePreservingCommand]
-
-  (* State management *)
-  | VernacWriteState _ -> []
-  | VernacRestoreState _ -> []
-
-  (* Resetting *)
-  | VernacRemoveName _ -> [NavigationCommand]
-  | VernacResetName _ -> [NavigationCommand]
-  | VernacResetInitial -> [NavigationCommand]
-  | VernacBack _ -> [NavigationCommand]
-  | VernacBackTo _ -> [NavigationCommand]
-
-  (* Commands *)
-  | VernacDeclareTacticDefinition _ -> []
-  | VernacCreateHintDb _ -> []
-  | VernacHints _ -> []
-  | VernacSyntacticDefinition _ -> []
-  | VernacDeclareImplicits _ -> []
-  | VernacDeclareReduction _ -> []
-  | VernacReserve _ -> []
-  | VernacGeneralizable _ -> []
-  | VernacSetOpacity _ -> []
-  | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand]
-  | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) ->
-      if coqide_known_option o then [KnownOptionCommand] else []
-  | VernacSetOption _ -> []
-  | VernacRemoveOption _ -> []
-  | VernacAddOption _ -> []
-  | VernacMemOption _ -> [QueryCommand]
-
-  | VernacPrintOption _ -> [QueryCommand]
-  | VernacCheckMayEval _ -> [QueryCommand]
-  | VernacGlobalCheck _ -> [QueryCommand]
-  | VernacPrint _ -> [QueryCommand]
-  | VernacSearch _ -> [QueryCommand]
-  | VernacLocate _ -> [QueryCommand]
-
-  | VernacComments _ -> [OtherStatePreservingCommand]
-  | VernacNop -> [OtherStatePreservingCommand]
-
-  (* Proof management *)
-  | VernacGoal _ -> [GoalStartingCommand]
-
-  | VernacAbort _ -> []
-  | VernacAbortAll -> [NavigationCommand]
-  | VernacRestart -> [NavigationCommand]
-  | VernacSuspend -> [NavigationCommand]
-  | VernacResume _ -> [NavigationCommand]
-  | VernacUndo _ -> [NavigationCommand]
-  | VernacUndoTo _ -> [NavigationCommand]
-  | VernacBacktrack _ -> [NavigationCommand]
-
-  | VernacFocus _ -> [SolveCommand]
-  | VernacUnfocus -> [SolveCommand]
-  | VernacGo _ -> []
-  | VernacShow _ -> [OtherStatePreservingCommand]
-  | VernacCheckGuard -> [OtherStatePreservingCommand]
-  | VernacProof (Tacexpr.TacId []) -> [OtherStatePreservingCommand]
-  | VernacProof _ -> []
-
-  (* Toplevel control *)
-  | VernacToplevelControl _ -> []
-
-  (* Extensions *)
-  | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand]
-  | VernacExtend _ -> []
-
-let is_vernac_goal_starting_command com =
-  List.mem GoalStartingCommand (attribute_of_vernac_command com)
-
-let is_vernac_navigation_command com =
-  List.mem NavigationCommand (attribute_of_vernac_command com)
-
-let is_vernac_query_command com =
-  List.mem QueryCommand (attribute_of_vernac_command com)
-
-let is_vernac_known_option_command com =
-  List.mem KnownOptionCommand (attribute_of_vernac_command com)
-
-let is_vernac_debug_command com =
-  List.mem DebugCommand (attribute_of_vernac_command com)
-
-let is_vernac_goal_printing_command com =
-  let attribute = attribute_of_vernac_command com in
-  List.mem GoalStartingCommand attribute or
-  List.mem SolveCommand attribute
-
-let is_vernac_state_preserving_command com =
-  let attribute = attribute_of_vernac_command com in
-  List.mem OtherStatePreservingCommand attribute or
-  List.mem QueryCommand attribute
-
-let is_vernac_tactic_command com =
-  List.mem SolveCommand (attribute_of_vernac_command com)
-
-let is_vernac_proof_ending_command com =
-  List.mem ProofEndingCommand (attribute_of_vernac_command com)
-
-type undo_info = identifier list
-
-let undo_info () = Pfedit.get_all_proof_names ()
-
-type reset_mark = Libnames.object_name
-
-type reset_status =
-  | NoReset
-  | ResetAtSegmentStart of Names.identifier
-  | ResetAtRegisteredObject of reset_mark
-
-type reset_info = {
-  status : reset_status;
-  proofs : identifier list;
-  cur_prf : (identifier * int) option;
-  loc_ast : Util.loc * Vernacexpr.vernac_expr;
-}
+let toplvl_ctr = ref 0
+
+let toplvl_ctr_mtx = Mutex.create ()
 
-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 () =
-  prerr_endline "Reset initial called";
-  Vernacentries.abort_refine Lib.reset_initial ()
-
-let reset_to sp =
-      prerr_endline
-        ("Reset called with state "^(Libnames.string_of_path (fst sp)));
-      Lib.reset_to_state sp
-
-let raw_interp s =
-  Vernac.raw_do_vernac (Pcoq.Gram.parsable (Stream.of_string 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???) - now with less screen
-  * pollution *)
-  (try Pervasives.prerr_string " \r"; Pervasives.flush stderr with _ -> ());
-  match pe with
-    | None -> assert false
-    | Some((loc,vernac) as last) ->
-	if is_vernac_debug_command vernac then
-	  user_error_loc loc (str "Debug mode not available within CoqIDE");
-	if is_vernac_navigation_command vernac then
-	  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
-	    "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 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
-
-let interp verbosely phrase =
-  interp_with_options verbosely (make_option_commands ()) phrase
-
-let interp_and_replace s =
-  let result = interp false s in
-  let msg = read_stdout () in
-  result,msg
-
-let rec is_pervasive_exn = function
-  | Out_of_memory | Stack_overflow | Sys.Break -> true
-  | Error_in_file (_,_,e) -> is_pervasive_exn e
-  | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
-  | DuringCommandInterp (_,e) -> is_pervasive_exn e
-  | _ -> false
-
-let print_toplevel_error exc =
-  let (dloc,exc) =
-    match exc with
-      | DuringCommandInterp (loc,ie) ->
-          if loc = dummy_loc then (None,ie) else (Some loc, ie)
-      | _ -> (None, exc)
-  in
-  let (loc,exc) =
-    match exc with
-      | Stdpp.Exc_located (loc, ie) -> (Some loc),ie
-      | Error_in_file (s, (_,fname, loc), ie) -> None, ie
-      | _ -> dloc,exc
-  in
-  match exc with
-    | End_of_input  -> 	str "Please report: End of input",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 ->
-	   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 =
-  prerr_string "*";
+let coqtop_zombies () =
+  Mutex.lock toplvl_ctr_mtx;
+  let res = !toplvl_ctr in
+  Mutex.unlock toplvl_ctr_mtx;
+  res
+
+
+(** * Starting / signaling / ending a real coqtop sub-process *)
+
+(** We simulate a Unix.open_process that also returns the pid of
+    the created process. Note: this uses Unix.create_process, which
+    doesn't call bin/sh, so args shouldn't be quoted. The process
+    cannot be terminated by a Unix.close_process, but rather by a
+    kill of the pid.
+
+           >--ide2top_w--[pipe]--ide2top_r-->
+    coqide                                   coqtop
+           <--top2ide_r--[pipe]--top2ide_w--<
+
+    Note: we use Unix.stderr in Unix.create_process to get debug
+    messages from the coqtop's Ide_slave loop.
+*)
+
+let open_process_pid prog args =
+  let (ide2top_r,ide2top_w) = Unix.pipe () in
+  let (top2ide_r,top2ide_w) = Unix.pipe () in
+  let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in
+  assert (pid <> 0);
+  Unix.close ide2top_r;
+  Unix.close top2ide_w;
+  let oc = Unix.out_channel_of_descr ide2top_w in
+  let ic = Unix.in_channel_of_descr top2ide_r in
+  set_binary_mode_out oc true;
+  set_binary_mode_in ic true;
+  (pid,ic,oc)
+
+let spawn_coqtop sup_args =
+  Mutex.lock toplvl_ctr_mtx;
   try
-    vernac_com Vernacentries.interp last;
-    Lib.add_frozen_state()
+    let prog = !Minilib.coqtop_path in
+    let args = Array.of_list (prog :: "-ideslave" :: sup_args) in
+    let (pid,ic,oc) = open_process_pid prog args in
+    incr toplvl_ctr;
+    Mutex.unlock toplvl_ctr_mtx;
+    { pid = pid; cin = oc; cout = ic ; sup_args = sup_args }
   with e ->
-    let s,_ = process_exn e in prerr_endline ("Replay during undo failed because: "^s);
+    Mutex.unlock toplvl_ctr_mtx;
     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) *
-           (string * string)
-type concl = env * evar_map * constr * string
-type meta = env * evar_map * string
-type goal = hyp list * concl
-
-let prepare_hyp sigma env ((i,c,d) as a) =
-  env, sigma,
-  ((i,string_of_id i),c,d),
-  (msg (pr_var_decl env a), msg (pr_ltype_env env d))
-
-let prepare_hyps sigma env =
-  assert (rel_context env = []);
-  let hyps =
-    fold_named_context
-      (fun env d acc -> let hyp = prepare_hyp sigma env d in hyp :: acc)
-      env ~init:[]
-  in
-  List.rev hyps
-
-let prepare_goal_main sigma g =
-  let env = evar_env g in
-  (prepare_hyps sigma env,
-   (env, sigma, g.evar_concl, msg (pr_ltype_env_at_top env g.evar_concl)))
-
-let prepare_goal sigma g =
-  let options = make_option_commands () in
-  List.iter (fun (set_option,_) -> raw_interp set_option) options;
-  let x = prepare_goal_main sigma g in
-  List.iter (fun (_,unset_option) -> raw_interp unset_option) options;
-  x
-
-let get_current_pm_goal () =
-  let pfts = get_pftreestate ()  in
-  let gls = try nth_goal_of_pftreestate 1 pfts with _ -> raise Not_found in
-  let sigma= sig_sig gls in
-  let gl = sig_it gls in
-    prepare_goal sigma gl
-
-let get_current_goals () =
-    let pfts = get_pftreestate () 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 print_no_goal () =
-  (* 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_equality_type ast then
-      [ "discriminate "^ident, "discriminate "^ident^".";
-	"injection "^ident, "injection "^ident^"." ]
-    else
-      []) @
-
-   (let _,t = splay_prod env sigma ast in
-    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^".")]
-
-let concl_menu (_,_,concl,_) =
-  let is_eq = is_equality_type concl in
-  ["intro", "intro.";
-   "intros", "intros.";
-   "intuition","intuition." ] @
-
-   (if is_eq then
-      ["reflexivity", "reflexivity.";
-       "discriminate", "discriminate.";
-       "symmetry", "symmetry." ]
-    else
-      []) @
-
-  ["assumption" ,"assumption.";
-   "omega", "omega.";
-   "ring", "ring.";
-   "auto with *", "auto with *.";
-   "eauto with *", "eauto with *.";
-   "tauto", "tauto.";
-   "trivial", "trivial.";
-   "decide equality", "decide equality.";
-
-   "simpl", "simpl.";
-   "subst", "subst.";
-
-   "red", "red.";
-   "split", "split.";
-   "left", "left.";
-   "right", "right.";
-  ]
-
-
-let id_of_name = function
-  | Names.Anonymous -> id_of_string "x"
-  | Names.Name x -> x
-
-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 ->
-	let {Declarations.mind_nparams = np},
-	{Declarations.mind_consnames = carr ;
-	 Declarations.mind_nf_lc = tarr }
-	= Global.lookup_inductive i
-	in
-	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
-	       | [] -> []
-	       | (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
-	  tarr
-	  []
-    | _ -> raise Not_found
-
-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
+let respawn_coqtop coqtop = spawn_coqtop coqtop.sup_args
+
+let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint)
+let killer = ref (fun pid -> Unix.kill pid Sys.sigkill)
 
+let break_coqtop coqtop =
+  try !interrupter coqtop.pid
+  with _ -> prerr_endline "Error while sending Ctrl-C"
+
+let kill_coqtop coqtop =
+  let pid = coqtop.pid in
+  begin
+    try !killer pid
+    with _ -> prerr_endline "Kill -9 failed. Process already terminated ?"
+  end;
+  try
+    ignore (Unix.waitpid [] pid);
+    Mutex.lock toplvl_ctr_mtx; decr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx
+  with _ -> prerr_endline "Error while waiting for child"
+
+(** * Calls to coqtop *)
+
+(** Cf [Ide_intf] for more details *)
+
+let p = Xml_parser.make ()
+let () = Xml_parser.check_eof p false
+
+let eval_call coqtop (c:'a Ide_intf.call) =
+  Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c);
+  flush coqtop.cin;
+  let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in
+  (Ide_intf.to_answer xml : 'a Interface.value)
+
+let interp coqtop ?(raw=false) ?(verbose=true) s =
+  eval_call coqtop (Ide_intf.interp (raw,verbose,s))
+let rewind coqtop i = eval_call coqtop (Ide_intf.rewind i)
+let inloadpath coqtop s = eval_call coqtop (Ide_intf.inloadpath s)
+let mkcases coqtop s = eval_call coqtop (Ide_intf.mkcases s)
+let status coqtop = eval_call coqtop Ide_intf.status
+let hints coqtop = eval_call coqtop Ide_intf.hints
+
+module PrintOpt =
+struct
+  type t = string list
+  let implicit = ["Printing"; "Implicit"]
+  let coercions = ["Printing"; "Coercions"]
+  let raw_matching = ["Printing"; "Matching"; "Synth"]
+  let notations = ["Printing"; "Notations"]
+  let all_basic = ["Printing"; "All"]
+  let existential = ["Printing"; "Existential"; "Instances"]
+  let universes = ["Printing"; "Universes"]
+
+  let state_hack = Hashtbl.create 11
+  let _ = List.iter (fun opt -> Hashtbl.add state_hack opt false)
+            [ implicit; coercions; raw_matching; notations; all_basic; existential; universes ]
+
+  let set coqtop options =
+    let () = List.iter (fun (name, v) -> Hashtbl.replace state_hack name v) options in
+    let options = List.map (fun (name, v) -> (name, Interface.BoolValue v)) options in
+    match eval_call coqtop (Ide_intf.set_options options) with
+    | Interface.Good () -> ()
+    | _ -> raise (Failure "Cannot set options.")
+
+  let enforce_hack coqtop =
+    let elements = Hashtbl.fold (fun opt v acc -> (opt, v) :: acc) state_hack [] in
+    set coqtop elements
+
+end
+
+let goals coqtop =
+  let () = PrintOpt.enforce_hack coqtop in
+  eval_call coqtop Ide_intf.goals
+
+let evars coqtop =
+  let () = PrintOpt.enforce_hack coqtop in
+  eval_call coqtop Ide_intf.evars
diff --git a/ide/coq.mli b/ide/coq.mli
index 9dec52c6..9d64da6c 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -1,84 +1,70 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Coq : Interaction with the Coq toplevel *)
 
-open Names
-open Term
-open Environ
-open Evd
+(** * Version and date *)
 
 val short_version : unit -> string
 val version : unit -> string
 
-type printing_state = {
-  mutable printing_implicit : bool;
-  mutable printing_coercions : bool;
-  mutable printing_raw_matching : bool;
-  mutable printing_no_notation : bool;
-  mutable printing_all : bool;
-  mutable printing_evar_instances : bool;
-  mutable printing_universes : bool;
-  mutable printing_full_all : bool
-}
+(** * Initial checks by launching test coqtop processes *)
 
-val printing_state : printing_state
+val filter_coq_opts : string list -> bool * string list
 
-type reset_info
+(** A mock coqtop launch, checking in particular that initial.coq is found *)
+val check_connection : string list -> unit
 
-val reset_initial : unit -> unit
+(** * The structure describing a coqtop sub-process *)
 
-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 * string
+type coqtop
 
-val push_phrase : ('a * reset_info) Stack.t -> reset_info -> 'a -> unit
+(** * Count of all active coqtops *)
 
-val rewind : reset_info list -> ('a * reset_info) Stack.t -> unit
+val coqtop_zombies : unit -> int
 
-val is_vernac_tactic_command : Vernacexpr.vernac_expr -> bool
-val is_vernac_state_preserving_command : Vernacexpr.vernac_expr -> bool
-val is_vernac_goal_starting_command : Vernacexpr.vernac_expr -> bool
-val is_vernac_proof_ending_command : Vernacexpr.vernac_expr -> bool
+(** * Starting / signaling / ending a real coqtop sub-process *)
 
-(* type hyp = (identifier * constr option * constr) * string *)
+val spawn_coqtop : string list -> coqtop
+val respawn_coqtop : coqtop -> coqtop
+val kill_coqtop : coqtop -> unit
+val break_coqtop : coqtop -> unit
 
-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
-type goal = hyp list * concl
+(** In win32, we'll use a different kill function than Unix.kill *)
 
-val get_current_goals : unit -> goal list
+val killer : (int -> unit) ref
+val interrupter : (int -> unit) ref
 
-val get_current_pm_goal : unit -> goal
+(** * Calls to Coqtop, cf [Ide_intf] for more details *)
 
-val print_no_goal : unit -> string
+val interp :
+  coqtop -> ?raw:bool -> ?verbose:bool -> string -> string Interface.value
+val rewind : coqtop -> int -> int Interface.value
+val status : coqtop -> Interface.status Interface.value
+val goals : coqtop -> Interface.goals option Interface.value
+val evars : coqtop -> Interface.evar list option Interface.value
+val hints : coqtop -> (Interface.hint list * Interface.hint) option Interface.value
+val inloadpath : coqtop -> string -> bool Interface.value
+val mkcases : coqtop -> string -> string list list Interface.value
 
-val process_exn : exn -> string*(Util.loc option)
+(** A specialized version of [raw_interp] dedicated to
+    set/unset options. *)
 
-val hyp_menu : hyp -> (string * string) list
-val concl_menu : concl -> (string * string) list
+module PrintOpt :
+sig
+  type t
+  val implicit : t
+  val coercions : t
+  val raw_matching : t
+  val notations : t
+  val all_basic : t
+  val existential : t
+  val universes : t
 
-val is_in_coq_lib : string -> bool
-val is_in_coq_path : string -> bool
-val is_in_loadpath : string -> bool
-
-val make_cases : string -> string list list
-
-
-type tried_tactic =
-  | Interrupted
-  | Success of int (* nb of goals after *)
-  | Failed
-
-(* Message to display in lower status bar. *)
-
-val current_status : unit -> string
+  val set : coqtop -> (t * bool) list -> unit
+end
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index d41bcf29..b9e14145 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_commands.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 let commands = [
   [(* "Abort"; *)
    "Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T.";
@@ -16,8 +14,10 @@ let commands = [
    "Add LoadPath";
    "Add ML Path";
    "Add Morphism";
+   "Add Printing Constructor";
    "Add Printing If";
    "Add Printing Let";
+   "Add Printing Record";
    "Add Rec LoadPath";
    "Add Rec ML Path";
    "Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. ";
@@ -94,8 +94,10 @@ let commands = [
    "Record";
    "Remark";
    "Remove LoadPath";
+   "Remove Printing Constructor";
    "Remove Printing If";
    "Remove Printing Let";
+   "Remove Printing Record";
    "Require";
    "Require Export";
    "Require Import";
diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll
index 02e21166..f0f1afb7 100644
--- a/ide/coq_lex.mll
+++ b/ide/coq_lex.mll
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
-
 {
   open Lexing
 
@@ -21,60 +19,55 @@
 
   (* 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 ())
+  let tag_of_ident =
+    let one_word_commands =
+      [ "Add" ; "Check"; "Eval"; "Extraction" ;
+	"Load" ; "Undo"; "Goal";
+	"Proof" ; "Print";"Save" ;
+	"End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]
+    in
+    let one_word_declarations =
+      [ (* Definitions *)
+	"Definition" ; "Let" ; "Example" ; "SubClass" ;
+        "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
+        (* Assumptions *)
+	"Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
+	"Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
+        (* Inductive *)
+        "Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
+        (* Other *)
+	"Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ]
+    in
+    let proof_declarations =
       [ "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"; "Abort" ];
-    Hashtbl.mem h
+        "Proposition" ; "Property" ]
+    in
+    let proof_ends =
+      [ "Qed" ; "Defined" ; "Admitted"; "Abort" ]
+    in
+    let constr_keywords =
+      [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for";
+	"end"; "as"; "let"; "in"; "if"; "then"; "else"; "return";
+	"Prop"; "Set"; "Type" ]
+    in
+    let h = Hashtbl.create 97 in (* for vernac *)
+    let h' = Hashtbl.create 97 in (* for constr *)
+    List.iter (fun s -> Hashtbl.add h s Keyword) one_word_commands;
+    List.iter (fun s -> Hashtbl.add h s Declaration) one_word_declarations;
+    List.iter (fun s -> Hashtbl.add h s ProofDeclaration) proof_declarations;
+    List.iter (fun s -> Hashtbl.add h s Qed) proof_ends;
+    List.iter (fun s -> Hashtbl.add h' s Keyword) constr_keywords;
+    (fun initial id -> Hashtbl.find (if initial then h else h') id)
+
+  exception Unterminated
+
+  let here f lexbuf = f (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
 
-  let start = ref true
 }
 
 let space =
-  [' ' '\010' '\013' '\009' '\012']
+  [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *)
 
 let firstchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
@@ -82,12 +75,14 @@ let identchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let ident = firstchar identchar*
 
-let sentence_sep = '.' [ ' ' '\n' '\t' ]
+let undotted_sep = [ '{' '}' '-' '+' '*' ]
+
+let dot_sep = '.' (space | eof)
 
 let multiword_declaration =
   "Module" (space+ "Type")?
 | "Program" space+ ident
-| "Existing" space+ "Instance"
+| "Existing" space+ "Instance" "s"?
 | "Canonical" space+ "Structure"
 
 let locality = ("Local" space+)?
@@ -130,65 +125,75 @@ rule coq_string = parse
 and comment = parse
   | "(*" { ignore (comment lexbuf); comment lexbuf }
   | "\"" { ignore (coq_string lexbuf); comment lexbuf }
-  | "*)" { Lexing.lexeme_end lexbuf }
-  | eof { Lexing.lexeme_end lexbuf }
+  | "*)" { (true, Lexing.lexeme_start lexbuf + 2) }
+  | eof { (false, Lexing.lexeme_end lexbuf) }
   | _ { comment lexbuf }
 
-and sentence stamp = parse
-  | space+ { sentence stamp lexbuf }
+and sentence initial stamp = parse
   | "(*" {
       let comm_start = Lexing.lexeme_start lexbuf in
-      let comm_end = comment lexbuf in
+      let trully_terminated,comm_end = comment lexbuf in
       stamp comm_start comm_end Comment;
-      sentence stamp lexbuf
+      if not trully_terminated then raise Unterminated;
+      (* A comment alone is a sentence.
+	 A comment in a sentence doesn't terminate the sentence.
+         Note: comm_end is the first position _after_ the comment,
+	 as required when tagging a zone, hence the -1 to locate the
+	 ")" terminating the comment.
+      *)
+      if initial then comm_end - 1 else sentence false stamp lexbuf
     }
   | "\"" {
       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
+      sentence false stamp lexbuf
     }
   | multiword_declaration {
-      if !start then begin
-        start := false;
-        stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Declaration
-      end;
-      sentence stamp lexbuf
+      if initial then here stamp lexbuf Declaration;
+      sentence false stamp lexbuf
     }
   | multiword_command {
-      if !start then begin
-        start := false;
-        stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword
-      end;
-      sentence stamp lexbuf }
+      if initial then here stamp lexbuf Keyword;
+      sentence false 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 }
+      (try here stamp lexbuf (tag_of_ident initial id) with Not_found -> ());
+      sentence false stamp lexbuf }
+  | ".." {
+      (* We must have a particular rule for parsing "..", where no dot
+	 is a terminator, even if we have a blank afterwards
+	 (cf. for instance the syntax for recursive notation).
+	 This rule and the following one also allow to treat the "..."
+	 special case, where the third dot is a terminator. *)
+      sentence false stamp lexbuf
+    }
+  | dot_sep { Lexing.lexeme_start lexbuf } (* The usual "." terminator *)
+  | undotted_sep {
+      (* Separators like { or } and bullets * - + are only active
+	 at the start of a sentence *)
+      if initial then Lexing.lexeme_start lexbuf
+      else sentence false stamp lexbuf
+    }
+  | space+ {
+       (* Parsing spaces is the only situation preserving initiality *)
+       sentence initial stamp lexbuf
+    }
+  | _ {
+      (* Any other characters *)
+      sentence false stamp lexbuf
+    }
+  | eof { raise Unterminated }
 
 {
-  let find_end_offset stamp slice =
-    let lb = Lexing.from_string slice in
-    start := true;
-    sentence stamp lb;
-    Lexing.lexeme_end lb
+
+  (** Parse a sentence in string [slice], tagging relevant parts with
+      function [stamp], and returning the position of the first
+      sentence delimitor (either "." or "{" or "}" or the end of a comment).
+      It will raise [Unterminated] when no end of sentence is found.
+  *)
+
+  let delimit_sentence stamp slice =
+    sentence true stamp (Lexing.from_string slice)
+
 }
diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml
deleted file mode 100644
index 568594bd..00000000
--- a/ide/coq_tactics.ml
+++ /dev/null
@@ -1,131 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: coq_tactics.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-let tactics = [
-  "Abstract";
-  "Absurd";
-  "Apply";
-  "Apply ... with";
-  "Assert";
-  "Assumption";
-  "Auto";
-  "AutoRewrite";
-  "Binding list";
-  "Case";
-  "Case ... with";
-  "Cbv";
-  "Change";
-  "Change ... in";
-  "Clear";
-  "ClearBody";
-  "Compare";
-  "Compute";
-  "Constructor";
-  "Constructor ... with";
-  "Contradiction";
-  "Conversion tactics";
-  "Cut";
-  "CutRewrite";
-  "Decide Equality";
-  "Decompose";
-  "Decompose Record";
-  "Decompose Sum";
-  "Dependent Inversion";
-  "Dependent Inversion ... with";
-  "Dependent Inversion_clear";
-  "Dependent Inversion_clear ... with";
-  "Dependent Rewrite ->";
-  "Dependent Rewrite <-";
-  "Derive Inversion";
-  "Destruct";
-  "Discriminate";
-  "DiscrR";
-  "Do";
-  "Double Induction";
-  "EApply";
-  "EAuto";
-  "Elim ... using";
-  "Elim ... with";
-  "ElimType";
-  "Exact";
-  "Exists";
-  "Fail";
-  "Field";
-  "First";
-  "Fold";
-  "Fourier";
-  "Generalize";
-  "Generalize Dependent";
-  "Print Hint";
-  "Hnf";
-  "Idtac";
-  "Induction";
-  "Info";
-  "Injection";
-  "Intro";
-  "Intro ... after";
-  "Intro after";
-  "Intros";
-  "Intros pattern";
-  "Intros until";
-  "Intuition";
-  "Inversion";
-  "Inversion ... in";
-  "Inversion ... using";
-  "Inversion ... using ... in";
-  "Inversion_clear";
-  "Inversion_clear ... in";
-  "LApply";
-  "Lazy";
-  "Left";
-  "LetTac";
-  "Move";
-  "NewDestruct";
-  "NewInduction";
-  "Omega";
-  "Orelse";
-  "Pattern";
-  "Pose";
-  "Prolog";
-  "Quote";
-  "Red";
-  "Refine";
-  "Reflexivity";
-  "Rename";
-  "Repeat";
-  "Replace ... with";
-  "Rewrite";
-  "Rewrite ->";
-  "Rewrite -> ... in";
-  "Rewrite <-";
-  "Rewrite <- ... in";
-  "Rewrite ... in";
-  "Right";
-  "Ring";
-  "Setoid_replace";
-  "Setoid_rewrite";
-  "Simpl";
-  "Simple Inversion";
-  "Simplify_eq";
-  "Solve";
-  "Split";
-  "SplitAbsolu";
-  "SplitRmult";
-  "Subst";
-  "Symmetry";
-  "Tacticals";
-  "Tauto";
-  "Transitivity";
-  "Trivial";
-  "Try";
-  "tactic macros";
-  "Unfold";
-  "Unfold ... in";
-]
diff --git a/ide/.coqide-gtk2rc b/ide/coqide-gtk2rc
index 11c53dad..621d4e84 100644
--- a/ide/.coqide-gtk2rc
+++ b/ide/coqide-gtk2rc
@@ -1,5 +1,5 @@
-# Some default functions for CoqIde. You may copy the file in your HOME and
-# edit as you want. See 
+# Some default functions for CoqIde. You may copy the file in $XDG_CONFIG_HOME
+# ($HOME/.config/coq/) and edit as you want. See 
 # http://developer.gnome.org/doc/API/2.0/gtk/gtk-Resource-Files.html
 # for a complete set of options
 # To set the font of the text windows, edit the .coqiderc file through the menus.
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 162728ad..009a1989 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -1,16 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqide.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Preferences
-open Vernacexpr
-open Coq
 open Gtk_parsing
 open Ideutils
 
@@ -19,9 +15,17 @@ type ide_info = {
   stop : GText.mark;
 }
 
+(** Have we used admit or declarative mode's daimon ?
+    If yes, we color differently *)
+
+type safety = Safe | Unsafe
+
+let safety_tag = function
+  | Safe -> Tags.Script.processed
+  | Unsafe -> Tags.Script.unjustified
 
 class type analyzed_views=
-object('self)
+object
   val mutable act_id : GtkSignal.id option
   val mutable deact_id : GtkSignal.id option
   val input_buffer : GText.buffer
@@ -32,7 +36,8 @@ 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 cmd_stack : ide_info Stack.t
+  val mycoqtop : Coq.coqtop ref
   val mutable is_active : bool
   val mutable read_only : bool
   val mutable filename : string option
@@ -47,7 +52,6 @@ object('self)
 
   method filename : string option
   method stats :  Unix.stats option
-  method set_filename : string option -> unit
   method update_stats : unit
   method revert : unit
   method auto_save : unit
@@ -61,31 +65,25 @@ object('self)
   method backtrack_to : GText.iter -> unit
   method backtrack_to_no_lock : GText.iter -> unit
   method clear_message : unit
-  method deactivate : unit -> unit
   method disconnected_keypress_handler : GdkEvent.Key.t -> bool
-  method electric_handler : GtkSignal.id
   method find_phrase_starting_at :
     GText.iter -> (GText.iter * GText.iter) option
   method get_insert : GText.iter
   method get_start_of_input : GText.iter
   method go_to_insert : unit
   method indent_current_line : unit
+  method go_to_next_occ_of_cur_word : unit
+  method go_to_prev_occ_of_cur_word : unit
   method insert_command : string -> string -> unit
   method tactic_wizard : string list -> unit
   method insert_message : string -> unit
-  method insert_this_phrase_on_success :
-    bool -> bool -> bool -> string -> string -> bool
-  method process_next_phrase : bool -> bool -> bool -> bool
+  method process_next_phrase : bool -> unit
   method process_until_iter_or_error : GText.iter -> unit
   method process_until_end_or_error : unit
   method recenter_insert : unit
   method reset_initial : unit
-  method send_to_coq :
-    bool -> bool -> string ->
-    bool -> bool -> bool ->
-    (bool*reset_info) option
+  method force_reset_initial : unit
   method set_message : string -> unit
-  method show_pm_goal : unit
   method show_goals : unit
   method show_goals_full : unit
   method undo_last_step : unit
@@ -102,72 +100,71 @@ type viewable_script =
      proof_view : GText.view;
      message_view : GText.view;
      analyzed_view : analyzed_views;
-     command_stack : (ide_info * Coq.reset_info) Stack.t;
+     toplvl : Coq.coqtop ref;
+     command : Command_windows.command_window;
     }
 
-
-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 kill_session s =
+  s.analyzed_view#kill_detached_views ();
+  Coq.kill_coqtop !(s.toplvl)
+
+let build_session s =
+  let session_paned = GPack.paned `VERTICAL () in
+  let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
+    ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in
+  let script_frame = GBin.frame ~shadow_type:`IN
+    ~packing:eval_paned#add1 () in
+  let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:script_frame#add () in
+  let state_paned = GPack.paned `VERTICAL
+    ~packing:eval_paned#add2 () in
+  let proof_frame = GBin.frame ~shadow_type:`IN
+    ~packing:state_paned#add1 () in
+  let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:proof_frame#add () in
+  let message_frame = GBin.frame ~shadow_type:`IN
+    ~packing:state_paned#add2 () in
+  let message_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:message_frame#add () in
+  let session_tab = GPack.hbox ~homogeneous:false () in
+  let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
+    ~packing:session_tab#pack () in
   let _ =
-    script#buffer#connect#modified_changed
-      ~callback:(fun () -> if script#buffer#modified
-                 then img#set_stock `SAVE
-                 else img#set_stock `YES) in
+    s.script#buffer#connect#modified_changed
+      ~callback:(fun () -> if s.script#buffer#modified
+        then img#set_stock `SAVE
+        else img#set_stock `YES) in
   let _ =
-    session_paned#misc#connect#size_allocate
+    eval_paned#misc#connect#size_allocate
+      ~callback:
       (let old_paned_width = ref 2 in
        let old_paned_height = ref 2 in
-         (fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
-            if !old_paned_width <> paned_width || !old_paned_height <> paned_height then (
-              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)
+       (fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
+	 if !old_paned_width <> paned_width || !old_paned_height <> paned_height then (
+	   eval_paned#set_position (eval_paned#position * paned_width / !old_paned_width);
+	   state_paned#set_position (state_paned#position * paned_height / !old_paned_height);
+	   old_paned_width := paned_width;
+	   old_paned_height := paned_height;
+	 )))
+  in
+  session_paned#pack2 ~shrink:false ~resize:false (s.command#frame#coerce);
+  script_scroll#add s.script#coerce;
+  proof_scroll#add s.proof_view#coerce;
+  message_scroll#add s.message_view#coerce;
+  session_tab#pack s.tab_label#coerce;
+  img#set_stock `YES;
+  eval_paned#set_position 1;
+  state_paned#set_position 1;
+  (Some session_tab#coerce,None,session_paned#coerce)
 
 let session_notebook =
-  Typed_notebook.create 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)
+  Typed_notebook.create build_session kill_session
+    ~border_width:2 ~show_border:false ~scrollable:true ()
 
 let cb = GData.clipboard Gdk.Atom.primary
 
-
 let last_cb_content = ref ""
 
-
 let update_notebook_pos () =
   let pos =
     match !current.vertical_tabs, !current.opposite_tabs with
@@ -178,21 +175,13 @@ let update_notebook_pos () =
   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 to_do_on_page_switch = ref []
+(** * Coqide's handling of signals *)
 
+(** We ignore Ctrl-C, and for most of the other catchable signals
+    we launch an emergency save of opened files and then exit *)
 
 let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
 			Sys.sigill; Sys.sigpipe; Sys.sigquit;
@@ -200,75 +189,80 @@ let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
 
 let crash_save i =
   (*  ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
-  safe_prerr_endline "Trying to save all buffers in .crashcoqide files";
+  Minilib.safe_prerr_endline "Trying to save all buffers in .crashcoqide files";
   let count = ref 0 in
-    List.iter
-      (function {script=view; analyzed_view = av } ->
-	 (let filename = match av#filename with
-	    | None ->
-		incr count;
-		"Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
-	    | Some f -> f^".crashcoqide"
-	  in
-	    try
-	      if try_export filename (view#buffer#get_text ()) then
-		safe_prerr_endline ("Saved "^filename)
-	      else safe_prerr_endline ("Could not save "^filename)
-	    with _ -> safe_prerr_endline ("Could not save "^filename))
-      )
-      session_notebook#pages;
-    safe_prerr_endline "Done. Please report.";
-    if i <> 127 then exit i
+  List.iter
+    (function {script=view; analyzed_view = av } ->
+      (let filename = match av#filename with
+	| None ->
+	  incr count;
+	  "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
+	| Some f -> f^".crashcoqide"
+       in
+       try
+	 if try_export filename (view#buffer#get_text ()) then
+	   Minilib.safe_prerr_endline ("Saved "^filename)
+	 else Minilib.safe_prerr_endline ("Could not save "^filename)
+       with _ -> Minilib.safe_prerr_endline ("Could not save "^filename))
+    )
+    session_notebook#pages;
+  Minilib.safe_prerr_endline "Done. Please report.";
+  if i <> 127 then exit i
 
 let ignore_break () =
   List.iter
     (fun i ->
-       try Sys.set_signal i (Sys.Signal_handle crash_save)
-       with _ -> prerr_endline "Signal ignored (normal if Win32)")
+      try Sys.set_signal i (Sys.Signal_handle crash_save)
+      with _ -> prerr_endline "Signal ignored (normal if Win32)")
     signals_to_crash;
   Sys.set_signal Sys.sigint Sys.Signal_ignore
 
+
+(** * Locks *)
+
 (* Locking machinery for Coq kernel *)
 let coq_computing = Mutex.create ()
 
 (* To prevent Coq from interrupting during undoing...*)
 let coq_may_stop = Mutex.create ()
 
+(* To prevent a force_reset_initial during a force_reset_initial *)
+let resetting = Mutex.create ()
+
+exception RestartCoqtop
+exception Unsuccessful
+
+let force_reset_initial () =
+  prerr_endline "Reset Initial";
+  session_notebook#current_term.analyzed_view#force_reset_initial
+
 let break () =
-  prerr_endline "User break received:";
-  if not (Mutex.try_lock coq_computing) then
-    begin
-      prerr_endline " trying to stop computation:";
-      if Mutex.try_lock coq_may_stop then begin
-	  Util.interrupt := true;
-	  prerr_endline " interrupt flag set. Computation should stop soon...";
-	  Mutex.unlock coq_may_stop
-	end else prerr_endline " interruption refused (may not stop now)";
-    end
-  else begin
-      Mutex.unlock coq_computing;
-      prerr_endline " ignored (not computing)"
-    end
+  prerr_endline "User break received";
+  Coq.break_coqtop !(session_notebook#current_term.toplvl)
 
 let do_if_not_computing text f x =
   let threaded_task () =
-    (* Beware: mutexes must be locked and unlocked in the same thread
-       on at least FreeBSD (see bug #2431) *)
     if Mutex.try_lock coq_computing then
       begin
-        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
+	prerr_endline "Getting lock";
+	List.iter
+          (fun elt -> try f elt with
+            | RestartCoqtop -> elt.analyzed_view#reset_initial
+            | Sys_error str ->
+              elt.analyzed_view#reset_initial;
+              elt.analyzed_view#set_message
+                ("Unable to communicate with coqtop, restarting coqtop.\n"^
+		    "Error was: "^str)
+            | e ->
+              Mutex.unlock coq_computing;
+              elt.analyzed_view#set_message
+                ("Unknown error, please report:\n"^(Printexc.to_string e)))
+          x;
+	prerr_endline "Releasing lock";
+	Mutex.unlock coq_computing;
       end
     else
-      prerr_endline
-        "Discarded order (computations are ongoing)"
+      prerr_endline "Discarded order (computations are ongoing)"
   in
   prerr_endline ("Launching thread " ^ text);
   ignore (Glib.Timeout.add ~ms:300 ~callback:
@@ -277,69 +271,77 @@ let do_if_not_computing text f x =
               else (pbar#pulse (); true)));
   ignore (Thread.create threaded_task ())
 
-(* 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
-
 let warning msg =
   GToolbox.message_box ~title:"Warning"
     ~icon:(let img = GMisc.image () in
-	     img#set_stock `DIALOG_WARNING;
-	     img#set_icon_size `DIALOG;
-	     img#coerce)
+	   img#set_stock `DIALOG_WARNING;
+	   img#set_icon_size `DIALOG;
+	   img#coerce)
     msg
 
-(*
-(* XXX - beaucoups d'appels, a garder *)
-let get_current_view =
-  focused_session
- *)
 let remove_current_view_page () =
   let do_remove () =
     let c = session_notebook#current_page in
-      kill_input_view c
+    session_notebook#remove_page c
   in
   let current = session_notebook#current_term in
-    if not current.script#buffer#modified then do_remove ()
-    else
-      match GToolbox.question_box ~title:"Close"
-              ~buttons:["Save Buffer and Close";
-                        "Close without Saving";
-                        "Don't Close"]
-              ~default:0
-              ~icon:(let img = GMisc.image () in
-                       img#set_stock `DIALOG_WARNING;
-                       img#set_icon_size `DIALOG;
-                       img#coerce)
-              "This buffer has unsaved modifications"
-      with
-        | 1 ->
-            begin match current.analyzed_view#filename with
-              | None ->
-                  begin match select_file_for_save ~title:"Save file" () with
-                    | None -> ()
-                    | Some f ->
-                        if current.analyzed_view#save_as f then begin
-                          flash_info ("File " ^ f ^ " saved") ;
-                          do_remove ()
-                        end else
-                          warning  ("Save Failed (check if " ^ f ^ " is writable)")
-                  end
+  if not current.script#buffer#modified then do_remove ()
+  else
+    match GToolbox.question_box ~title:"Close"
+      ~buttons:["Save Buffer and Close";
+                "Close without Saving";
+                "Don't Close"]
+      ~default:0
+      ~icon:(let img = GMisc.image () in
+             img#set_stock `DIALOG_WARNING;
+             img#set_icon_size `DIALOG;
+             img#coerce)
+      "This buffer has unsaved modifications"
+    with
+      | 1 ->
+        begin match current.analyzed_view#filename with
+          | None ->
+            begin match select_file_for_save ~title:"Save file" () with
+              | None -> ()
               | Some f ->
-                  if current.analyzed_view#save f then begin
-                    flash_info ("File " ^ f ^ " saved") ;
-                    do_remove ()
-                  end else
-                    warning  ("Save Failed (check if " ^ f ^ " is writable)")
+                if current.analyzed_view#save_as f then begin
+                  flash_info ("File " ^ f ^ " saved") ;
+                  do_remove ()
+                end else
+                  warning  ("Save Failed (check if " ^ f ^ " is writable)")
             end
-        | 2 -> do_remove ()
-        | _ -> ()
+          | Some f ->
+            if current.analyzed_view#save f then begin
+              flash_info ("File " ^ f ^ " saved") ;
+              do_remove ()
+            end else
+              warning  ("Save Failed (check if " ^ f ^ " is writable)")
+        end
+      | 2 -> do_remove ()
+      | _ -> ()
+
+module Opt = Coq.PrintOpt
+
+let print_items = [
+  ([Opt.implicit],"Display implicit arguments","Display _implicit arguments",
+   "i",false);
+  ([Opt.coercions],"Display coercions","Display _coercions","c",false);
+  ([Opt.raw_matching],"Display raw matching expressions",
+   "Display raw _matching expressions","m",true);
+  ([Opt.notations],"Display notations","Display _notations","n",true);
+  ([Opt.all_basic],"Display all basic low-level contents",
+   "Display _all basic low-level contents","a",false);
+  ([Opt.existential],"Display existential variable instances",
+   "Display _existential variable instances","e",false);
+  ([Opt.universes],"Display universe levels","Display _universe levels",
+   "u",false);
+  ([Opt.all_basic;Opt.existential;Opt.universes], "Display all low-level contents",
+   "Display all _low-level contents","l",false)
+]
+
+let setopts ct opts v =
+  let opts = List.map (fun o -> (o, v)) opts in
+  Coq.PrintOpt.set ct opts
 
 (* Reset this to None on page change ! *)
 let (last_completion:(string*int*int*bool) option ref) = ref None
@@ -351,64 +353,64 @@ let rec complete input_buffer w (offset:int) =
   match !last_completion with
     | Some (lw,loffset,lpos,backward)
 	when lw=w && loffset=offset ->
-	begin
-	  let iter = input_buffer#get_iter (`OFFSET lpos) in
-	    if backward then
-	      match complete_backward w iter with
-		| None ->
-		    last_completion :=
-		      Some (lw,loffset,
-			    (find_word_end
-			       (input_buffer#get_iter (`OFFSET loffset)))#offset ,
-			    false);
-		    None
-		| Some (ss,start,stop) as result ->
-		    last_completion :=
-		      Some (w,offset,ss#offset,true);
-		    result
-	    else
-	      match complete_forward w iter with
-		| None ->
-		    last_completion := None;
-		    None
-		| Some (ss,start,stop) as result ->
-		    last_completion :=
-		      Some (w,offset,ss#offset,false);
-		    result
-	end
-    | _ -> begin
-	  match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
+      begin
+	let iter = input_buffer#get_iter (`OFFSET lpos) in
+	if backward then
+	  match complete_backward w iter with
 	    | None ->
-		last_completion :=
-		  Some (w,offset,(find_word_end (input_buffer#get_iter
-						   (`OFFSET offset)))#offset,false);
-		complete input_buffer w offset
+	      last_completion :=
+		Some (lw,loffset,
+		      (find_word_end
+			 (input_buffer#get_iter (`OFFSET loffset)))#offset ,
+		      false);
+	      None
 	    | Some (ss,start,stop) as result ->
-		last_completion := Some (w,offset,ss#offset,true);
-		result
+	      last_completion :=
+		Some (w,offset,ss#offset,true);
+	      result
+	else
+	  match complete_forward w iter with
+	    | None ->
+	      last_completion := None;
+	      None
+	    | Some (ss,start,stop) as result ->
+	      last_completion :=
+		Some (w,offset,ss#offset,false);
+	      result
       end
+    | _ -> begin
+      match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
+	| None ->
+	  last_completion :=
+	    Some (w,offset,(find_word_end (input_buffer#get_iter
+					     (`OFFSET offset)))#offset,false);
+	  complete input_buffer w offset
+	| Some (ss,start,stop) as result ->
+	  last_completion := Some (w,offset,ss#offset,true);
+	  result
+    end
 
 let get_current_word () =
   match session_notebook#current_term,cb#text with
     | {script=script; analyzed_view=av;},None ->
-	  prerr_endline "None selected";
-	  let it = av#get_insert in
-	  let start = find_word_start it in
-	  let stop = find_word_end start in
-	    script#buffer#move_mark `SEL_BOUND 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
+      prerr_endline "None selected";
+      let it = av#get_insert in
+      let start = find_word_start it in
+      let stop = find_word_end start in
+      script#buffer#move_mark `SEL_BOUND ~where:start;
+      script#buffer#move_mark `INSERT ~where:stop;
+      script#buffer#get_text ~slice:true ~start ~stop ()
+    | _,Some t ->
+      prerr_endline "Some selected";
+      prerr_endline t;
+      t
 
 
 let input_channel b ic =
   let buf = String.create 1024 and len = ref 0 in
-    while len := input ic buf 0 1024; !len > 0 do
-      Buffer.add_substring b buf 0 !len
-    done
+  while len := input ic buf 0 1024; !len > 0 do
+    Buffer.add_substring b buf 0 !len
+  done
 
 let with_file handler name ~f =
   try
@@ -416,116 +418,138 @@ 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
 
-
-(* For electric handlers *)
-exception Found
-
 (* For find_phrase_starting_at *)
 exception Stop of int
 
-(* 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 tag_of_sort = function
+  | Coq_lex.Comment -> Tags.Script.comment
+  | Coq_lex.Keyword -> Tags.Script.kwd
+  | Coq_lex.Declaration -> Tags.Script.decl
+  | Coq_lex.ProofDeclaration -> Tags.Script.proof_decl
+  | Coq_lex.Qed -> Tags.Script.qed
+  | Coq_lex.String -> failwith "No tag"
 
 let apply_tag (buffer:GText.buffer) orig off_conv from upto sort =
-  let conv_and_apply start stop tag =
+  try
+    let tag = tag_of_sort sort in
     let start = orig#forward_chars (off_conv from) in
     let stop = orig#forward_chars (off_conv upto) in
     buffer#apply_tag ~start ~stop tag
-  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 -> ()
+  with _ -> ()
 
 let remove_tags (buffer:GText.buffer) from upto =
   List.iter (buffer#remove_tag ~start:from ~stop:upto)
     [ Tags.Script.comment; Tags.Script.kwd; Tags.Script.decl;
       Tags.Script.proof_decl; Tags.Script.qed ]
 
+(** Cut a part of the buffer in sentences and tag them.
+    May raise [Coq_lex.Unterminated] when the zone ends with
+    an unterminated sentence. *)
+
 let split_slice_lax (buffer:GText.buffer) from upto =
   remove_tags buffer from upto;
-  buffer#remove_tag ~start:from ~stop:upto Tags.Script.lax_end;
+  buffer#remove_tag ~start:from ~stop:upto Tags.Script.sentence;
   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))
+    let end_off = Coq_lex.delimit_sentence (apply_tag buffer from off_conv) str
+    in
+    let start = from#forward_chars (off_conv end_off) in
+    let stop = start#forward_char in
+    buffer#apply_tag ~start ~stop Tags.Script.sentence;
+    let next = end_off + 1 in
+    if next < slice_len then begin
+      ignore (from#nocopy#forward_chars (off_conv next));
+      split_substring (String.sub str next (slice_len - next))
     end
   in
   split_substring slice
 
-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
+(** Searching forward and backward a position fulfilling some condition *)
+
+let rec forward_search cond (iter:GText.iter) =
+  if iter#is_end || cond iter then iter
+  else forward_search cond iter#forward_char
+
+let rec backward_search cond (iter:GText.iter) =
+  if iter#is_start || cond iter then iter
+  else backward_search cond iter#backward_char
+
+let is_sentence_end s = s#has_tag Tags.Script.sentence
+let is_char s c = s#char = Char.code c
+
+(** Search backward the first character of a sentence, starting at [iter]
+    and going at most up to [soi] (meant to be the end of the locked zone).
+    Raise [Not_found] when no proper sentence start has been found,
+    in particular when the final "." of the locked zone is followed
+    by a non-blank character outside the locked zone. This non-blank
+    character will be signaled as erroneous in [tag_on_insert] below. *)
+
+let grab_sentence_start (iter:GText.iter) soi =
+  let cond iter =
+    if iter#compare soi < 0 then raise Not_found;
+    let prev = iter#backward_char in
+    is_sentence_end prev &&
+      (not (is_char prev '.') ||
+       List.exists (is_char iter) [' ';'\n';'\r';'\t'])
+  in
+  backward_search cond iter
+
+(** Search forward the first character immediately after a sentence end *)
+
+let rec grab_sentence_stop (start:GText.iter) =
+  (forward_search is_sentence_end start)#forward_char
+
+(** Search forward the first character immediately after a "." sentence end
+    (and not just a "{" or "}" or comment end *)
+
+let rec grab_ending_dot (start:GText.iter) =
+  let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
+  (forward_search is_ending_dot start)#forward_char
+
+(** Retag a zone that has been edited *)
 
 let tag_on_insert =
+  (* possible race condition here : editing two buffers with a timedelta smaller
+   * than 1.5s might break the error recovery mechanism. *)
   let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *)
   fun buffer ->
-    try 
+    try
+      (* the start of the non-locked zone *)
+      let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+      (* the inserted zone is between [prev_insert] and [insert] *)
       let insert = buffer#get_iter_at_mark `INSERT in
-      let 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 prev_insert = buffer#get_iter_at_mark (`NAME "prev_insert") in
+      (* [prev_insert] is normally always before [insert] even when deleting.
+	 Let's check this nonetheless *)
+      let prev_insert =
+	if insert#compare prev_insert < 0 then insert else prev_insert
+      in
+      let start = grab_sentence_start prev_insert soi in
+      (** The status of "{" "}" as sentence delimiters is too fragile.
+	  We retag up to the next "." instead. *)
+      let stop = grab_ending_dot insert in
       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 ->
+      with Coq_lex.Unterminated ->
         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))
+	let callback () =
+	  if not !skip_curr then begin
+	    try split_slice_lax buffer start buffer#end_iter
+	    with Coq_lex.Unterminated -> ()
+	  end; false
+	in
+	ignore (Glib.Timeout.add ~ms:1500 ~callback)
     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 _ -> ()
+  try split_slice_lax buffer buffer#start_iter buffer#end_iter
+  with Coq_lex.Unterminated -> ()
 
 let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
   (* move back twice if not into proof_decl,
@@ -537,8 +561,8 @@ let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
     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 decl_end = grab_ending_dot decl_start in
+  let prf_end = grab_ending_dot prf_end in
   let prf_end = prf_end#forward_char in
   if decl_start#has_tag Tags.Script.folded then (
     buffer#remove_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
@@ -547,7 +571,12 @@ let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
     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 =
+(** The arguments that will be passed to coqtop. No quoting here, since
+    no /bin/sh when using create_process instead of open_process. *)
+let custom_project_files = ref []
+let sup_args = ref []
+
+class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs _ct _fn =
 object(self)
   val input_view = _script
   val input_buffer = _script#buffer
@@ -556,13 +585,15 @@ object(self)
   val message_view = _mv
   val message_buffer = _mv#buffer
   val cmd_stack = _cs
+  val mycoqtop = _ct
   val mutable is_active = false
   val mutable read_only = false
-  val mutable filename = None
+  val mutable filename = _fn
   val mutable stats = None
   val mutable last_modification_time = 0.
   val mutable last_auto_save_time = 0.
   val mutable detached_views = []
+  val mutable find_forward_instead_of_backward = false
 
   val mutable auto_complete_on = !current.auto_complete
   val hidden_proofs = Hashtbl.create 32
@@ -572,10 +603,10 @@ object(self)
   method set_auto_complete t = auto_complete_on <- t
   method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x ->
     let old = auto_complete_on in
-      self#set_auto_complete false;
-      let y = f x in
-	self#set_auto_complete old;
-	y
+    self#set_auto_complete false;
+    let y = f x in
+    self#set_auto_complete old;
+    y
   method add_detached_view (w:GWindow.window) =
     detached_views <- w::detached_views
   method remove_detached_view (w:GWindow.window) =
@@ -587,12 +618,6 @@ object(self)
 
   method filename = filename
   method stats = stats
-  method set_filename f =
-    filename <- f;
-    match f with
-      | Some f -> stats <- my_stat f
-      | None -> ()
-
   method update_stats =
     match filename with
       | Some f -> stats <- my_stat f
@@ -601,44 +626,44 @@ object(self)
   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";
-                  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 ()
+        let do_revert () = begin
+          push_info "Reverting buffer";
+          try
+            if is_active then self#force_reset_initial;
+            let b = Buffer.create 1024 in
+            with_file flash_info f ~f:(input_channel b);
+            let s = try_convert (Buffer.contents b) in
+            input_buffer#set_text s;
+            self#update_stats;
+            input_buffer#place_cursor ~where:input_buffer#start_iter;
+            input_buffer#set_modified false;
+            pop_info ();
+            flash_info "Buffer reverted";
+            force_retag input_buffer;
+          with _  ->
+            pop_info ();
+            flash_info "Warning: could not revert buffer";
         end
+        in
+        if input_buffer#modified then
+          match (GToolbox.question_box
+                   ~title:"Modified buffer changed on disk"
+                   ~buttons:["Revert from File";
+                             "Overwrite File";
+                             "Disable Auto Revert"]
+                   ~default:0
+                   ~icon:(stock_to_widget `DIALOG_WARNING)
+                   "Some unsaved buffers changed on disk"
+          )
+          with 1 -> do_revert ()
+            | 2 -> if self#save f then flash_info "Overwritten" else
+                flash_info "Could not overwrite file"
+            | _ ->
+              prerr_endline "Auto revert set to false";
+              !current.global_auto_revert <- false;
+              disconnect_revert_timer ()
+        else do_revert ()
+      end
       | None -> ()
 
   method save f =
@@ -647,8 +672,8 @@ object(self)
       input_buffer#set_modified false;
       stats <- my_stat f;
       (match self#auto_save_name with
-         | None -> ()
-         | Some fn -> try Sys.remove fn with _ -> ());
+        | None -> ()
+        | Some fn -> try Sys.remove fn with _ -> ());
       true
     end
     else false
@@ -657,31 +682,31 @@ object(self)
     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)
+        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)
+          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 =
@@ -690,16 +715,16 @@ object(self)
                ~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")
+               ~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
+    else self#save f
 
   method set_read_only b = read_only<-b
   method read_only = read_only
@@ -721,9 +746,9 @@ object(self)
 
   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...*)
+       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
@@ -737,229 +762,139 @@ object(self)
       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
+    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
-        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
+        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 ->
-      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."
 
+  method go_to_next_occ_of_cur_word =
+    let cv = session_notebook#current_term in
+    let av = cv.analyzed_view in
+    let b = (cv.script)#buffer in
+    let start = find_word_start (av#get_insert) in
+    let stop = find_word_end start in
+    let text = b#get_text ~start ~stop () in
+    match stop#forward_search text with
+      | None -> ()
+      | Some(start, _) ->
+        (b#place_cursor start;
+         self#recenter_insert)
+
+  method go_to_prev_occ_of_cur_word =
+    let cv = session_notebook#current_term in
+    let av = cv.analyzed_view in
+    let b = (cv.script)#buffer in
+    let start = find_word_start (av#get_insert) in
+    let stop = find_word_end start in
+    let text = b#get_text ~start ~stop () in
+    match start#backward_search text with
+      | None -> ()
+      | Some(start, _) ->
+        (b#place_cursor start;
+         self#recenter_insert)
 
   val mutable full_goal_done = true
 
   method show_goals_full =
     if not full_goal_done then
-      begin
-        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
+      proof_view#buffer#set_text "";
+    begin
+      let menu_callback = if !current.contextual_menus_on_goal then
+          (fun s () -> ignore (self#insert_this_phrase_on_success
+                                 true true false ("progress "^s) s))
+        else
+          (fun _ _ -> ()) in
+      try
+        begin match Coq.goals !mycoqtop with
+          | Interface.Fail (l, str) ->
+            self#set_message ("Error in coqtop :\n"^str)
+          | Interface.Good goals ->
+            begin match Coq.evars !mycoqtop with
+            | Interface.Fail (l, str) ->
+              self#set_message ("Error in coqtop :\n"^str)
+            | Interface.Good evs ->
+              let hints = match Coq.hints !mycoqtop with
+              | Interface.Fail (_, _) -> None
+              | Interface.Good hints -> hints
+              in
+              Ideproof.display
+                (Ideproof.mode_tactic menu_callback)
+                proof_view goals hints evs
+            end
+        end
+      with
+        | e -> prerr_endline (Printexc.to_string e)
+    end
 
   method show_goals = self#show_goals_full
 
-
-  method send_to_coq verbosely replace phrase show_output show_error localize =
+  method private send_to_coq ct verbose phrase show_output show_error localize =
     let display_output msg =
       self#insert_message (if show_output then msg else "") in
-    let display_error 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 Tags.Script.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 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)
+    let display_error (loc,s) =
+      if show_error then begin
+        if not (Glib.Utf8.validate s) then
+          flash_info "This error is so nasty that I can't even display it."
+        else begin
+          self#insert_message s;
+          message_view#misc#draw None;
+          if localize then
+            (match loc with
+              | None -> ()
+              | Some (start,stop) ->
+                let convert_pos = byte_offset_to_char_offset phrase in
+                let start = convert_pos start in
+                let stop = convert_pos stop in
+                let i = self#get_start_of_input in
+                let starti = i#forward_chars start in
+                let stopi = i#forward_chars stop in
+                input_buffer#apply_tag Tags.Script.error
+                  ~start:starti
+                  ~stop:stopi;
+                input_buffer#place_cursor ~where:starti)
         end
-      with e ->
-        if show_error then sync display_error e;
-        None
+      end in
+    try
+      full_goal_done <- false;
+      prerr_endline "Send_to_coq starting now";
+      (* It's important here to work with [ct] and not [!mycoqtop], otherwise
+         we could miss a restart of coqtop and continue sending it orders. *)
+      match Coq.interp ct ~verbose phrase with
+        | Interface.Fail (l,str) -> sync display_error (l,str); None
+        | Interface.Good msg -> sync display_output msg; Some Safe
+          (* TODO: Restore someday the access to Decl_mode.get_damon_flag,
+	     and also detect the use of admit, and then return Unsafe *)
+    with
+      | End_of_file -> (* Coqtop has died, let's trigger a reset_initial. *)
+        raise RestartCoqtop
+      | e -> sync display_error (None, Printexc.to_string e); None
 
   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
+      let start = grab_sentence_start start self#get_start_of_input in
+      let stop = grab_sentence_stop start in
+      if is_sentence_end stop#backward_char then Some (start,stop)
+      else None
     with Not_found -> None
 
   method complete_at_offset (offset:int) =
@@ -967,236 +902,269 @@ object(self)
     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
+    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 ~where:(it())#backward_char;
+            true
+      end else false
+    else false
 
-  method process_next_phrase verbosely display_goals do_highlight =
+  method private process_one_phrase ct verbosely display_goals do_highlight =
     let get_next_phrase () =
       self#clear_message;
-      prerr_endline "process_next_phrase starting now";
+      prerr_endline "process_one_phrase starting now";
       if do_highlight then begin
         push_info "Coq is computing";
         input_view#set_editable false;
       end;
       match self#find_phrase_starting_at self#get_start_of_input with
         | None ->
-            if do_highlight then begin
-              input_view#set_editable true;
-              pop_info ();
-            end;
-            None
+          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 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
+          prerr_endline "process_one_phrase : to_process highlight";
+          if do_highlight then begin
+            input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
+            prerr_endline "process_one_phrase : to_process applied";
+          end;
+          prerr_endline "process_one_phrase : getting phrase";
+          Some((start,stop),start#get_slice ~stop) in
     let remove_tag (start,stop) =
       if do_highlight then begin
         input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
         input_view#set_editable true;
         pop_info ();
       end in
-    let mark_processed reset_info is_complete (start,stop) =
+    let mark_processed safe (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 (is_complete,reset_info) ->
-                   sync (mark_processed reset_info is_complete) loc; true
-               | None -> sync remove_tag loc; false)
-    end
+      b#apply_tag (safety_tag safe) ~start ~stop;
+      if (self#get_insert#compare) stop <= 0 then
+        begin
+          b#place_cursor ~where:stop;
+          self#recenter_insert
+        end;
+      let ide_payload = { start = `MARK (b#create_mark start);
+                          stop = `MARK (b#create_mark stop); } in
+      Stack.push ide_payload cmd_stack;
+      if display_goals then self#show_goals;
+      remove_tag (start,stop)
+    in
+    match sync get_next_phrase () with
+      | None -> raise Unsuccessful
+      | Some ((_,stop) as loc,phrase) ->
+	  if stop#backward_char#has_tag Tags.Script.comment
+	  then sync mark_processed Safe loc
+          else try match self#send_to_coq ct verbosely phrase true true true with
+            | Some safe -> sync mark_processed safe loc
+            | None -> sync remove_tag loc; raise Unsuccessful
+	  with
+	    | RestartCoqtop -> sync remove_tag loc; raise RestartCoqtop
 
-  method insert_this_phrase_on_success
-        show_output show_msg localize coqphrase insertphrase =
-    let mark_processed reset_info is_complete =
+  method process_next_phrase verbosely =
+    try self#process_one_phrase !mycoqtop verbosely true true
+    with Unsuccessful -> ()
+
+  method private insert_this_phrase_on_success
+    show_output show_msg localize coqphrase insertphrase =
+    let mark_processed safe =
       let stop = self#get_start_of_input in
-        if stop#starts_line then
-          input_buffer#insert ~iter:stop insertphrase
-        else input_buffer#insert ~iter:stop ("\n"^insertphrase);
-        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
+      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 (safety_tag safe) ~start ~stop;
+      if (self#get_insert#compare) stop <= 0 then
+        input_buffer#place_cursor ~where:stop;
+      let ide_payload = { start = `MARK (input_buffer#create_mark start);
+                          stop = `MARK (input_buffer#create_mark stop); } in
+      Stack.push ide_payload cmd_stack;
+      self#show_goals;
+       (*Auto insert save on success...
+	 try (match Coq.get_current_goals () with
+	 | [] ->
+	 (match self#send_to_coq "Save.\n" true true true with
+	 | Some ast ->
+	 begin
+	 let stop = self#get_start_of_input in
+	 if stop#starts_line then
+	 input_buffer#insert ~iter:stop "Save.\n"
+	 else input_buffer#insert ~iter:stop "\nSave.\n";
+	 let start = self#get_start_of_input in
+	 input_buffer#move_mark ~where:stop (`NAME"start_of_input");
+	 input_buffer#apply_tag_by_name "processed" ~start ~stop;
+	 if (self#get_insert#compare) stop <= 0 then
+	 input_buffer#place_cursor stop;
+	 let start_of_phrase_mark =
+	 `MARK (input_buffer#create_mark start) in
+	 let end_of_phrase_mark =
+	 `MARK (input_buffer#create_mark stop) in
+	 push_phrase
+	 reset_info start_of_phrase_mark end_of_phrase_mark ast
+	 end
+	 | None -> ())
+	 | _ -> ())
+	 with _ -> ()*) in
+    match self#send_to_coq !mycoqtop false coqphrase show_output show_msg localize with
+      | Some safe -> sync mark_processed safe; true
+      | None ->
+        sync
+          (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
+          ();
+        false
 
   method process_until_iter_or_error stop =
     let stop' = `OFFSET stop#offset in
     let start = self#get_start_of_input#copy in
     let start' = `OFFSET start#offset in
+    sync (fun _ ->
+      input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
+      input_view#set_editable false) ();
+    push_info "Coq is computing";
+    let get_current () =
+      if !current.stop_before then
+        match self#find_phrase_starting_at self#get_start_of_input with
+          | None -> self#get_start_of_input
+          | Some (_, stop2) -> stop2
+      else begin
+        self#get_start_of_input
+      end
+    in
+    let unlock () =
       sync (fun _ ->
-              input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
-              input_view#set_editable false) ();
-      push_info "Coq is computing";
-      let get_current () =
-        if !current.stop_before then
-          match self#find_phrase_starting_at self#get_start_of_input with
-            | None -> self#get_start_of_input
-            | Some (_, stop2) -> stop2
-              else begin
-                self#get_start_of_input
-              end
-      in
-        (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()
+	self#show_goals;
+	(* Start and stop might be invalid if an eol was added at eof *)
+	let start = input_buffer#get_iter start' in
+	let stop =  input_buffer#get_iter stop' in
+	input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
+	input_view#set_editable true) ()
+    in
+    (* All the [process_one_phrase] below should be done with the same [ct]
+       instead of accessing multiple time [mycoqtop]. Otherwise a restart of
+       coqtop could go unnoticed, and the new coqtop could receive strange
+       things. *)
+    let ct = !mycoqtop in
+    (try
+       while stop#compare (get_current()) >= 0
+       do self#process_one_phrase ct false false false done
+     with
+       | Unsuccessful -> ()
+       | RestartCoqtop -> unlock (); raise RestartCoqtop);
+    unlock ();
+    pop_info()
 
   method process_until_end_or_error =
     self#process_until_iter_or_error input_buffer#end_iter
 
   method reset_initial =
-    sync (fun _ ->
-            Stack.iter
-              (function (inf,_) ->
-                 let start = input_buffer#get_iter_at_mark inf.start in
-                 let stop = input_buffer#get_iter_at_mark inf.stop in
-                   input_buffer#move_mark ~where:start (`NAME "start_of_input");
-                   input_buffer#remove_tag Tags.Script.processed ~start ~stop;
-                   input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
-                   input_buffer#delete_mark inf.start;
-                   input_buffer#delete_mark inf.stop;
-              )
-              cmd_stack;
-            Stack.clear cmd_stack;
-            self#clear_message)();
-    Coq.reset_initial ()
+    mycoqtop := Coq.respawn_coqtop !mycoqtop;
+    sync (fun () ->
+      Stack.iter
+	(function inf ->
+          let start = input_buffer#get_iter_at_mark inf.start in
+          let stop = input_buffer#get_iter_at_mark inf.stop in
+          input_buffer#move_mark ~where:start (`NAME "start_of_input");
+          input_buffer#remove_tag Tags.Script.processed ~start ~stop;
+	  input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+          input_buffer#delete_mark inf.start;
+          input_buffer#delete_mark inf.stop;
+	)
+	cmd_stack;
+      Stack.clear cmd_stack;
+      self#clear_message) ()
+
+  method force_reset_initial =
+    (* Do nothing if a force_reset_initial is already ongoing *)
+    if Mutex.try_lock resetting then begin
+      Coq.kill_coqtop !mycoqtop;
+      (* If a computation is ongoing, an exception will trigger
+	 the reset_initial in do_if_not_computing, not here. *)
+      if Mutex.try_lock coq_computing then begin
+	self#reset_initial;
+	Mutex.unlock coq_computing
+      end;
+      Mutex.unlock resetting
+    end
+
+  (* Internal method for dialoging with coqtop about a backtrack.
+     The ide's cmd_stack has already been cleared up to the desired point.
+     The [finish] function is used to handle minor differences between
+     [go_to_insert] and [undo_last_step] *)
+
+  method private do_backtrack finish n =
+    (* pop n more commands if coqtop has said so (e.g. for undoing a proof) *)
+    let rec n_pop n =
+      if n = 0 then ()
+      else
+	let phrase = Stack.pop cmd_stack in
+	let stop = input_buffer#get_iter_at_mark phrase.stop in
+        if stop#backward_char#has_tag Tags.Script.comment
+	  then n_pop n
+	  else n_pop (pred n)
+    in
+    match Coq.rewind !mycoqtop n with
+      | Interface.Good n ->
+	n_pop n;
+        sync (fun _ ->
+          let start =
+            if Stack.is_empty cmd_stack then input_buffer#start_iter
+            else input_buffer#get_iter_at_mark (Stack.top cmd_stack).stop in
+	  let stop = self#get_start_of_input in
+          input_buffer#remove_tag Tags.Script.processed ~start ~stop;
+          input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+          input_buffer#move_mark ~where:start (`NAME "start_of_input");
+          self#show_goals;
+          self#clear_message;
+          finish start) ()
+      | Interface.Fail (l,str) ->
+        sync self#set_message
+          ("Error while backtracking :\n" ^ str ^ "\n" ^
+	   "CoqIDE and coqtop may be out of sync, you may want to use Restart.")
 
   (* backtrack Coq to the phrase preceding iterator [i] *)
   method backtrack_to_no_lock i =
     prerr_endline "Backtracking_to iter starts now.";
+    full_goal_done <- false;
     (* pop Coq commands until we reach iterator [i] *)
-    let rec pop_cmds popped =
-      if Stack.is_empty cmd_stack then
-        popped
-      else
-        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 command";
-            pop_cmds (coq::popped)
-          end
-        else
-          begin
-            Stack.push (ide,coq) cmd_stack;
-            popped
-          end
+    let rec n_step n =
+      if Stack.is_empty cmd_stack then n else
+        let phrase = Stack.top cmd_stack in
+	let stop = input_buffer#get_iter_at_mark phrase.stop in
+        if i#compare stop >= 0 then n
+	else begin
+	  ignore (Stack.pop cmd_stack);
+          if stop#backward_char#has_tag Tags.Script.comment
+	  then n_step n
+	  else n_step (succ n)
+	end
     in
-    let seq = List.rev (pop_cmds []) in
-      prerr_endline "Popped commands";
-      if 0 < List.length seq then
-        begin
-          try
-            rewind seq cmd_stack;
-            sync (fun _ ->
-                    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 (...)"
+    begin
+      try
+	self#do_backtrack (fun _ -> ()) (n_step 0);
+	(* We may have backtracked too much: let's replay *)
+	self#process_until_iter_or_error i
+      with _ ->
+        push_info
+	  ("WARNING: undo failed badly.\n" ^
+	   "Coq might be in an inconsistent state.\n" ^
+	   "Please restart and report.");
+    end
 
   method backtrack_to i =
     if Mutex.try_lock coq_may_stop then
@@ -1207,41 +1175,26 @@ object(self)
 
   method go_to_insert =
     let point = self#get_insert in
-      if point#compare self#get_start_of_input>=0
-      then self#process_until_iter_or_error point
-      else self#backtrack_to point
+    if point#compare self#get_start_of_input>=0
+    then self#process_until_iter_or_error point
+    else self#backtrack_to point
 
   method undo_last_step =
+    full_goal_done <- false;
     if Mutex.try_lock coq_may_stop then
       (push_info "Undoing last step...";
        (try
-          let (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"*)()
+          let phrase = Stack.pop cmd_stack in
+	  let stop = input_buffer#get_iter_at_mark phrase.stop in
+	  let count =
+	    if stop#backward_char#has_tag Tags.Script.comment then 0 else 1
+	  in
+	  let finish where =
+	    input_buffer#place_cursor ~where;
+	    self#recenter_insert;
+	  in
+	  self#do_backtrack finish count
+        with Stack.Empty -> ()
        );
        pop_info ();
        Mutex.unlock coq_may_stop)
@@ -1257,231 +1210,233 @@ object(self)
     ignore
       (List.exists
          (fun p ->
-            self#insert_this_phrase_on_success true false false
-              ("progress "^p^".\n") (p^".\n")) l)
+           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
-      end
+    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
+    end
 
 
   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
+        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 () =
-    is_active <- false;
-    (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);
-    prerr_endline "CONNECTED  inactive : ";
-    print_id (Option.get deact_id)*)
-
-  (* XXX *)
-  method activate () =
-    is_active <- true;(*
-    (match deact_id with None -> ()
-       | Some id -> input_view#misc#disconnect id;
-                    prerr_endline "DISCONNECTED old inactive : ";
-                    print_id id
-    );*)
+  method activate () = if not is_active then begin
+    is_active <- true;
     act_id <- Some
-                (input_view#event#connect#key_press self#active_keypress_handler);
+      (input_view#event#connect#key_press ~callback:self#active_keypress_handler);
     prerr_endline "CONNECTED active : ";
-    print_id (Option.get act_id);
-    match
-      filename
-    with
+    print_id (match act_id with Some x -> x | None -> assert false);
+    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 =
-    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;)
+      | Some f ->
+	let dir = Filename.dirname f in
+	let ct = !mycoqtop in
+	match Coq.inloadpath ct dir with
+	  | Interface.Fail (_,str) ->
+	    self#set_message
+	      ("Could not determine lodpath, this might lead to problems:\n"^str)
+	  | Interface.Good true -> ()
+	  | Interface.Good false ->
+	    let cmd = Printf.sprintf "Add LoadPath \"%s\". "  dir in
+	    match Coq.interp ct cmd with
+	      | Interface.Fail (l,str) ->
+		self#set_message ("Couln't add loadpath:\n"^str)
+	      | Interface.Good _ -> ()
+  end
 
   method private electric_paren tag =
-    let oparen_code = Glib.Utf8.to_unichar "("  (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 ()
-                       | _ -> ())
-     )
+    let oparen_code = Glib.Utf8.to_unichar "("  ~pos:(ref 0) in
+    let cparen_code = Glib.Utf8.to_unichar ")"  ~pos:(ref 0) in
+    ignore (input_buffer#connect#insert_text ~callback:
+              (fun it x ->
+                input_buffer#remove_tag
+                  ~start:input_buffer#start_iter
+                  ~stop:input_buffer#end_iter
+                  tag;
+                if x = "" then () else
+                  match x.[String.length x - 1] with
+                    | ')' ->
+                      let hit = self#get_insert in
+                      let count = ref 0 in
+                      if hit#nocopy#backward_find_char
+                        (fun c ->
+                          if c = oparen_code && !count = 0 then true
+                          else if c = cparen_code then
+                            (incr count;false)
+                          else if c = oparen_code then
+                            (decr count;false)
+                          else false
+                        )
+                      then
+                        begin
+                          prerr_endline "Found matching parenthesis";
+                          input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
+                        end
+                      else ()
+                    | _ -> ())
+  )
 
   method help_for_keyword () =
-
     browse_keyword (self#insert_message) (get_current_word ())
 
+(** NB: Events during text edition:
+
+    - [begin_user_action]
+    - [insert_text] (or [delete_range] when deleting)
+    - [changed]
+    - [end_user_action]
+
+   When pasting a text containing tags (e.g. the sentence terminators),
+   there is actually many [insert_text] and [changed]. For instance,
+   for "a. b.":
+
+    - [begin_user_action]
+    - [insert_text] (for "a")
+    - [changed]
+    - [insert_text] (for ".")
+    - [changed]
+    - [apply_tag] (for the tag of ".")
+    - [insert_text] (for " b")
+    - [changed]
+    - [insert_text] (for ".")
+    - [changed]
+    - [apply_tag] (for the tag of ".")
+    - [end_user_action]
+
+  Since these copy-pasted tags may interact badly with the retag mechanism,
+  we now don't monitor the "changed" event, but rather the "begin_user_action"
+  and "end_user_action". We begin by setting a mark at the initial cursor
+  point. At the end, the zone between the mark and the cursor is to be
+  untagged and then retagged. *)
+
   initializer
     ignore (message_buffer#connect#insert_text
               ~callback:(fun it s -> ignore
-                                       (message_view#scroll_to_mark
-                                          ~use_align:false
-                                          ~within_margin:0.49
-                                          `INSERT)));
+                (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)));
+                if (it#compare self#get_start_of_input)<0
+                then GtkSignal.stop_emit ();
+                if String.length s > 1 then
+                  (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor ~where:it)));
     ignore (input_buffer#connect#after#apply_tag
               ~callback:(fun tag ~start ~stop ->
-                           if (start#compare self#get_start_of_input)>=0
-                           then
-                             begin
-                               input_buffer#remove_tag
-                                 Tags.Script.processed
-                                 ~start
-                                 ~stop;
-                               input_buffer#remove_tag
-                                 Tags.Script.unjustified
-                                 ~start
-                                 ~stop
-                             end
+                if (start#compare self#get_start_of_input)>=0
+                then
+                  begin
+                    input_buffer#remove_tag
+                      Tags.Script.processed
+                      ~start
+                      ~stop;
+                    input_buffer#remove_tag
+                      Tags.Script.unjustified
+                      ~start
+                      ~stop
+                  end
               )
     );
     ignore (input_buffer#connect#after#insert_text
               ~callback:(fun it s ->
-                           if auto_complete_on &&
-                              String.length s = 1 && s <> " " && s <> "\n"
-                           then
-                             let v = session_notebook#current_term.analyzed_view
-                             in
-                             let has_completed =
-                               v#complete_at_offset
-                                 ((input_view#buffer#get_iter `SEL_BOUND)#offset)
-                             in
-                               if has_completed then
-                                 input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char;
-
-
+                if auto_complete_on &&
+                  String.length s = 1 && s <> " " && s <> "\n"
+                then
+                  let v = session_notebook#current_term.analyzed_view
+                  in
+                  let has_completed =
+                    v#complete_at_offset
+                      ((input_view#buffer#get_iter `SEL_BOUND)#offset)
+                  in
+                  if has_completed then
+                    input_buffer#move_mark `SEL_BOUND ~where:(input_buffer#get_iter `SEL_BOUND)#forward_char;
               )
     );
-    ignore (input_buffer#connect#changed
+    ignore (input_buffer#connect#begin_user_action
+	      ~callback:(fun () ->
+		           let here = input_buffer#get_iter_at_mark `INSERT in
+			   input_buffer#move_mark (`NAME "prev_insert") here
+	      )
+    );
+    ignore (input_buffer#connect#end_user_action
               ~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
+                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));
+    self#electric_paren Tags.Script.paren;
+    ignore (input_buffer#connect#after#mark_set
+              ~callback:(fun it (m:Gtk.text_mark) ->
+                !set_location
+                  (Printf.sprintf
+                     "Line: %5d Char: %3d" (self#get_insert#line + 1)
+                     (self#get_insert#line_offset + 1));
+                match GtkText.Mark.get_name m  with
+                  | Some "insert" ->
+                    input_buffer#remove_tag
+                      ~start:input_buffer#start_iter
+                      ~stop:input_buffer#end_iter
+                      Tags.Script.paren;
+                  | Some s ->
+                    prerr_endline (s^" moved")
+                  | None -> () )
+    );
+    ignore (input_buffer#connect#insert_text
+              ~callback:(fun it s ->
+                prerr_endline "Should recenter ?";
+                if String.contains s '\n' then begin
+                  prerr_endline "Should recenter : yes";
+                  self#recenter_insert
+                end));
 end
 
 let last_make = ref "";;
@@ -1498,9 +1453,9 @@ let search_next_error () =
   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;
-    (f,l,b,e,
-     String.sub !last_make msg_index (String.length !last_make - msg_index))
+  last_make_index := Str.group_end 4;
+  (f,l,b,e,
+   String.sub !last_make msg_index (String.length !last_make - msg_index))
 
 
 
@@ -1508,7 +1463,7 @@ let search_next_error () =
 (* session creation and primitive handling                            *)
 (**********************************************************************)
 
-let create_session () =
+let create_session file =
   let script =
     Undo.undoable_view
       ~buffer:(GText.buffer ~tag_table:Tags.Script.table ())
@@ -1521,70 +1476,87 @@ let create_session () =
     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 basename = GMisc.label ~text:(match file with
+				      |None -> "*scratch*"
+				      |Some f -> (Glib.Convert.filename_to_utf8 (Filename.basename f))
+				   ) () in
+  let stack = Stack.create () in
+  let coqtop_args = match file with
+    |None -> !sup_args
+    |Some the_file -> match !current.read_project with
+	|Ignore_args -> !sup_args
+	|Append_args -> (Project_file.args_from_project the_file !custom_project_files !current.project_file_name)
+	   @(!sup_args)
+	|Subst_args -> Project_file.args_from_project the_file !custom_project_files !current.project_file_name
+  in
+  let ct = ref (Coq.spawn_coqtop coqtop_args) in
+  let command = new Command_windows.command_window ct current in
+  let legacy_av = new analyzed_view script proof message stack ct file in
+  let () = legacy_av#update_stats in
   let _ =
     script#buffer#create_mark ~name:"start_of_input" script#buffer#start_iter in
   let _ =
+    script#buffer#create_mark ~name:"prev_insert" script#buffer#start_iter in
+  let _ =
     proof#buffer#create_mark ~name:"end_of_conclusion" proof#buffer#start_iter in
   let _ =
     GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in
+  let () =
+    List.iter (fun (opts,_,_,_,dflt) -> setopts !ct opts dflt) print_items in
+  let _ = legacy_av#activate () in
   let _ =
     proof#event#connect#motion_notify ~callback:
       (fun e ->
-         let win = match proof#get_window `WIDGET with
-           | None -> assert false
-           | Some w -> w in
-         let x,y = Gdk.Window.get_pointer_location win in
-         let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
-         let it = proof#get_iter_at_location ~x:b_x ~y:b_y in
-         let tags = it#tags in
-           List.iter
-             (fun t ->
-                ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter))
-             tags;
-           false) in
-    script#misc#set_name "ScriptWindow";
-    script#buffer#place_cursor ~where:(script#buffer#start_iter);
-    proof#misc#set_can_focus true;
-    message#misc#set_can_focus true;
-    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=""
-    }
+        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=begin match file with None -> "" |Some f -> f end;
+    script=script;
+    proof_view=proof;
+    message_view=message;
+    analyzed_view=legacy_av;
+    encoding="";
+    toplvl=ct;
+    command=command
+  }
 
 (* XXX - to be used later
-let load_session session filename encs =
-  session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs;
-  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
-  session.filename <- filename;
-  session.script#buffer#set_modified false
+   let 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 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
- *)
+   let init_session session =
+   session.script#buffer#set_modified false;
+   session.script#clear_undo;
+   session.script#buffer#place_cursor session.script#buffer#start_iter
+*)
 
 
 
@@ -1593,93 +1565,93 @@ let init_session session =
 (* 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_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 ()
+*)
 
 (* Nota: using && here has the advantage of working both under win32 and unix.
    If someday we want the main command to be tried even if the "cd" has failed,
@@ -1691,36 +1663,147 @@ let local_cd file =
 
 let do_print session =
   let av = session.analyzed_view in
-    match av#filename with
-      |None -> flash_info "Cannot print: this buffer has no name"
-      |Some f_name -> begin
-	  let cmd =
-	local_cd session.filename ^
-              !current.cmd_coqdoc ^ " --coqlib_path " ^ Envars.coqlib () ^
-	      " -ps " ^ Filename.quote (Filename.basename f_name) ^
-              " | " ^ !current.cmd_print
-	  in
-	  let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE"  () in
-	  let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in
-	  let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in
-	  let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in
-	  let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in
-	  let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
-	  let print_button  = GButton.button ~stock:`PRINT  ~label:"Print"  ~packing:hbox_print#add () in
-	  let callback_print () =
-            let cmd = print_entry#text in
-            let s,_ = run_command av#insert_message cmd in
-              flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
-              print_window#destroy ()
-	  in
-            ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
-            ignore (print_button#connect#clicked ~callback:callback_print);
-            print_window#misc#show ()
+  match av#filename with
+    |None ->  flash_info "Cannot print: this buffer has no name"
+    |Some f_name ->  begin
+      let cmd =
+        local_cd f_name ^
+          !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename f_name) ^
+          " | " ^ !current.cmd_print
+      in
+      let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE"  () in
+      let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in
+      let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in
+      let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in
+      let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in
+      let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
+      let print_button  = GButton.button ~stock:`PRINT  ~label:"Print"  ~packing:hbox_print#add () in
+      let callback_print () =
+        let cmd = print_entry#text in
+        let s,_ = run_command av#insert_message cmd in
+        flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
+        print_window#destroy ()
+      in
+      ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
+      ignore (print_button#connect#clicked ~callback:callback_print);
+      print_window#misc#show ()
+    end
+
+let load_file handler f =
+  let f = absolute_filename f in
+  try
+    prerr_endline "Loading file starts";
+    let is_f = Minilib.same_file f in
+      if not (Minilib.list_fold_left_i
+		(fun i found x -> if found then found else
+                   let {analyzed_view=av} = x in
+                     (match av#filename with
+			| None -> false
+			| Some fn ->
+			    if is_f fn
+			    then (session_notebook#goto_page i; true)
+			    else false))
+              0 false session_notebook#pages)
+      then begin
+	prerr_endline "Loading: must open";
+	let b = Buffer.create 1024 in
+	prerr_endline "Loading: get raw content";
+	with_file handler f ~f:(input_channel b);
+	prerr_endline "Loading: convert content";
+	let s = do_convert (Buffer.contents b) in
+	prerr_endline "Loading: create view";
+	let session = create_session (Some f) in
+	prerr_endline "Loading: adding view";
+	let index = session_notebook#append_term session in
+	let av = session.analyzed_view in
+	prerr_endline "Loading: stats";
+	av#update_stats;
+	let input_buffer = session.script#buffer in
+	prerr_endline "Loading: fill buffer";
+	input_buffer#set_text s;
+	input_buffer#place_cursor ~where:input_buffer#start_iter;
+	force_retag input_buffer;
+	prerr_endline ("Loading: switch to view "^ string_of_int index);
+	session_notebook#goto_page index;
+	prerr_endline "Loading: highlight";
+	input_buffer#set_modified false;
+	prerr_endline "Loading: clear undo";
+	session.script#clear_undo;
+	prerr_endline "Loading: success"
+      end
+  with
+    | e -> handler ("Load failed: "^(Printexc.to_string e))
+
+let do_load = load_file flash_info
+
+let saveall_f () =
+  List.iter
+    (function
+       | {script = view ; analyzed_view = av} ->
+           begin match av#filename with
+             | None -> ()
+             | Some f ->
+		 ignore (av#save f)
+           end
+    )  session_notebook#pages
+
+let forbid_quit_to_save () =
+    begin try save_pref() with e -> flash_info "Cannot save preferences" end;
+    (if List.exists
+      (function
+        | {script=view} -> view#buffer#modified
+      )
+      session_notebook#pages then
+      match (GToolbox.question_box ~title:"Quit"
+               ~buttons:["Save Named Buffers and Quit";
+                         "Quit without Saving";
+                         "Don't Quit"]
+               ~default:0
+               ~icon:
+               (let img = GMisc.image () in
+                img#set_stock `DIALOG_WARNING;
+                img#set_icon_size `DIALOG;
+                img#coerce)
+               "There are unsaved buffers"
+      )
+      with 1 -> saveall_f () ; false
+        | 2 -> false
+        | _ -> true
+    else false)||
+      (let wait_window =
+        GWindow.window ~modal:true ~wm_class:"CoqIde" ~wm_name:"CoqIde" ~kind:`POPUP
+          ~title:"Terminating coqtops" () in
+      let _ =
+        GMisc.label ~text:"Terminating coqtops processes, please wait ..."
+          ~packing:wait_window#add () in
+      let warning_window =
+        GWindow.message_dialog ~message_type:`WARNING ~buttons:GWindow.Buttons.yes_no
+          ~message:
+	  ("Some coqtops processes are still running.\n" ^
+	     "If you quit CoqIDE right now, you may have to kill them manually.\n" ^
+	     "Do you want to wait for those processes to terminate ?") () in
+      let () = List.iter (fun _ -> session_notebook#remove_page 0) session_notebook#pages in
+      let nb_try=ref (0) in
+      let () = wait_window#show () in
+      let () = while (Coq.coqtop_zombies () <> 0)&&(!nb_try <= 50) do
+	incr nb_try;
+	Thread.delay 0.1 ;
+      done in
+	if (!nb_try = 50) then begin
+	  wait_window#misc#hide ();
+	  match warning_window#run () with
+	    | `YES -> warning_window#misc#hide (); true
+	    | `NO | `DELETE_EVENT -> false
 	end
+	else false)
 
 let main files =
   (* Statup preferences *)
-  load_pref ();
+  begin
+    try load_pref ()
+    with e ->
+      flash_info ("Could not load preferences ("^Printexc.to_string e^").");
+  end;
 
   (* Main window *)
   let w = GWindow.window
@@ -1729,1626 +1812,1152 @@ let main files =
     ~width:!current.window_width ~height:!current.window_height
     ~title:"CoqIde" ()
   in
-    (try
-	 let icon_image = lib_ide_file "coq.png" in
-	 let icon = GdkPixbuf.from_file icon_image in
-	   w#set_icon (Some icon)
-     with _ -> ());
+  (try
+     let icon_image = Filename.concat (List.find
+       (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
+       Minilib.xdg_data_dirs) "coq.png" in
+     let icon = GdkPixbuf.from_file icon_image in
+     w#set_icon (Some icon)
+   with _ -> ());
 
-    let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
+  let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
 
+  let new_f _ =
+    match select_file_for_save ~title:"Create file" () with
+      | None -> ()
+      | Some f -> do_load f
+  in
+  let load_f _ =
+    match select_file_for_open ~title:"Load file" () with
+      | None -> ()
+      | Some f -> do_load f
+  in
+  let save_f _ =
+    let current = session_notebook#current_term in
+    try
+      (match current.analyzed_view#filename with
+        | None ->
+          begin match select_file_for_save ~title:"Save file" ()
+            with
+              | None -> ()
+              | Some f ->
+                if current.analyzed_view#save_as f then begin
+                  current.tab_label#set_text (Filename.basename f);
+                  flash_info ("File " ^ f ^ " saved")
+                end
+                else warning ("Save Failed (check if " ^ f ^ " is writable)")
+          end
+        | Some f ->
+          if current.analyzed_view#save f then
+            flash_info ("File " ^ f ^ " saved")
+          else warning  ("Save Failed (check if " ^ f ^ " is writable)")
 
-    (* Menu bar *)
-    let menubar = GMenu.menu_bar ~packing:vbox#pack () in
+      )
+    with
+      | e -> warning "Save: unexpected error"
+  in
+  let saveas_f _ =
+    let current = session_notebook#current_term in
+    try (match current.analyzed_view#filename with
+      | None ->
+        begin match select_file_for_save ~title:"Save file as" ()
+          with
+            | None -> ()
+            | Some f ->
+              if current.analyzed_view#save_as f then begin
+                current.tab_label#set_text (Filename.basename f);
+                flash_info "Saved"
+              end
+              else flash_info "Save Failed"
+        end
+      | Some f ->
+        begin match select_file_for_save
+            ~dir:(ref (Filename.dirname f))
+            ~filename:(Filename.basename f)
+            ~title:"Save file as" ()
+          with
+            | None -> ()
+            | Some f ->
+              if current.analyzed_view#save_as f then begin
+                current.tab_label#set_text (Filename.basename f);
+                flash_info "Saved"
+              end else flash_info "Save Failed"
+        end);
+    with e -> flash_info "Save Failed"
+  in
+  let revert_f {analyzed_view = av} =
+    (try
+       match av#filename,av#stats with
+         | Some f,Some stats ->
+           let new_stats = Unix.stat f in
+           if new_stats.Unix.st_mtime > stats.Unix.st_mtime
+           then av#revert
+         | Some _, None -> av#revert
+         | _ -> ()
+     with _ -> av#revert)
+  in
+  let export_f kind _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    match av#filename with
+      | None ->
+        flash_info "Cannot print: this buffer has no name"
+      | Some f ->
+        let basef = Filename.basename f in
+        let output =
+          let basef_we = try Filename.chop_extension basef with _ -> basef in
+          match kind with
+            | "latex" -> basef_we ^ ".tex"
+            | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
+            | _ -> assert false
+        in
+        let cmd =
+          local_cd f ^ !current.cmd_coqdoc ^ " --" ^ kind ^
+	    " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef)
+        in
+        let s,_ = run_command av#insert_message cmd in
+        flash_info (cmd ^
+                      if s = Unix.WEXITED 0
+                      then " succeeded"
+                      else " failed")
+  in
+  let quit_f _ = if not (forbid_quit_to_save ()) then exit 0 in
+  let get_active_view_for_cp () =
+    let has_sel (i0,i1) = i0#compare i1 <> 0 in
+    let current = session_notebook#current_term in
+    if has_sel current.script#buffer#selection_bounds
+    then current.script#as_view
+    else if has_sel current.proof_view#buffer#selection_bounds
+    then current.proof_view#as_view
+    else current.message_view#as_view
+  in
+  (*
+    let toggle_auto_complete_i =
+    edit_f#add_check_item "_Auto Completion"
+    ~active:!current.auto_complete
+    ~callback:
+    in
+  *)
+  (*
+    auto_complete :=
+    (fun b -> match session_notebook#current_term.analyzed_view with
+    | Some av -> av#set_auto_complete b
+    | None -> ());
+  *)
+
+(* begin of find/replace mechanism *)
+  let last_found = ref None in
+  let search_backward = ref false in
+  let find_w = GWindow.window
+    (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
+    (* ~allow_grow:true ~allow_shrink:true *)
+    (* ~width:!current.window_width ~height:!current.window_height *)
+    ~position:`CENTER
+    ~title:"CoqIde search/replace" ()
+  in
+  let find_box = GPack.table
+    ~columns:3 ~rows:5
+    ~col_spacings:10 ~row_spacings:10 ~border_width:10
+    ~homogeneous:false ~packing:find_w#add () in
 
-    (* Toolbar *)
-    let toolbar = GButton.toolbar
-      ~orientation:`HORIZONTAL
-      ~style:`ICONS
-      ~tooltips:true
-      ~packing:(* handle#add *)
-      (vbox#pack ~expand:false ~fill:false)
+  let _ =
+    GMisc.label ~text:"Find:"
+      ~xalign:1.0
+      ~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 _ =
+    GMisc.label ~text:"Replace with:"
+      ~xalign:1.0
+      ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) ()
+  in
+  let replace_entry = GEdit.entry
+    ~editable: true
+    ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
+    ()
+  in
+  (* let _ =
+     GButton.check_button
+     ~label:"case sensitive"
+     ~active:true
+     ~packing: (find_box#attach ~left:1 ~top:2)
+     ()
+     in
+  *)
+  let find_backwards_check =
+    GButton.check_button
+      ~label:"search backwards"
+      ~active:!search_backward
+      ~packing: (find_box#attach ~left:1 ~top:3)
+      ()
+  in
+  let close_find_button =
+    GButton.button
+      ~label:"Close"
+      ~packing: (find_box#attach ~left:2 ~top:2)
+      ()
+  in
+  let replace_find_button =
+    GButton.button
+      ~label:"Replace and find"
+      ~packing: (find_box#attach ~left:2 ~top:1)
       ()
+  in
+  let find_again_button =
+    GButton.button
+      ~label:"_Find again"
+      ~packing: (find_box#attach ~left:2 ~top:0)
+      ()
+  in
+  let last_find () =
+    let v = session_notebook#current_term.script in
+    let b = v#buffer in
+    let start,stop =
+      match !last_found with
+	| None -> let i = b#get_iter_at_mark `INSERT in (i,i)
+	| Some(start,stop) ->
+	  let start = b#get_iter_at_mark start
+	  and stop = b#get_iter_at_mark stop
+	  in
+	  b#remove_tag Tags.Script.found ~start ~stop;
+	  last_found:=None;
+	  start,stop
     in
-      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
-      let accel_group = factory#accel_group in
-
-      (* File Menu *)
-      let file_menu = factory#add_submenu "_File" in
-
-      let file_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/File/" file_menu ~accel_group in
-
-      (* File/Load Menu *)
-      let load_file handler f =
-	let f = absolute_filename f in
-	  try
-	    prerr_endline "Loading file starts";
-	    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";
-	      with_file handler f ~f:(input_channel b);
-	      prerr_endline "Loading: convert content";
-	      let s = do_convert (Buffer.contents b) in
-		prerr_endline "Loading: create view";
-                let session = create_session () in
-                  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename f));
-		  prerr_endline "Loading: adding view";
-                  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 = 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);
-		      session_notebook#goto_page index;
-		      prerr_endline "Loading: highlight";
-		      input_buffer#set_modified false;
-		      prerr_endline "Loading: clear undo";
-		      session.script#clear_undo;
-		      prerr_endline "Loading: success"
-            end
-	  with
-	    | e -> handler ("Load failed: "^(Printexc.to_string e))
-      in
-      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
-	  | None -> ()
-	  | Some f -> load f
-      in
-	ignore (load_m#connect#activate (load_f));
-
-      let load_m = file_factory#add_item "_Open"
-	~key:GdkKeysyms._O in
-      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"
-	  ~key:GdkKeysyms._S in
-	let save_f () =
-	  let current = session_notebook#current_term in
-	    try
-	      (match current.analyzed_view#filename with
-		 | None ->
-		     begin match select_file_for_save ~title:"Save file" ()
-		       with
-			 | None -> ()
-			 | Some f ->
-			     if current.analyzed_view#save_as f then begin
-                                 current.tab_label#set_text (Filename.basename f);
-				 flash_info ("File " ^ f ^ " saved")
-			       end
-			     else warning ("Save Failed (check if " ^ f ^ " is writable)")
-		     end
-		 | Some f ->
-		     if current.analyzed_view#save f then
-		       flash_info ("File " ^ f ^ " saved")
-		     else warning  ("Save Failed (check if " ^ f ^ " is writable)")
-
-	      )
-	    with
-	      | e -> warning "Save: unexpected error"
+    (v,b,start,stop)
+  in
+  let do_replace () =
+    let v = session_notebook#current_term.script in
+    let b = v#buffer in
+    match !last_found with
+      | None -> ()
+      | Some(start,stop) ->
+	let start = b#get_iter_at_mark start
+	and stop = b#get_iter_at_mark stop
+	in
+	b#delete ~start ~stop;
+	b#insert ~iter:start replace_entry#text;
+	last_found:=None
+  in
+  let find_from (v : Undo.undoable_view)
+      (b : GText.buffer) (starti : GText.iter) text =
+    prerr_endline ("Searching for " ^ text);
+    match (if !search_backward then starti#backward_search text
+      else starti#forward_search text)
+    with
+      | None -> ()
+      | Some(start,stop) ->
+	b#apply_tag Tags.Script.found ~start ~stop;
+	let start = `MARK (b#create_mark start)
+	and stop = `MARK (b#create_mark stop)
 	in
-	  ignore (save_m#connect#activate save_f);
+	v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
+	  stop;
+	last_found := Some(start,stop)
+  in
+  let do_find () =
+    let (v,b,starti,_) = last_find () in
+    find_from v b starti find_entry#text
+  in
+  let do_replace_find () =
+    do_replace();
+    do_find()
+  in
+  let close_find () =
+    let (v,b,_,stop) = last_find () in
+    b#place_cursor ~where:stop;
+    find_w#misc#hide();
+    v#coerce#misc#grab_focus()
+  in
+  to_do_on_page_switch :=
+    (fun i -> if find_w#misc#visible then close_find())::
+    !to_do_on_page_switch;
+  let find_again () =
+    let (v,b,start,_) = last_find () in
+    let start =
+      if !search_backward
+      then start#backward_chars 1
+      else start#forward_chars 1
+    in
+    find_from v b start find_entry#text
+  in
+  let click_on_backward () =
+    search_backward := not !search_backward
+  in
+  let key_find ev =
+    let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
+    if k = GdkKeysyms._Escape then
+      begin
+	let (v,b,_,stop) = last_find () in
+	find_w#misc#hide();
+	v#coerce#misc#grab_focus();
+	true
+      end
+    else if k = GdkKeysyms._Escape then
+      begin
+	close_find();
+	true
+      end
+    else if k = GdkKeysyms._Return ||
+	   List.mem `CONTROL s && k = GdkKeysyms._f then
+      begin
+	find_again ();
+	true
+      end
+    else if List.mem `CONTROL s && k = GdkKeysyms._b then
+      begin
+	find_backwards_check#set_active (not !search_backward);
+	true
+      end
+    else false (* to let default callback execute *)
+  in
+  let find_f ~backward () =
+    let save_dir = !search_backward in
+    search_backward := backward;
+    find_w#show ();
+    find_w#present ();
+    find_entry#misc#grab_focus ();
+    search_backward := save_dir
+  in
+  let _ = find_again_button#connect#clicked find_again in
+  let _ = close_find_button#connect#clicked close_find in
+  let _ = replace_find_button#connect#clicked do_replace_find in
+  let _ = find_backwards_check#connect#clicked click_on_backward in
+  let _ = find_entry#connect#changed do_find in
+  let _ = find_entry#event#connect#key_press ~callback:key_find in
+  let _ = find_w#event#connect#delete ~callback:(fun _ -> find_w#misc#hide(); true) in
+  (*
+    let search_if = edit_f#add_item "Search _forward"
+    ~key:GdkKeysyms._greater
+    in
+    let search_ib = edit_f#add_item "Search _backward"
+    ~key:GdkKeysyms._less
+    in
+  *)
+  (*
+    let complete_i = edit_f#add_item "_Complete"
+    ~key:GdkKeysyms._comma
+    ~callback:
+    (do_if_not_computing
+    (fun b ->
+    let v = session_notebook#current_term.analyzed_view
+
+    in v#complete_at_offset
+    ((v#view#buffer#get_iter `SEL_BOUND)#offset)
+    ))
+    in
+    complete_i#misc#set_state `INSENSITIVE;
+  *)
+(* end of find/replace mechanism *)
+(* begin Preferences *)
+  let reset_revert_timer () =
+    disconnect_revert_timer ();
+    if !current.global_auto_revert then
+      revert_timer := Some
+	(GMain.Timeout.add ~ms:!current.global_auto_revert_delay
+	   ~callback:
+	   (fun () ->
+	     do_if_not_computing "revert" (sync revert_f) session_notebook#pages;
+	     true))
+  in reset_revert_timer (); (* to enable statup preferences timer *)
+  (* XXX *)
+  let auto_save_f {analyzed_view = av} =
+    (try
+       av#auto_save
+     with _ -> ())
+  in
 
-	  (* File/Save As Menu *)
-	  let saveas_m = file_factory#add_item "S_ave as"
-	  in
-	  let saveas_f () =
-	    let current = session_notebook#current_term in
-	      try (match current.analyzed_view#filename with
-		     | None ->
-			 begin match select_file_for_save ~title:"Save file as" ()
-			   with
-			     | None -> ()
-			     | Some f ->
-				 if current.analyzed_view#save_as f then begin
-                                   current.tab_label#set_text (Filename.basename f);
-				     flash_info "Saved"
-				   end
-				 else flash_info "Save Failed"
-			 end
-		     | Some f ->
-			 begin match select_file_for_save
-			     ~dir:(ref (Filename.dirname f))
-			     ~filename:(Filename.basename f)
-			     ~title:"Save file as" ()
-			   with
-			     | None -> ()
-			     | Some f ->
-				 if current.analyzed_view#save_as f then begin
-                                   current.tab_label#set_text (Filename.basename f);
-				     flash_info "Saved"
-				   end else flash_info "Save Failed"
-			 end);
-	      with e -> flash_info "Save Failed"
-	  in
-	    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 () =
-	      List.iter
-		(function
-		   | {script = view ; analyzed_view = av} ->
-		       begin match av#filename with
-			 | None -> ()
-			 | Some f ->
-			     ignore (av#save f)
-		       end
-		)  session_notebook#pages
-	    in
-            (* XXX *)
-	    let has_something_to_save () =
-	      List.exists
-		(function
-		   | {script=view} -> view#buffer#modified
-		)
-		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 () =
-		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
-				      then av#revert
-				| Some _, None -> av#revert
-				| _ -> ()
-			  with _ -> av#revert)
-		  ) 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 = !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 _ = file_factory#add_item "_Print..."
-	            ~key:GdkKeysyms._P
-                    ~callback:(fun () -> do_print session_notebook#current_term) in
-
-		  (* File/Export to Menu *)
-		  let export_f kind () =
-		    let v = session_notebook#current_term in
-		    let av = v.analyzed_view in
-		      match av#filename with
-			| None ->
-			    flash_info "Cannot print: this buffer has no name"
-			| Some f ->
-			    let basef = Filename.basename f in
-			    let output =
-			      let basef_we = try Filename.chop_extension basef with _ -> basef in
-				match kind with
-				  | "latex" -> basef_we ^ ".tex"
-				  | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
-				  | _ -> assert false
-			    in
-			    let cmd =
-			      local_cd f ^
-				!current.cmd_coqdoc ^ " --coqlib_path " ^
-				Envars.coqlib () ^ " --" ^ kind ^
-				" -o " ^ (Filename.quote output) ^ " " ^
-				(Filename.quote basef)
-			    in
-			    let s,_ = run_command av#insert_message cmd in
-			      flash_info (cmd ^
-					     if s = Unix.WEXITED 0
-					     then " succeeded"
-					     else " failed")
-		  in
-		  let 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")
-		  in
-		  let _ =
-		    file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex")
-		  in
-		  let _ =
-		    file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi")
-		  in
-		  let _ =
-		    file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf")
-		  in
-		  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 () ->
-				 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
-			match (GToolbox.question_box ~title:"Quit"
-				 ~buttons:["Save Named Buffers and Quit";
-					   "Quit without Saving";
-					   "Don't Quit"]
-				 ~default:0
-				 ~icon:
-				 (let img = GMisc.image () in
-				    img#set_stock `DIALOG_WARNING;
-				    img#set_icon_size `DIALOG;
-				    img#coerce)
-				 "There are unsaved buffers"
-			      )
-			with 1 -> saveall_f () ; exit 0
-			  | 2 -> exit 0
-			  | _ -> ()
-		      else exit 0
-		    in
-		    let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q
-		      ~callback:quit_f
-		    in
-		      ignore (w#event#connect#delete (fun _ -> quit_f (); true));
-
-		      (* Edit Menu *)
-		      let edit_menu = factory#add_submenu "_Edit" in
-		      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 (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 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_active_view_for_cp ())
-				    GtkText.View.S.cut_clipboard
-                                 ));
-			ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback:
-				 (fun () -> GtkSignal.emit_unit
-				    (get_active_view_for_cp ())
-				    GtkText.View.S.copy_clipboard));
-			ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback:
-				 (fun () ->
-				    try GtkSignal.emit_unit
-				      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"
-			  ~active:!current.auto_complete
-			  ~callback:
-			  in
-			*)
-			(*
-			  auto_complete :=
-			  (fun b -> match session_notebook#current_term.analyzed_view with
-			  | Some av -> av#set_auto_complete b
-			  | None -> ());
-			*)
-
-			let last_found = ref None in
-			let search_backward = ref false in
-			let find_w = GWindow.window
-			  (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
-			  (* ~allow_grow:true ~allow_shrink:true *)
-			  (* ~width:!current.window_width ~height:!current.window_height *)
+  let reset_auto_save_timer () =
+    disconnect_auto_save_timer ();
+    if !current.auto_save then
+      auto_save_timer := Some
+	(GMain.Timeout.add ~ms:!current.auto_save_delay
+	   ~callback:
+	   (fun () ->
+	     do_if_not_computing "autosave" (sync auto_save_f) session_notebook#pages;
+	     true))
+  in reset_auto_save_timer (); (* to enable statup preferences timer *)
+(* end Preferences *)
+  let do_or_activate f () =
+    do_if_not_computing "do_or_activate"
+      (fun current ->
+        let av = current.analyzed_view in
+        ignore (f av);
+        pop_info ();
+        let msg = match Coq.status !(current.toplvl) with
+        | Interface.Fail (l, str) ->
+          "Oops, problem while fetching coq status."
+        | Interface.Good status ->
+          let path = match status.Interface.status_path with
+          | None -> ""
+          | Some p -> " in " ^ p
+          in
+          let name = match status.Interface.status_proofname with
+          | None -> ""
+          | Some n -> ", proving " ^ n
+          in
+          "Ready" ^ path ^ name
+        in
+        push_info msg
+      )
+      [session_notebook#current_term]
+  in
+  let do_if_active f _ =
+    do_if_not_computing "do_if_active"
+      (fun sess -> ignore (f sess.analyzed_view))
+      [session_notebook#current_term] in
+  let match_callback _ =
+    let w = get_current_word () in
+    let cur_ct = !(session_notebook#current_term.toplvl) in
+    try
+      match Coq.mkcases cur_ct w with
+        | Interface.Fail _ -> raise Not_found
+        | Interface.Good cases ->
+          let print_branch c l =
+	    Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
+	      (print_list (fun c s -> Format.fprintf c "%s@ " s)) l
+          in
+          let b = Buffer.create 1024 in
+          let fmt = Format.formatter_of_buffer b in
+          Format.fprintf fmt "@[match var with@\n%aend@]@."
+            (print_list print_branch) cases;
+          let s = Buffer.contents b in
+          prerr_endline s;
+          let {script = view } = session_notebook#current_term in
+          ignore (view#buffer#delete_selection ());
+          let m = view#buffer#create_mark
+            (view#buffer#get_iter `INSERT)
+          in
+          if view#buffer#insert_interactive s then
+            let i = view#buffer#get_iter (`MARK m) in
+            let _ = i#nocopy#forward_chars 9 in
+            view#buffer#place_cursor ~where:i;
+            view#buffer#move_mark ~where:(i#backward_chars 3)
+              `SEL_BOUND
+    with Not_found -> flash_info "Not an inductive type"
+  in
+(* External command callback *)
+  let compile_f _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    save_f ();
+    match av#filename with
+      | None ->
+	flash_info "Active buffer has no name"
+      | Some f ->
+	let cmd = !current.cmd_coqc ^ " -I "
+	  ^ (Filename.quote (Filename.dirname f))
+	  ^ " " ^ (Filename.quote f) in
+	let s,res = run_command av#insert_message cmd in
+	if s = Unix.WEXITED 0 then
+	  flash_info (f ^ " successfully compiled")
+	else begin
+	  flash_info (f ^ " failed to compile");
+	  av#process_until_end_or_error;
+	  av#insert_message "Compilation output:\n";
+	  av#insert_message res
+	end
+  in
+  let make_f _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    match av#filename with
+      | None ->
+	flash_info "Cannot make: this buffer has no name"
+      | Some f ->
+	let cmd = local_cd f ^ !current.cmd_make in
+
+	(*
+	  save_f ();
+	*)
+	av#insert_message "Command output:\n";
+	let s,res = run_command av#insert_message cmd in
+	last_make := res;
+	last_make_index := 0;
+	flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+  in
+  let next_error _ =
+    try
+      let file,line,start,stop,error_msg = search_next_error () in
+      do_load file;
+      let v = session_notebook#current_term in
+      let av = v.analyzed_view in
+      let input_buffer = v.script#buffer in
+      (*
+	let init = input_buffer#start_iter in
+	let i = init#forward_lines (line-1) in
+      *)
+      (*
+	let convert_pos = byte_offset_to_char_offset phrase in
+	let start = convert_pos start in
+	let stop = convert_pos stop in
+      *)
+      (*
+	let starti = i#forward_chars start in
+	let stopi = i#forward_chars stop in
+      *)
+      let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
+      let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
+      input_buffer#apply_tag Tags.Script.error
+	~start:starti
+	~stop:stopi;
+      input_buffer#place_cursor ~where:starti;
+      av#set_message error_msg;
+      v.script#misc#grab_focus ()
+    with Not_found ->
+      last_make_index := 0;
+      let v = session_notebook#current_term in
+      let av = v.analyzed_view in
+      av#set_message "No more errors.\n"
+  in
+  let coq_makefile_f _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    match av#filename with
+      | None ->
+	flash_info "Cannot make makefile: this buffer has no name"
+      | Some f ->
+	let cmd = local_cd f ^ !current.cmd_coqmakefile in
+	let s,res = run_command av#insert_message cmd in
+	flash_info
+	  (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+  in
+
+  let file_actions = GAction.action_group ~name:"File" () in
+  let export_actions = GAction.action_group ~name:"Export" () in
+  let edit_actions = GAction.action_group ~name:"Edit" () in
+  let navigation_actions = GAction.action_group ~name:"Navigation" () in
+  let tactics_actions = GAction.action_group ~name:"Tactics" () in
+  let templates_actions = GAction.action_group ~name:"Templates" () in
+  let queries_actions = GAction.action_group ~name:"Queries" () in
+  let display_actions = GAction.action_group ~name:"Display" () in
+  let compile_actions = GAction.action_group ~name:"Compile" () in
+  let windows_actions = GAction.action_group ~name:"Windows" () in
+  let help_actions = GAction.action_group ~name:"Help" () in
+  let add_gen_actions menu_name act_grp l =
+    let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) in
+    let add_simple_template menu_name act_grp text =
+      let text' =
+	let l = String.length text - 1 in
+	if String.get text l = '.'
+	then text ^"\n"
+	else text ^" "
+      in
+      GAction.add_action (menu_name^" "^(no_under text)) ~label:text
+	~callback:(fun _ -> let {script = view } = session_notebook#current_term in
+			    ignore (view#buffer#insert_interactive text')) act_grp
+    in
+    List.iter (function
+      | [] -> ()
+      | [s] -> add_simple_template menu_name act_grp s
+      | s::_ as ll -> let label = "_@..." in label.[1] <- s.[0];
+		      GAction.add_action (menu_name^" "^(String.make 1 s.[0])) ~label act_grp;
+		      List.iter (add_simple_template menu_name act_grp) ll
+    ) l
+  in
+  let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s)
+    ~accel:(!current.modifier_for_tactics^sc)
+    ~callback:(do_if_active (fun a -> a#insert_command
+			       ("progress "^s^".\n") (s^".\n"))) in
+  let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel
+    ~callback:(fun _ -> let term = get_current_word () in
+		 session_notebook#current_term.command#new_command ~command:s ~term ())
+  in let add_complex_template (name, label, text, offset, len, key) =
+    (* Templates/Lemma *)
+    let callback _ =
+      let {script = view } = session_notebook#current_term in
+      if view#buffer#insert_interactive text then begin
+	let iter = view#buffer#get_iter_at_mark `INSERT in
+	ignore (iter#nocopy#backward_chars offset);
+	view#buffer#move_mark `INSERT ~where:iter;
+	ignore (iter#nocopy#backward_chars len);
+	view#buffer#move_mark `SEL_BOUND ~where:iter;
+      end in
+      match key with
+	|Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac)
+	|None -> GAction.add_action name ~label ~callback ?accel:None
+  in
+    GAction.add_actions file_actions [
+      GAction.add_action "File" ~label:"_File";
+      GAction.add_action "New" ~callback:new_f ~stock:`NEW;
+      GAction.add_action "Open" ~callback:load_f ~stock:`OPEN;
+      GAction.add_action "Save" ~callback:save_f ~stock:`SAVE ~tooltip:"Save current buffer";
+      GAction.add_action "Save as" ~label:"S_ave as" ~callback:saveas_f ~stock:`SAVE_AS;
+      GAction.add_action "Save all" ~label:"Sa_ve all" ~callback:(fun _ -> saveall_f ());
+      GAction.add_action "Revert all buffers" ~label:"_Revert all buffers" ~callback:(fun _ -> List.iter revert_f session_notebook#pages) ~stock:`REVERT_TO_SAVED;
+      GAction.add_action "Close buffer" ~label:"_Close buffer" ~callback:(fun _ -> remove_current_view_page ()) ~stock:`CLOSE ~tooltip:"Close current buffer";
+      GAction.add_action "Print..." ~label:"_Print..." ~callback:(fun _ -> do_print session_notebook#current_term) ~stock:`PRINT ~accel:"<Ctrl>p";
+      GAction.add_action "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l"
+	~callback:(fun _ -> force_retag
+                     session_notebook#current_term.script#buffer;
+		     session_notebook#current_term.analyzed_view#recenter_insert)
+	~stock:`REFRESH;
+      GAction.add_action "Quit" ~callback:quit_f ~stock:`QUIT;
+    ];
+    GAction.add_actions export_actions [
+      GAction.add_action "Export to" ~label:"E_xport to";
+      GAction.add_action "Html" ~label:"_Html" ~callback:(export_f "html");
+      GAction.add_action "Latex" ~label:"_LaTeX" ~callback:(export_f "latex");
+      GAction.add_action "Dvi" ~label:"_Dvi" ~callback:(export_f "dvi");
+      GAction.add_action "Pdf" ~label:"_Pdf" ~callback:(export_f "pdf");
+      GAction.add_action "Ps" ~label:"_Ps" ~callback:(export_f "ps");
+    ];
+    GAction.add_actions edit_actions [
+      GAction.add_action "Edit" ~label:"_Edit";
+      GAction.add_action "Undo" ~accel:"<Ctrl>u"
+	~callback:(fun _ -> do_if_not_computing "undo"
+		     (fun sess ->
+			ignore (sess.analyzed_view#without_auto_complete
+				  (fun () -> session_notebook#current_term.script#undo) ()))
+		     [session_notebook#current_term]) ~stock:`UNDO;
+      GAction.add_action "Clear Undo Stack" ~label:"_Clear Undo Stack"
+	~callback:(fun _ -> ignore session_notebook#current_term.script#clear_undo);
+      GAction.add_action "Cut" ~callback:(fun _ -> GtkSignal.emit_unit
+					    (get_active_view_for_cp ())
+					    ~sgn:GtkText.View.S.cut_clipboard
+					 ) ~stock:`CUT;
+      GAction.add_action "Copy" ~callback:(fun _ -> GtkSignal.emit_unit
+             (get_active_view_for_cp ())
+             ~sgn:GtkText.View.S.copy_clipboard) ~stock:`COPY;
+      GAction.add_action "Paste" ~callback:(fun _ ->
+             try GtkSignal.emit_unit
+                   session_notebook#current_term.script#as_view
+                   ~sgn:GtkText.View.S.paste_clipboard
+             with _ -> prerr_endline "EMIT PASTE FAILED") ~stock:`PASTE;
+      GAction.add_action "Find in buffer" ~label:"_Find in buffer" ~callback:(fun _ -> find_f ~backward:false ()) ~stock:`FIND;
+      GAction.add_action "Find backwards" ~label:"Find _backwards" ~callback:(fun _ -> find_f ~backward:true ()) ~accel:"<Ctrl>b";
+      GAction.add_action "Complete Word" ~label:"Complete Word" ~callback:(fun _ ->
+	     ignore (
+	       let av = session_notebook#current_term.analyzed_view in
+	       av#complete_at_offset (av#get_insert)#offset
+	     )) ~accel:"<Ctrl>slash";
+      GAction.add_action "External editor" ~label:"External editor" ~callback:(fun _ ->
+	let av = session_notebook#current_term.analyzed_view in
+	match av#filename with
+	  | None -> warning "Call to external editor available only on named files"
+	  | Some f ->
+	    save_f ();
+	    let com = Minilib.subst_command_placeholder !current.cmd_editor (Filename.quote f) in
+	    let _ = run_command av#insert_message com in
+	    av#revert) ~stock:`EDIT;
+      GAction.add_action "Preferences" ~callback:(fun _ ->
+	begin
+	  try configure ~apply:update_notebook_pos ()
+	  with _ -> flash_info "Cannot save preferences"
+	end;
+	reset_revert_timer ()) ~stock:`PREFERENCES;
+      (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ];
+    GAction.add_actions navigation_actions [
+      GAction.add_action "Navigation" ~label:"_Navigation";
+      GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN
+	~callback:(fun _ -> do_or_activate (fun a -> a#process_next_phrase true) ())
+	~tooltip:"Forward one command" ~accel:(!current.modifier_for_navigation^"Down");
+      GAction.add_action "Backward" ~label:"_Backward" ~stock:`GO_UP
+	~callback:(fun _ -> do_or_activate (fun a -> a#undo_last_step) ())
+	~tooltip:"Backward one command" ~accel:(!current.modifier_for_navigation^"Up");
+      GAction.add_action "Go to" ~label:"_Go to" ~stock:`JUMP_TO
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_insert) ())
+	~tooltip:"Go to cursor" ~accel:(!current.modifier_for_navigation^"Right");
+      GAction.add_action "Start" ~label:"_Start" ~stock:`GOTO_TOP
+	~callback:(fun _ -> force_reset_initial ())
+	~tooltip:"Restart coq" ~accel:(!current.modifier_for_navigation^"Home");
+      GAction.add_action "End" ~label:"_End" ~stock:`GOTO_BOTTOM
+	~callback:(fun _ -> do_or_activate (fun a -> a#process_until_end_or_error) ())
+	~tooltip:"Go to end" ~accel:(!current.modifier_for_navigation^"End");
+      GAction.add_action "Interrupt" ~label:"_Interrupt" ~stock:`STOP
+	~callback:(fun _ -> break ()) ~tooltip:"Interrupt computations"
+	~accel:(!current.modifier_for_navigation^"Break");
+      GAction.add_action "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
+	~callback:(fun _ -> let sess = session_notebook#current_term in
+		     toggle_proof_visibility sess.script#buffer
+		       sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
+	~accel:(!current.modifier_for_navigation^"h");
+      GAction.add_action "Previous" ~label:"_Previous" ~stock:`GO_BACK
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_prev_occ_of_cur_word) ())
+	~tooltip:"Previous occurence" ~accel:(!current.modifier_for_navigation^"less");
+      GAction.add_action "Next" ~label:"_Next" ~stock:`GO_FORWARD
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_next_occ_of_cur_word) ())
+	~tooltip:"Next occurence" ~accel:(!current.modifier_for_navigation^"greater");
+    ];
+    GAction.add_actions tactics_actions [
+      GAction.add_action "Try Tactics" ~label:"_Try Tactics";
+      GAction.add_action "Wizard" ~tooltip:"Proof Wizard" ~label:"<Proof Wizard>"
+	~stock:`DIALOG_INFO ~callback:(do_if_active (fun a -> a#tactic_wizard
+						       !current.automatic_tactics))
+	~accel:(!current.modifier_for_tactics^"dollar");
+      tactic_shortcut "auto" "a";
+      tactic_shortcut "auto with *" "asterisk";
+      tactic_shortcut "eauto" "e";
+      tactic_shortcut "eauto with *" "ampersand";
+      tactic_shortcut "intuition" "i";
+      tactic_shortcut "omega" "o";
+      tactic_shortcut "simpl" "s";
+      tactic_shortcut "tauto" "p";
+      tactic_shortcut "trivial" "v";
+    ];
+    add_gen_actions "Tactic" tactics_actions Coq_commands.tactics;
+    GAction.add_actions templates_actions [
+      GAction.add_action "Templates" ~label:"Te_mplates";
+      add_complex_template
+	("Lemma", "_Lemma __", "Lemma new_lemma : .\nIdeproof.\n\nSave.\n",
+	 19, 9, Some "L");
+      add_complex_template
+	("Theorem", "_Theorem __", "Theorem new_theorem : .\nIdeproof.\n\nSave.\n",
+	 19, 11, Some "T");
+      add_complex_template
+	("Definition", "_Definition __", "Definition ident := .\n",
+	 6, 5, Some "D");
+      add_complex_template
+	("Inductive", "_Inductive __", "Inductive ident : :=\n  | : .\n",
+	 14, 5, Some "I");
+      add_complex_template
+	("Fixpoint", "_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
+	 29, 5, Some "F");
+      add_complex_template ("Scheme", "_Scheme __",
+			    "Scheme new_scheme := Induction for _ Sort _\
+\nwith _ := Induction for _ Sort _.\n",61,10, Some "S");
+      GAction.add_action "match" ~label:"match ..." ~callback:match_callback
+	~accel:(!current.modifier_for_templates^"C");
+    ];
+    add_gen_actions "Template" templates_actions Coq_commands.commands;
+    GAction.add_actions queries_actions [
+      GAction.add_action "Queries" ~label:"_Queries";
+      query_shortcut "SearchAbout" (Some "F2");
+      query_shortcut "Check" (Some "F3");
+      query_shortcut "Print" (Some "F4");
+      query_shortcut "About" (Some "F5");
+      query_shortcut "Locate" None;
+      query_shortcut "Whelp Locate" None;
+    ];
+    GAction.add_action "Display" ~label:"_Display" display_actions;
+    List.iter
+      (fun (opts,name,label,key,dflt) ->
+         GAction.add_toggle_action name ~active:dflt ~label
+	   ~accel:(!current.modifier_for_display^key)
+          ~callback:(fun v -> do_or_activate (fun a ->
+            let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
+            a#show_goals) ()) display_actions)
+      print_items;
+    GAction.add_actions compile_actions [
+      GAction.add_action "Compile" ~label:"_Compile";
+      GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f;
+      GAction.add_action "Make" ~label:"_Make" ~callback:make_f ~accel:"F6";
+      GAction.add_action "Next error" ~label:"_Next error" ~callback:next_error
+	~accel:"F7";
+      GAction.add_action "Make makefile" ~label:"Make makefile" ~callback:coq_makefile_f;
+    ];
+    GAction.add_actions windows_actions [
+      GAction.add_action "Windows" ~label:"_Windows";
+      GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane"
+	~callback:(fun _ -> let ccw = session_notebook#current_term.command in
+		     if ccw#frame#misc#visible
+		     then ccw#frame#misc#hide ()
+		     else ccw#frame#misc#show ())
+	~accel:"Escape";
+      GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar"
+	~active:(!current.show_toolbar) ~callback:
+	(fun _ -> !current.show_toolbar <- not !current.show_toolbar;
+	   !show_toolbar !current.show_toolbar);
+      GAction.add_action "Detach View" ~label:"Detach _View"
+	~callback:(fun _ -> do_if_not_computing "detach view"
+		     (function {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:"CoqIde search/replace" ()
-			in
-			let find_box = GPack.table
-			  ~columns:3 ~rows:5
-			  ~col_spacings:10 ~row_spacings:10 ~border_width:10
-			  ~homogeneous:false ~packing:find_w#add () in
-
-			let _ =
-			  GMisc.label ~text:"Find:"
-			    ~xalign:1.0
-			    ~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)
+			  ~title:(match av#filename with
+				    | None -> "*Unnamed*"
+				    | Some f -> f)
 			  ()
 			in
-			let _ =
-			  GMisc.label ~text:"Replace with:"
-			    ~xalign:1.0
-			    ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) ()
+			let sb = GBin.scrolled_window
+			  ~packing:w#add ()
 			in
-			let replace_entry = GEdit.entry
-			  ~editable: true
-			  ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
+			let nv = GText.view
+			  ~buffer:v#buffer
+			  ~packing:sb#add
 			  ()
 			in
-			(* let _ =
-			  GButton.check_button
-			    ~label:"case sensitive"
-			    ~active:true
-			    ~packing: (find_box#attach ~left:1 ~top:2)
-			    ()
-
-                        in
-			*)
-			  (*
-			    let find_backwards_check =
-			    GButton.check_button
-			    ~label:"search backwards"
-			    ~active:false
-			    ~packing: (find_box#attach ~left:1 ~top:3)
-			    ()
-			    in
-			  *)
-			let close_find_button =
-			  GButton.button
-			    ~label:"Close"
-			    ~packing: (find_box#attach ~left:2 ~top:0)
-			    ()
-			in
-			let replace_button =
-			  GButton.button
-			    ~label:"Replace"
-			    ~packing: (find_box#attach ~left:2 ~top:1)
-			    ()
-			in
-			let replace_find_button =
-			  GButton.button
-			    ~label:"Replace and find"
-			    ~packing: (find_box#attach ~left:2 ~top:2)
-			    ()
-			in
-			let find_again_button =
-			  GButton.button
-			    ~label:"_Find again"
-			    ~packing: (find_box#attach ~left:2 ~top:3)
-			    ()
-			in
-			let find_again_backward_button =
-			  GButton.button
-			    ~label:"Find _backward"
-			    ~packing: (find_box#attach ~left:2 ~top:4)
-			    ()
-			in
-			let last_find () =
-			  let v = session_notebook#current_term.script in
-			  let b = v#buffer in
-			  let start,stop =
-			    match !last_found with
-			      | None -> let i = b#get_iter_at_mark `INSERT in (i,i)
-			      | Some(start,stop) ->
-				  let start = b#get_iter_at_mark start
-				  and stop = b#get_iter_at_mark stop
-				  in
-				    b#remove_tag Tags.Script.found ~start ~stop;
-				    last_found:=None;
-				    start,stop
-			  in
-			    (v,b,start,stop)
-			in
-			let do_replace () =
-			  let v = session_notebook#current_term.script in
-			  let b = v#buffer in
-			    match !last_found with
-			      | None -> ()
-			      | Some(start,stop) ->
-				  let start = b#get_iter_at_mark start
-				  and stop = b#get_iter_at_mark stop
-				  in
-				    b#delete ~start ~stop;
-				    b#insert ~iter:start replace_entry#text;
-				    last_found:=None
-			in
-			let find_from (v : Undo.undoable_view)
-			    (b : GText.buffer) (starti : GText.iter) text =
-			  prerr_endline ("Searching for " ^ text);
-			  match (if !search_backward then starti#backward_search text
-				 else starti#forward_search text)
-			  with
-			    | None -> ()
-			    | Some(start,stop) ->
-				b#apply_tag Tags.Script.found ~start ~stop;
-				let start = `MARK (b#create_mark start)
-				and stop = `MARK (b#create_mark stop)
-				in
-				  v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
-				    stop;
-				  last_found := Some(start,stop)
-			in
-			let do_find () =
-			  let (v,b,starti,_) = last_find () in
-			    find_from v b starti find_entry#text
-			in
-			let do_replace_find () =
-			  do_replace();
-			  do_find()
-			in
-			let close_find () =
-			  let (v,b,_,stop) = last_find () in
-			    b#place_cursor stop;
-			    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;
-			  let find_again_forward () =
-			    search_backward := false;
-			    let (v,b,start,_) = last_find () in
-			    let start = start#forward_chars 1 in
-			      find_from v b start find_entry#text
-			  in
-			  let find_again_backward () =
-			    search_backward := true;
-			    let (v,b,start,_) = last_find () in
-			    let start = start#backward_chars 1 in
-			      find_from v b start find_entry#text
-			  in
-			  let key_find ev =
-			    let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
-			      if k = GdkKeysyms._Escape then
-				begin
-				  let (v,b,_,stop) = last_find () in
-				    find_w#misc#hide();
-				    v#coerce#misc#grab_focus();
-				    true
-				end
-			      else if k = GdkKeysyms._Return then
-				begin
-				  close_find();
-				  true
-				end
-			      else if List.mem `CONTROL s && k = GdkKeysyms._f then
-				begin
-				  find_again_forward ();
-				  true
-				end
-			      else if List.mem `CONTROL s && k = GdkKeysyms._b then
-				begin
-				  find_again_backward ();
-				  true
-				end
-			      else false (* to let default callback execute *)
-			  in
-			  let find_f ~backward () =
-			    search_backward := backward;
-			    find_w#show ();
-			    find_w#present ();
-			    find_entry#misc#grab_focus ()
-			  in
-			  let _ = edit_f#add_item "_Find in buffer"
-			    ~key:GdkKeysyms._F
-			    ~callback:(find_f ~backward:false)
-			  in
-			  let _ = edit_f#add_item "Find _backwards"
-			    ~key:GdkKeysyms._B
-			    ~callback:(find_f ~backward:true)
-			  in
-			  let _ = close_find_button#connect#clicked close_find in
-			  let _ = replace_button#connect#clicked do_replace in
-			  let _ = replace_find_button#connect#clicked do_replace_find in
-			  let _ = find_again_button#connect#clicked find_again_forward in
-			  let _ = find_again_backward_button#connect#clicked find_again_backward in
-			  let _ = find_entry#connect#changed do_find in
-			  let _ = find_entry#event#connect#key_press ~callback:key_find in
-			  let _ = find_w#event#connect#delete (fun _ -> find_w#misc#hide(); true) in
-			    (*
-			      let search_if = edit_f#add_item "Search _forward"
-			      ~key:GdkKeysyms._greater
-			      in
-			      let search_ib = edit_f#add_item "Search _backward"
-			      ~key:GdkKeysyms._less
-			      in
-			    *)
-			    (*
-			      let complete_i = edit_f#add_item "_Complete"
-			      ~key:GdkKeysyms._comma
-			      ~callback:
-			      (do_if_not_computing
-			      (fun b ->
-			      let v = session_notebook#current_term.analyzed_view
-
-			      in v#complete_at_offset
-			      ((v#view#buffer#get_iter `SEL_BOUND)#offset)
-			      ))
-			      in
-			      complete_i#misc#set_state `INSENSITIVE;
-			    *)
-
-			    ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback:
-				     (fun () ->
-					ignore (
-						 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 _ =
-			      edit_f#add_item "External editor" ~callback:
-				(fun () ->
-				   let av = session_notebook#current_term.analyzed_view in
-				     match av#filename with
-				       | None -> warning "Call to external editor available only on named files"
-				       | Some f ->
-					   save_f ();
-					   let com = Flags.subst_command_placeholder !current.cmd_editor (Filename.quote f) in
-					   let _ = run_command av#insert_message com in
-					     av#revert)
-			    in
-			    let _ = edit_f#add_separator () in
-			      (* Preferences *)
-			    let reset_revert_timer () =
-			      disconnect_revert_timer ();
-			      if !current.global_auto_revert then
-				revert_timer := Some
-				  (GMain.Timeout.add ~ms:!current.global_auto_revert_delay
-				     ~callback:
-				     (fun () ->
-					do_if_not_computing "revert" (sync revert_f) ();
-					true))
-			    in reset_revert_timer (); (* to enable statup preferences timer *)
-                              (* XXX *)
-			      let auto_save_f () =
-				List.iter
-				  (function
-				       {script = view ; analyzed_view = av} ->
-					 (try
-					      av#auto_save
-					  with _ -> ())
-				  )
-				  session_notebook#pages
-			      in
-
-			      let reset_auto_save_timer () =
-				disconnect_auto_save_timer ();
-				if !current.auto_save then
-				  auto_save_timer := Some
-				    (GMain.Timeout.add ~ms:!current.auto_save_delay
-				       ~callback:
-				       (fun () ->
-					  do_if_not_computing "autosave" (sync auto_save_f) ();
-					  true))
-			      in reset_auto_save_timer (); (* to enable statup preferences timer *)
-
-
-				let _ =
-				  edit_f#add_item "_Preferences"
-				    ~callback:(fun () -> configure ~apply:update_notebook_pos (); reset_revert_timer ())
-				in
-				  (*
-				    let save_prefs_m =
-				    configuration_factory#add_item "_Save preferences"
-				    ~callback:(fun () -> save_pref ())
-				    in
-				  *)
-				  (* Navigation Menu *)
-				let navigation_menu =  factory#add_submenu "_Navigation" in
-				let navigation_factory =
-				  new GMenu.factory navigation_menu
-				    ~accel_path:"<CoqIde MenuBar>/Navigation/"
-				    ~accel_group
-				    ~accel_modi:!current.modifier_for_navigation
-				in
-				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)
-                                    end else
-				      begin
-					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 =
-				  do_if_not_computing "do_or_activate"
-				    (_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 =
-				  begin
-				    match key with None -> ()
-				      | Some key -> ignore (navigation_factory#add_item text ~key ~callback)
-				  end;
-				  ignore (toolbar#insert_button
-					    ~tooltip
-(*					    ~text:tooltip*)
-					    ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR icon)
-					    ~callback
-					    ())
-				in
-				  add_to_menu_toolbar
-				    "_Save"
-				    ~tooltip:"Save current buffer"
-				    ~callback:save_f
-				    `SAVE;
-				  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 ))
-
-				    `GO_DOWN;
-				  add_to_menu_toolbar "_Backward"
-				    ~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"
-				    ~key:GdkKeysyms._Right
-				    ~callback:(do_or_activate (fun a-> a#go_to_insert))
-				    `JUMP_TO;
-				  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"
-				    ~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
-				    ~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
-				      ~accel_path:"<CoqIde MenuBar>/Tactics/"
-				      ~accel_group
-				      ~accel_modi:!current.modifier_for_tactics
-				  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
-
-				    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
-									 "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
-									 "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"
-									 "eauto with *.\n"))
-					   );
-				    ignore (tactics_factory#add_item "_intuition"
-					      ~key:GdkKeysyms._i
-					      ~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
-									 "omega.\n" "omega.\n"))
-					   );
-				    ignore (tactics_factory#add_item "_simpl"
-					      ~key:GdkKeysyms._s
-					      ~callback:(do_if_active (fun a -> a#insert_command "progress simpl.\n" "simpl.\n" ))
-					   );
-				    ignore (tactics_factory#add_item "_tauto"
-					      ~key:GdkKeysyms._p
-					      ~callback:(do_if_active (fun a -> a#insert_command "tauto.\n" "tauto.\n" ))
-					   );
-				    ignore (tactics_factory#add_item "_trivial"
-					      ~key:GdkKeysyms._v
-					      ~callback:(do_if_active( fun a -> a#insert_command "progress trivial.\n"  "trivial.\n" ))
-					   );
-
-
-				    ignore (toolbar#insert_button
-					      ~tooltip:"Proof Wizard"
-					      ~text:"Wizard"
-					      ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR `DIALOG_INFO)
-					      ~callback:(do_if_active (fun a -> a#tactic_wizard
-									 !current.automatic_tactics
-								      ))
-					      ());
-
-
-
-				    ignore (tactics_factory#add_item "<Proof _Wizard>"
-					      ~key:GdkKeysyms._dollar
-					      ~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)
-					(menu_text, text) =
-				      let text =
-					let l = String.length text - 1 in
-					  if String.get text l = '.'
-					  then text ^"\n"
-					  else text ^" "
-				      in
-					ignore (factory#add_item menu_text
-						  ~callback:
-						  (fun () -> let {script = view } = session_notebook#current_term in
-							       ignore (view#buffer#insert_interactive text)))
-				    in
-				      List.iter
-					(fun l ->
-					   match l with
-					     | [] -> ()
-					     | [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 ff = new GMenu.factory f ~accel_group in
-						     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.tactics;
-
-				      (* Templates Menu *)
-				      let templates_menu =  factory#add_submenu "Te_mplates" in
-				      let templates_factory = new GMenu.factory templates_menu
-					~accel_path:"<CoqIde MenuBar>/Templates/"
-					~accel_group
-					~accel_modi:!current.modifier_for_templates
-				      in
-				      let add_complex_template (menu_text, text, offset, len, key) =
-					(* Templates/Lemma *)
-					let callback () =
-					  let {script = view } = session_notebook#current_term in
-					    if view#buffer#insert_interactive text then begin
-						let iter = view#buffer#get_iter_at_mark `INSERT in
-						  ignore (iter#nocopy#backward_chars offset);
-						  view#buffer#move_mark `INSERT iter;
-						  ignore (iter#nocopy#backward_chars len);
-						  view#buffer#move_mark `SEL_BOUND iter;
-					      end in
-					  ignore (templates_factory#add_item menu_text ~callback ?key)
-				      in
-					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",
-					   19, 11, Some GdkKeysyms._T);
-					add_complex_template
-					  ("_Definition __", "Definition ident := .\n",
-					   6, 5, Some GdkKeysyms._D);
-					add_complex_template
-					  ("_Inductive __", "Inductive ident : :=\n  | : .\n",
-					   14, 5, Some GdkKeysyms._I);
-					add_complex_template
-					  ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
-					   29, 5, Some GdkKeysyms._F);
-					add_complex_template("_Scheme __",
-							     "Scheme new_scheme := Induction for _ Sort _
-with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
-
-					(* Template for match *)
-					let callback () =
-					  let w = get_current_word () in
-					    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
-						    (print_list (fun c s -> Format.fprintf c " %s" s)) l
-						| [] -> assert false
-					      in
-					      let b = Buffer.create 1024 in
-					      let fmt = Format.formatter_of_buffer b in
-						Format.fprintf fmt "@[match var with@\n%aend@]@."
-						  (print_list print) cases;
-						let s = Buffer.contents b in
-						  prerr_endline s;
-						  let {script = view } = session_notebook#current_term in
-						    ignore (view#buffer#delete_selection ());
-						    let m = view#buffer#create_mark
-						      (view#buffer#get_iter `INSERT)
-						    in
-						      if view#buffer#insert_interactive s then
-							let i = view#buffer#get_iter (`MARK m) in
-							let _ = i#nocopy#forward_chars 9 in
-							  view#buffer#place_cursor i;
-							  view#buffer#move_mark ~where:(i#backward_chars 3)
-							    `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)
-					    (menu_text, text) =
-					    let text =
-					    let l = String.length text - 1 in
-					    if String.get text l = '.'
-					    then text ^"\n"
-					    else text ^" "
-					    in
-					    ignore (factory#add_item menu_text
-					    ~callback:
-					    (fun () -> let {view = view } = session_notebook#current_term in
-					    ignore (view#buffer#insert_interactive text)))
-					    in
-					  *)
-					  ignore (templates_factory#add_separator ());
-					  (*
-					    List.iter (add_simple_template templates_factory)
-					    [ "_auto", "auto ";
-					    "_auto with *", "auto with * ";
-					    "_eauto", "eauto ";
-					    "_eauto with *", "eauto with * ";
-					    "_intuition", "intuition ";
-					    "_omega", "omega ";
-					    "_simpl", "simpl ";
-					    "_tauto", "tauto ";
-					    "tri_vial", "trivial ";
-					    ];
-					    ignore (templates_factory#add_separator ());
-					  *)
-					  List.iter
-					    (fun l ->
-					       match l with
-						 | [] -> ()
-						 | [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 ff = new GMenu.factory f ~accel_group in
-							 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 _ =
-					    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
-								       ())
-					  in
-					  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
-								       ())
-					  in
-					  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
-								       ())
-					  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"
-					      ~callback:(fun () -> let term = get_current_word () in
-								     (Command_windows.command_window ())#new_command
-								       ~command:"Locate"
-								       ~term
-								       ())
-					  in
-					  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
-								       ())
-					  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_modi:!current.modifier_for_display
-					  in
-
-					  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
-							    "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
-
-					  let _ = ignore (view_factory#add_check_item
-							    "Display raw _matching expressions"
-							    ~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
-							    "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
-							    "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
-
-					  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
-							    "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
-							    "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
-
-
-
-					  (* Externals *)
-					  let externals_menu =  factory#add_submenu "_Compile" in
-					  let externals_factory = new GMenu.factory externals_menu
-					    ~accel_path:"<CoqIde MenuBar>/Compile/"
-					    ~accel_group
-					    ~accel_modi:[]
-					  in
-
-					  (* Command/Compile Menu *)
-					  let compile_f () =
-					    let v = session_notebook#current_term in
-					    let av = v.analyzed_view in
-					      save_f ();
-					      match av#filename with
-						| None ->
-						    flash_info "Active buffer has no name"
-						| Some f ->
-						    let cmd = !current.cmd_coqc ^ " -I "
-						      ^ (Filename.quote (Filename.dirname f))
-						      ^ " " ^ (Filename.quote f) in
-						    let s,res = run_command av#insert_message cmd in
-						      if s = Unix.WEXITED 0 then
-							flash_info (f ^ " successfully compiled")
-						      else begin
-							  flash_info (f ^ " failed to compile");
-							  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
-					  in
-
-					  (* Command/Make Menu *)
-					  let make_f () =
-					    let v = session_notebook#current_term in
-					    let av = v.analyzed_view in
-					      match av#filename with
-						| None ->
-						    flash_info "Cannot make: this buffer has no name"
-						| Some f ->
-						    let cmd =
-						      local_cd f ^ !current.cmd_make in
-
-						      (*
-							save_f ();
-						      *)
-						      av#insert_message "Command output:\n";
-						      let s,res = run_command av#insert_message cmd in
-							last_make := res;
-							last_make_index := 0;
-							flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
-					  in
-					  let _ = externals_factory#add_item "_Make"
-					    ~key:GdkKeysyms._F6
-					    ~callback:make_f
-					  in
-
-
-					  (* Compile/Next Error *)
-					  let next_error () =
-					    try
-					      let file,line,start,stop,error_msg = search_next_error () 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
-						  *)
-						  (*
-						    let convert_pos = byte_offset_to_char_offset phrase in
-						    let start = convert_pos start in
-						    let stop = convert_pos stop in
-						  *)
-						  (*
-						    let starti = i#forward_chars start in
-						    let stopi = i#forward_chars stop in
-						  *)
-						let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
-						let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
-						  input_buffer#apply_tag Tags.Script.error
-   						    ~start:starti
-						    ~stop:stopi;
-						  input_buffer#place_cursor starti;
-						  av#set_message error_msg;
-						  v.script#misc#grab_focus ()
-					    with Not_found ->
-					      last_make_index := 0;
-					      let v = session_notebook#current_term in
-					      let av = v.analyzed_view in
-						av#set_message "No more errors.\n"
-					  in
-					  let _ =
-					    externals_factory#add_item "_Next error"
-					      ~key:GdkKeysyms._F7
-					      ~callback:next_error in
-
-
-					  (* Command/CoqMakefile Menu*)
-					  let coq_makefile_f () =
-					    let v = session_notebook#current_term in
-					    let av = v.analyzed_view in
-					      match av#filename with
-						| None ->
-						    flash_info "Cannot make makefile: this buffer has no name"
-						| Some f ->
-						    let cmd =
-						      local_cd f ^ !current.cmd_coqmakefile in
-						    let s,res = run_command av#insert_message cmd in
-						      flash_info
-							(!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
-					  in
-					  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
-					    ~accel_path:"<CoqIde MenuBar>/Windows"
-					    ~accel_modi:[]
-					    ~accel_group
-					  in
-					  let _ =
-					    configuration_factory#add_item
-					      "Show/Hide _Query Pane"
-					      ~key:GdkKeysyms._Escape
-					      ~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 _View"
-					      ~callback:
-					      (do_if_not_computing "detach view"
-						 (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)
-							    ()
-							  in
-							  let sb = GBin.scrolled_window
-							    ~packing:w#add ()
-							  in
-							  let nv = GText.view
-							    ~buffer:v#buffer
-							    ~packing:sb#add
-							    ()
-							  in
-							    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
-					    ~accel_path:"<CoqIde MenuBar>/Help/"
-					    ~accel_modi:[]
-					    ~accel_group in
-					  let _ = help_factory#add_item "Browse Coq _Manual"
-					    ~callback:
-					    (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 = session_notebook#current_term.analyzed_view in
-						 browse av#insert_message !current.library_url) in
-					  let _ =
-					    help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1
-					      ~callback:(fun () ->
-							   let av = session_notebook#current_term.analyzed_view in
-							     av#help_for_keyword ())
-					  in
-					  let _ = help_factory#add_separator () 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
-					    queries_pane#pack1 ~shrink:false ~resize:true session_notebook#coerce;
-                                            update_notebook_pos ();
-					    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
-					    lower_hbox#pack ~expand:true status#coerce;
-					    let search_lbl = GMisc.label ~text:"Search:"
-					      ~show: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) ()
-					    in
-					      search_input#disable_activate ();
-					      let ready_to_wrap_search = ref false in
-
-					      let start_of_search = ref None in
-					      let start_of_found = ref None in
-					      let end_of_found = ref None in
-					      let search_forward = ref true in
-					      let matched_word = ref None in
-
-					      let memo_search () =
-						matched_word := Some search_input#entry#text
-					      in
-					      let end_search () =
-						prerr_endline "End Search";
-						memo_search ();
-						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 () =
-						prerr_endline "End Search(focus out)";
-						memo_search ();
-						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
-							  ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
-										if
-										  kv = GdkKeysyms._Right
-										  || kv = GdkKeysyms._Up
-										  || kv = GdkKeysyms._Left
-										  || (kv = GdkKeysyms._g
-										      && (List.mem `CONTROL (GdkEvent.Key.state k)))
-										then end_search ();
-								       false));
-						ignore (search_input#entry#event#connect#focus_out
-							  ~callback:(fun _ -> end_search_focus_out (); false));
-						to_do_on_page_switch :=
-						  (fun i ->
-						     start_of_search := None;
-						     ready_to_wrap_search:=false)::!to_do_on_page_switch;
-
-						(* TODO : make it work !!! *)
-						let rec search_f () =
-						  search_lbl#misc#show ();
-						  search_input#misc#show ();
-
-						  prerr_endline "search_f called";
-						  if !start_of_search = None then begin
-						      (* A full new search is starting *)
-						      start_of_search :=
-							Some (session_notebook#current_term.script#buffer#create_mark
-								(session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT));
-						      start_of_found := !start_of_search;
-						      end_of_found := !start_of_search;
-						      matched_word := Some "";
-						    end;
-						  let txt = search_input#entry#text in
-						  let v = session_notebook#current_term.script in
-						  let iit = v#buffer#get_iter_at_mark `SEL_BOUND
-						  and insert_iter = v#buffer#get_iter_at_mark `INSERT
-						  in
-						    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
-						    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
-
-						    (match
-							 if !search_forward then iit#forward_search txt
-							 else let npi = iit#forward_chars (Glib.Utf8.length txt) in
-								match
-								  (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
-								  (let t = iit#get_text ~stop:npi in
-								     flash_info (t^"\n"^txt);
-								     t = txt)
-								with
-								  | true,true ->
-								      (flash_info "T,T";iit#backward_search txt)
-								  | false,true -> flash_info "F,T";Some (iit,npi)
-								  | _,false ->
-								      (iit#backward_search txt)
-
-						     with
-						       | None ->
-							   if !ready_to_wrap_search then begin
-							       ready_to_wrap_search := false;
-							       flash_info "Search wrapped";
-							       v#buffer#place_cursor
-								 (if !search_forward then v#buffer#start_iter else
-								      v#buffer#end_iter);
-							       search_f ()
-							     end else begin
-								 if !search_forward then flash_info "Search at end"
-								 else flash_info "Search at start";
-								 ready_to_wrap_search := true
-							       end
-						       | Some (start,stop) ->
-							   prerr_endline "search: before moving marks";
-							   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-							   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-
-							   v#buffer#move_mark `SEL_BOUND start;
-							   v#buffer#move_mark `INSERT stop;
-							   prerr_endline "search: after moving marks";
-							   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-							   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-							   v#scroll_to_mark `SEL_BOUND
-						    )
-						in
-						  ignore (search_input#entry#event#connect#key_release
-							    ~callback:
-							    (fun ev ->
-							       if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
-								   let v = session_notebook#current_term.script in
-								     (match !start_of_search with
-									| None ->
-									    prerr_endline "search_key_rel: Placing sel_bound";
-									    v#buffer#move_mark
-									      `SEL_BOUND
-									      (v#buffer#get_iter_at_mark `INSERT)
-									| Some mk -> let it = v#buffer#get_iter_at_mark
-									    (`MARK mk) in
-										       prerr_endline "search_key_rel: Placing cursor";
-									    v#buffer#place_cursor it;
-									    start_of_search := None
-								     );
-								     search_input#entry#set_text "";
-								     v#coerce#misc#grab_focus ();
-								 end;
-							       false
-							    ));
-						  ignore (search_input#entry#connect#changed search_f);
-						    push_info "Ready";
-                                                                 (* Location display *)
-						    let l = GMisc.label
-						      ~text:"Line:     1 Char:   1"
-						      ~packing:lower_hbox#pack () in
-						      l#coerce#misc#set_name "location";
-						      set_location := l#set_text;
-						      (* Progress Bar *)
-            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\
-       \n(INRIA - CNRS - University Paris 11 and partners)\
-       \nWeb site: " ^ Coq_config.wwwcoq ^
-       "\nFeature wish or bug report: http://coq.inria.fr/bugs\
-       \n\
-       \nCredits for CoqIDE, the Integrated Development Environment for Coq:\
-       \n\
-       \nMain author  : Benjamin Monate\
-       \nContributors : Jean-Christophe Filliâtre\
-       \n               Pierre Letouzey, Claude Marché\
-       \n               Bruno Barras, Pierre Corbineau\
-       \n               Julien Narboux, Hugo Herbelin, ... \
-       \n\
-       \nVersion information\
-       \n-------------------\
-       \n"
-							    in
-							    let initial_about (b:GText.buffer) =
-							      let initial_string = "Welcome to CoqIDE, an Integrated Development Environment for Coq\n" in
-							      let coq_version = Coq.short_version () in
-								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
-								    let image = lib_ide_file "coq.png" in
-								    let startup_image = GdkPixbuf.from_file image in
-								      b#insert ~iter:b#start_iter "\n\n";
-								      b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
-								      b#insert ~iter:b#start_iter "\n\n\t\t   "
-								  with _ -> ())
-							    in
-
-							    let about (b:GText.buffer) =
-							      (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";
-								    b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
-								    b#insert ~iter:b#start_iter "\n\n\t\t   "
-								with _ -> ());
-								if Glib.Utf8.validate about_full_string
-								then b#insert about_full_string;
-								let coq_version = Coq.version () in
-								  if Glib.Utf8.validate coq_version
-								  then b#insert coq_version
-
-							    in
-							      w#add_accel_group accel_group;
-							      (* Remove default pango menu for textviews *)
-							      w#show ();
-							      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));
-							      (*
-
-							      *)
-							      resize_window := (fun () ->
-										  w#resize
-										    ~width:!current.window_width
-										    ~height:!current.window_height);
- 						              ignore(nb#connect#switch_page
-								       ~callback:
-								       (fun i ->
-									  prerr_endline ("switch_page: starts " ^ string_of_int i);
-									  List.iter (function f -> f i) !to_do_on_page_switch;
-									  prerr_endline "switch_page: success")
-								    );
- 							      if List.length files >=1 then
-								begin
-								  List.iter (fun f ->
-									       if Sys.file_exists f then 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;
-								  activate_input 0
-								end
-							      else
-								begin
-								  let session = create_session () in
-								  let index = session_notebook#append_term session in
-								    activate_input index;
-								end;
-                                  initial_about session_notebook#current_term.proof_view#buffer;
-                                  !show_toolbar !current.show_toolbar;
-                                  session_notebook#current_term.script#misc#grab_focus ()
-
-;;
+			  nv#misc#modify_font
+			    !current.text_font;
+			  ignore (w#connect#destroy
+				    ~callback:
+				    (fun () -> av#remove_detached_view w));
+			  av#add_detached_view w)
+		     [session_notebook#current_term]);
+    ];
+    GAction.add_actions help_actions [
+      GAction.add_action "Help" ~label:"_Help";
+      GAction.add_action "Browse Coq Manual" ~label:"Browse Coq _Manual"
+	~callback:(fun _ ->
+		     let av = session_notebook#current_term.analyzed_view in
+		       browse av#insert_message (doc_url ()));
+      GAction.add_action "Browse Coq Library" ~label:"Browse Coq _Library"
+	~callback:(fun _ ->
+		     let av = session_notebook#current_term.analyzed_view in
+		       browse av#insert_message !current.library_url);
+      GAction.add_action "Help for keyword" ~label:"Help for _keyword"
+	~callback:(fun _ -> let av = session_notebook#current_term.analyzed_view in
+		     av#help_for_keyword ()) ~stock:`HELP;
+      GAction.add_action "About Coq" ~label:"_About" ~stock:`ABOUT;
+    ];
+    Coqide_ui.init ();
+    Coqide_ui.ui_m#insert_action_group file_actions 0;
+    Coqide_ui.ui_m#insert_action_group export_actions 0;
+    Coqide_ui.ui_m#insert_action_group edit_actions 0;
+    Coqide_ui.ui_m#insert_action_group navigation_actions 0;
+    Coqide_ui.ui_m#insert_action_group tactics_actions 0;
+    Coqide_ui.ui_m#insert_action_group templates_actions 0;
+    Coqide_ui.ui_m#insert_action_group queries_actions 0;
+    Coqide_ui.ui_m#insert_action_group display_actions 0;
+    Coqide_ui.ui_m#insert_action_group compile_actions 0;
+    Coqide_ui.ui_m#insert_action_group windows_actions 0;
+    Coqide_ui.ui_m#insert_action_group help_actions 0;
+    w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
+    if Coq_config.gtk_platform <> `QUARTZ
+    then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
+    let tbar = GtkButton.Toolbar.cast ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
+    in let () = GtkButton.Toolbar.set ~orientation:`HORIZONTAL ~style:`ICONS
+	~tooltips:true tbar in
+    let toolbar = new GObj.widget tbar in
+    vbox#pack toolbar;
+
+    show_toolbar :=
+      (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ());
+
+    ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true));
+
+  (* The vertical Separator between Scripts and Goals *)
+  vbox#pack ~expand:true session_notebook#coerce;
+  update_notebook_pos ();
+  let nb = session_notebook in
+  let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+  lower_hbox#pack ~expand:true status#coerce;
+  let search_lbl = GMisc.label ~text:"Search:"
+    ~show:false
+    ~packing:(lower_hbox#pack ~expand:false) ()
+  in
+  let search_history = ref [] in
+  let (search_input,_) = GEdit.combo_box_entry_text ~strings:!search_history ~show:false
+    ~packing:(lower_hbox#pack ~expand:false) ()
+  in
+  let ready_to_wrap_search = ref false in
+
+  let start_of_search = ref None in
+  let start_of_found = ref None in
+  let end_of_found = ref None in
+  let search_forward = ref true in
+  let matched_word = ref None in
+
+  let memo_search () =
+    matched_word := Some search_input#entry#text
+  in
+  let end_search () =
+    prerr_endline "End Search";
+    memo_search ();
+    let v = session_notebook#current_term.script in
+    v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
+    v#coerce#misc#grab_focus ();
+    search_input#entry#set_text "";
+    search_lbl#misc#hide ();
+    search_input#misc#hide ()
+  in
+  let end_search_focus_out () =
+    prerr_endline "End Search(focus out)";
+    memo_search ();
+    let v = session_notebook#current_term.script in
+    v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
+    search_input#entry#set_text "";
+    search_lbl#misc#hide ();
+    search_input#misc#hide ()
+  in
+  ignore (search_input#entry#connect#activate ~callback:end_search);
+  ignore (search_input#entry#event#connect#key_press
+	    ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
+				if
+				  kv = GdkKeysyms._Right
+				  || kv = GdkKeysyms._Up
+				    || kv = GdkKeysyms._Left
+				      || (kv = GdkKeysyms._g
+					 && (List.mem `CONTROL (GdkEvent.Key.state k)))
+				then end_search ();
+				false));
+  ignore (search_input#entry#event#connect#focus_out
+	    ~callback:(fun _ -> end_search_focus_out (); false));
+  to_do_on_page_switch :=
+    (fun i ->
+      start_of_search := None;
+      ready_to_wrap_search:=false)::!to_do_on_page_switch;
+
+  (* TODO : make it work !!! *)
+  let rec search_f () =
+    search_lbl#misc#show ();
+    search_input#misc#show ();
+
+    prerr_endline "search_f called";
+    if !start_of_search = None then begin
+      (* A full new search is starting *)
+      start_of_search :=
+	Some (session_notebook#current_term.script#buffer#create_mark
+		(session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT));
+      start_of_found := !start_of_search;
+      end_of_found := !start_of_search;
+      matched_word := Some "";
+    end;
+    let txt = search_input#entry#text in
+    let v = session_notebook#current_term.script in
+    let iit = v#buffer#get_iter_at_mark `SEL_BOUND
+    and insert_iter = v#buffer#get_iter_at_mark `INSERT
+    in
+    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
+    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
+
+    (match
+	if !search_forward then iit#forward_search txt
+	else let npi = iit#forward_chars (Glib.Utf8.length txt) in
+	     match
+	       (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
+	       (let t = iit#get_text ~stop:npi in
+		flash_info (t^"\n"^txt);
+		t = txt)
+	     with
+	       | true,true ->
+		 (flash_info "T,T";iit#backward_search txt)
+	       | false,true -> flash_info "F,T";Some (iit,npi)
+	       | _,false ->
+		 (iit#backward_search txt)
+
+     with
+       | None ->
+	 if !ready_to_wrap_search then begin
+	   ready_to_wrap_search := false;
+	   flash_info "Search wrapped";
+	   v#buffer#place_cursor
+	     ~where:(if !search_forward then v#buffer#start_iter else
+		 v#buffer#end_iter);
+	   search_f ()
+	 end else begin
+	   if !search_forward then flash_info "Search at end"
+	   else flash_info "Search at start";
+	   ready_to_wrap_search := true
+	 end
+       | Some (start,stop) ->
+	 prerr_endline "search: before moving marks";
+	 prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
+	 prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
+
+	 v#buffer#move_mark `SEL_BOUND ~where:start;
+	 v#buffer#move_mark `INSERT ~where:stop;
+	 prerr_endline "search: after moving marks";
+	 prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
+	 prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
+	 v#scroll_to_mark `SEL_BOUND
+    )
+  in
+  ignore (search_input#entry#event#connect#key_release
+	    ~callback:
+	    (fun ev ->
+	      if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
+		let v = session_notebook#current_term.script in
+		(match !start_of_search with
+		  | None ->
+		    prerr_endline "search_key_rel: Placing sel_bound";
+		    v#buffer#move_mark
+		      `SEL_BOUND
+		      ~where:(v#buffer#get_iter_at_mark `INSERT)
+		  | Some mk -> let it = v#buffer#get_iter_at_mark
+				 (`MARK mk) in
+			       prerr_endline "search_key_rel: Placing cursor";
+			       v#buffer#place_cursor ~where:it;
+			       start_of_search := None
+		);
+		search_input#entry#set_text "";
+		v#coerce#misc#grab_focus ();
+	      end;
+	      false
+	    ));
+  ignore (search_input#entry#connect#changed ~callback:search_f);
+  push_info "Ready";
+  (* Location display *)
+  let l = GMisc.label
+    ~text:"Line:     1 Char:   1"
+    ~packing:lower_hbox#pack () in
+  l#coerce#misc#set_name "location";
+  set_location := l#set_text;
+  (* Progress Bar *)
+  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\
+     \n(INRIA - CNRS - LIX - LRI - PPS)\
+     \nWeb site: " ^ Coq_config.wwwcoq ^
+    "\nFeature wish or bug report: http://coq.inria.fr/bugs/\
+     \n\
+     \nCredits for CoqIDE, the Integrated Development Environment for Coq:\
+     \n\
+     \nMain author  : Benjamin Monate\
+     \nContributors : Jean-Christophe Filliâtre\
+     \n               Pierre Letouzey, Claude Marché\
+     \n               Bruno Barras, Pierre Corbineau\
+     \n               Julien Narboux, Hugo Herbelin, ... \
+     \n\
+     \nVersion information\
+     \n-------------------\
+     \n"
+  in
+  let initial_about (b:GText.buffer) =
+    let initial_string =
+      "Welcome to CoqIDE, an Integrated Development Environment for Coq\n"
+    in
+    let coq_version = Coq.short_version () in
+    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
+       let image = Filename.concat (List.find
+	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
+	 Minilib.xdg_data_dirs) "coq.png" in
+       let startup_image = GdkPixbuf.from_file image in
+       b#insert ~iter:b#start_iter "\n\n";
+       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
+       b#insert ~iter:b#start_iter "\n\n\t\t   "
+     with _ -> ())
+  in
+
+  let about (b:GText.buffer) =
+    (try
+       let image = Filename.concat (List.find
+	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
+	 Minilib.xdg_data_dirs) "coq.png" in
+       let startup_image = GdkPixbuf.from_file image in
+       b#insert ~iter:b#start_iter "\n\n";
+       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
+       b#insert ~iter:b#start_iter "\n\n\t\t   "
+     with _ -> ());
+    if Glib.Utf8.validate about_full_string
+    then b#insert about_full_string;
+    let coq_version = Coq.version () in
+    if Glib.Utf8.validate coq_version
+    then b#insert coq_version
+
+  in
+  (* Remove default pango menu for textviews *)
+  w#show ();
+  ignore ((help_actions#get_action "About Coq")#connect#activate
+	    ~callback:(fun _ -> let prf_v = session_notebook#current_term.proof_view in
+                                 prf_v#buffer#set_text ""; about prf_v#buffer));
+  (*
+
+  *)
+  resize_window := (fun () ->
+    w#resize
+      ~width:!current.window_width
+      ~height:!current.window_height);
+  ignore(nb#connect#switch_page
+	   ~callback:
+	   (fun i ->
+	     prerr_endline ("switch_page: starts " ^ string_of_int i);
+	     List.iter (function f -> f i) !to_do_on_page_switch;
+	     prerr_endline "switch_page: success")
+  );
+  if List.length files >=1 then
+    begin
+      List.iter (fun f ->
+	if Sys.file_exists f then do_load f else
+          let f = if Filename.check_suffix f ".v" then f else f^".v" in
+	  load_file (fun s -> print_endline s; exit 1) f)
+        files;
+      session_notebook#goto_page 0;
+    end
+  else
+    begin
+      let session = create_session None in
+      let index = session_notebook#append_term session in
+      session_notebook#goto_page index;
+    end;
+  initial_about session_notebook#current_term.proof_view#buffer;
+  !show_toolbar !current.show_toolbar;
+  session_notebook#current_term.script#misc#grab_focus ();;
 
 (* This function check every half of second if GeoProof has send
    something on his private clipboard *)
 
 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 ->
-	       if s <> "Ack" then
-		 session_notebook#current_term.script#buffer#insert (s^"\n");
-	       cb_Dr#set_text "Ack"
-	   | None -> ()
-	);
-	(* cb_Dr#clear does not work so i use : *)
-	(* cb_Dr#set_text "Ack" *)
-    done
-
-
-let start () =
-  let files = Coq.init () in
-    ignore_break ();
-    GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc");
-    (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
-      (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);
-    ignore (
-	     Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL;
-								 `WARNING;`CRITICAL]
-	       (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 ();
-    init_stdout ();
-    main files;
-    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."
-	| e ->
-	    safe_prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e));
-	    flush_all ();
-	    crash_save 127
-    done
-
+  while true do
+    Thread.delay 0.1;
+    let s = cb_Dr#text in
+    (match s with
+	Some s ->
+	  if s <> "Ack" then
+	    session_notebook#current_term.script#buffer#insert (s^"\n");
+	  cb_Dr#set_text "Ack"
+      | None -> ()
+    );
+  (* cb_Dr#clear does not work so i use : *)
+  (* cb_Dr#set_text "Ack" *)
+  done
+
+(** By default, the coqtop we try to launch is exactly the current coqide
+    full name, with the last occurrence of "coqide" replaced by "coqtop".
+    This should correctly handle the ".opt", ".byte", ".exe" situations.
+    If the replacement fails, we default to "coqtop", hoping it's somewhere
+    in the path. Note that the -coqtop option to coqide allows to override
+    this default coqtop path *)
+
+let default_coqtop_path () =
+  let prog = Sys.executable_name in
+  try
+    let pos = String.length prog - 6 in
+    let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
+    String.blit "coqtop" 0 prog i 6;
+    prog
+  with _ -> "coqtop"
+
+let read_coqide_args argv =
+  let rec filter_coqtop coqtop project_files out = function
+    | "-coqtop" :: prog :: args ->
+      if coqtop = "" then filter_coqtop prog project_files out args
+      else
+	(output_string stderr "Error: multiple -coqtop options"; exit 1)
+    | "-f" :: file :: args ->
+	filter_coqtop coqtop
+	  ((Minilib.canonical_path_name (Filename.dirname file),
+	    Project_file.read_project_file file) :: project_files) out args
+    | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1
+    | arg::args -> filter_coqtop coqtop project_files (arg::out) args
+    | [] -> ((if coqtop = "" then default_coqtop_path () else coqtop),
+	     List.rev project_files,List.rev out)
+  in
+  let coqtop,project_files,argv = filter_coqtop "" [] [] argv in
+    Minilib.coqtop_path := coqtop;
+    custom_project_files := project_files;
+  argv
 
+let process_argv argv =
+  try
+    let continue,filtered = Coq.filter_coq_opts (List.tl argv) in
+    if not continue then
+      (List.iter Minilib.safe_prerr_endline filtered; exit 0);
+    let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in
+    if opts <> [] then
+      (Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1);
+    filtered
+  with _ ->
+    (Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1)
diff --git a/ide/coqide.mli b/ide/coqide.mli
index ea995c71..38b0fab0 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.mli
@@ -1,16 +1,40 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqide.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** * The CoqIde main module *)
 
-(* The CoqIde main module. The following function [start] will parse the
-   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. *)
+(** The arguments that will be passed to coqtop. No quoting here, since
+    no /bin/sh when using create_process instead of open_process. *)
+val sup_args : string list ref
 
-val start : unit -> unit
+(** Filter the argv from coqide specific options, and set
+    Minilib.coqtop_path accordingly *)
+val read_coqide_args : string list -> string list
+
+(** Ask coqtop the remaining options it doesn't recognize *)
+val process_argv : string list -> string list
+
+(** Prepare the widgets, load the given files in tabs *)
+val main : string list -> unit
+
+(** Function to save anything and kill all coqtops
+    @return [false] if you're allowed to quit. *)
+val forbid_quit_to_save : unit -> bool
+
+(** Function to load of a file. *)
+val do_load : string -> unit
+
+(** Set coqide to ignore Ctrl-C, while launching [crash_save] and
+    exiting for others received signals *)
+val ignore_break : unit -> unit
+
+(** Emergency saving of opened files as "foo.v.crashcoqide",
+    and exit (if the integer isn't 127). *)
+val crash_save : int -> unit
+
+val check_for_geoproof_input : unit -> unit
diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4
new file mode 100644
index 00000000..3fec0631
--- /dev/null
+++ b/ide/coqide_main.ml4
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+IFDEF QUARTZ THEN
+external gtk_mac_init : (string -> unit) -> (unit -> bool) -> unit
+  = "caml_gtk_mac_init"
+
+external gtk_mac_ready :  ([> Gtk.widget ] as 'a) Gtk.obj -> ([> Gtk.widget ] as 'a) Gtk.obj ->
+                          ([> Gtk.widget ] as 'a) Gtk.obj -> unit
+  = "caml_gtk_mac_ready"
+END
+
+let initmac () = IFDEF QUARTZ THEN gtk_mac_init Coqide.do_load Coqide.forbid_quit_to_save ELSE () END
+
+let macready x y z = IFDEF QUARTZ THEN gtk_mac_ready x#as_widget y#as_widget z#as_widget ELSE ()  END
+
+(* On win32, we add the directory of coqide to the PATH at launch-time
+   (this used to be done in a .bat script). *)
+
+let set_win32_path () =
+  Unix.putenv "PATH"
+    (Filename.dirname Sys.executable_name ^ ";" ^
+      (try Sys.getenv "PATH" with _ -> ""))
+
+(* On win32, since coqide is now console-free, we re-route stdout/stderr
+   to avoid Sys_error if someone writes to them. We write to a pipe which
+   is never read (by default) or to a temp log file (when in debug mode).
+*)
+
+let reroute_stdout_stderr () =
+  let out_descr =
+    if !Ideutils.debug then
+      Unix.descr_of_out_channel (snd (Filename.open_temp_file "coqide_" ".log"))
+    else
+      snd (Unix.pipe ())
+  in
+  Unix.dup2 out_descr Unix.stdout;
+  Unix.dup2 out_descr Unix.stderr
+
+(* We also provide specific kill and interrupt functions. *)
+
+(* Since [win32_interrupt] involves some hack about the process console,
+   only one should run at the same time, we simply skip execution of
+   [win32_interrupt] if another instance is already running *)
+
+let ctrl_c_mtx = Mutex.create ()
+
+let ctrl_c_protect f i =
+  if not (Mutex.try_lock ctrl_c_mtx) then ()
+  else try f i; Mutex.unlock ctrl_c_mtx with _ -> Mutex.unlock ctrl_c_mtx
+
+IFDEF WIN32 THEN
+external win32_kill : int -> unit = "win32_kill"
+external win32_interrupt : int -> unit = "win32_interrupt"
+let () =
+  Coq.killer := win32_kill;
+  Coq.interrupter := ctrl_c_protect win32_interrupt;
+  set_win32_path ();
+  reroute_stdout_stderr ()
+END
+
+let () =
+  let argl = Array.to_list Sys.argv in
+  let argl = Coqide.read_coqide_args argl in
+  let files = Coqide.process_argv argl in
+  let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
+  Coq.check_connection args;
+  Coqide.sup_args := args;
+  Coqide.ignore_break ();
+  (try
+     let gtkrcdir = List.find
+       (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc"))
+       Minilib.xdg_config_dirs in
+     GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc");
+   with Not_found -> ());
+  ignore (GtkMain.Main.init ());
+  initmac () ;
+(*    GtkData.AccelGroup.set_default_mod_mask
+      (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*)
+    ignore (
+	     Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL;
+								 `WARNING;`CRITICAL]
+	       (fun ~level msg ->
+		  if level land Glib.Message.log_level `WARNING <> 0
+		  then Printf.eprintf "Warning: %s\n" msg
+		  else failwith ("Coqide internal error: " ^ msg)));
+    Coqide.main files;
+    if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ());
+    macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")
+             (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt");
+    while true do
+      try
+	GtkThread.main ()
+      with
+	| Sys.Break -> Ideutils.prerr_endline "Interrupted."
+	| e ->
+	    Minilib.safe_prerr_endline
+	      ("CoqIde unexpected error:" ^ (Printexc.to_string e));
+	    Coqide.crash_save 127
+    done
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
new file mode 100644
index 00000000..0d7c67ac
--- /dev/null
+++ b/ide/coqide_ui.ml
@@ -0,0 +1,151 @@
+let ui_m = GAction.ui_manager ();;
+
+let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x)
+
+let list_items menu li =
+  let res_buf = Buffer.create 500 in
+  let tactic_item = function
+    |[] -> Buffer.create 1
+    |[s] -> let b = Buffer.create 16 in
+	    let () = Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under s)^"' />\n") in
+	    b
+    |s::_ as l -> let b = Buffer.create 50 in
+		  let () = (Buffer.add_string b ("<menu action='"^menu^" "^(String.make 1 s.[0])^"'>\n")) in
+		  let () = (List.iter
+			     (fun x -> Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under x)^"' />\n")) l) in
+		  let () = Buffer.add_string b"</menu>\n" in
+		  b in
+  let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in
+  res_buf
+
+let init () =
+  let theui = Printf.sprintf "<ui>
+<menubar name='CoqIde MenuBar'>
+  <menu action='File'>
+    <menuitem action='New' />
+    <menuitem action='Open' />
+    <menuitem action='Save' />
+    <menuitem action='Save as' />
+    <menuitem action='Save all' />
+    <menuitem action='Revert all buffers' />
+    <menuitem action='Close buffer' />
+    <menuitem action='Print...' />
+    <menu action='Export to'>
+      <menuitem action='Html' />
+      <menuitem action='Latex' />
+      <menuitem action='Dvi' />
+      <menuitem action='Pdf' />
+      <menuitem action='Ps' />
+    </menu>
+    <menuitem action='Rehighlight' />
+    %s
+  </menu>
+  <menu name='Edit' action='Edit'>
+    <menuitem action='Undo' />
+    <menuitem action='Clear Undo Stack' />
+    <separator />
+    <menuitem action='Cut' />
+    <menuitem action='Copy' />
+    <menuitem action='Paste' />
+    <separator />
+    <menuitem action='Find in buffer' />
+    <menuitem action='Find backwards' />
+    <menuitem action='Complete Word' />
+    <separator />
+    <menuitem action='External editor' />
+    <separator />
+    <menuitem name='Prefs' action='Preferences' />
+  </menu>
+  <menu action='Navigation'>
+    <menuitem action='Forward' />
+    <menuitem action='Backward' />
+    <menuitem action='Go to' />
+    <menuitem action='Start' />
+    <menuitem action='End' />
+    <menuitem action='Interrupt' />
+    <menuitem action='Hide' />
+    <menuitem action='Previous' />
+    <menuitem action='Next' />
+  </menu>
+  <menu action='Try Tactics'>
+    <menuitem action='auto' />
+    <menuitem action='auto with *' />
+    <menuitem action='eauto' />
+    <menuitem action='eauto with *' />
+    <menuitem action='intuition' />
+    <menuitem action='omega' />
+    <menuitem action='simpl' />
+    <menuitem action='tauto' />
+    <menuitem action='trivial' />
+    <menuitem action='Wizard' />
+    <separator />
+    %s
+  </menu>
+  <menu action='Templates'>
+    <menuitem action='Lemma' />
+    <menuitem action='Theorem' />
+    <menuitem action='Definition' />
+    <menuitem action='Inductive' />
+    <menuitem action='Fixpoint' />
+    <menuitem action='Scheme' />
+    <menuitem action='match' />
+    <separator />
+    %s
+  </menu>
+  <menu action='Queries'>
+    <menuitem action='SearchAbout' />
+    <menuitem action='Check' />
+    <menuitem action='Print' />
+    <menuitem action='About' />
+    <menuitem action='Locate' />
+    <menuitem action='Whelp Locate' />
+  </menu>
+  <menu action='Display'>
+    <menuitem action='Display implicit arguments' />
+    <menuitem action='Display coercions' />
+    <menuitem action='Display raw matching expressions' />
+    <menuitem action='Display notations' />
+    <menuitem action='Display all basic low-level contents' />
+    <menuitem action='Display existential variable instances' />
+    <menuitem action='Display universe levels' />
+    <menuitem action='Display all low-level contents' />
+  </menu>
+  <menu action='Compile'>
+    <menuitem action='Compile buffer' />
+    <menuitem action='Make' />
+    <menuitem action='Next error' />
+    <menuitem action='Make makefile' />
+  </menu>
+  <menu action='Windows'>
+    <menuitem action='Show/Hide Query Pane' />
+    <menuitem action='Show/Hide Toolbar' />
+    <menuitem action='Detach View' />
+  </menu>
+  <menu name='Help' action='Help'>
+    <menuitem action='Browse Coq Manual' />
+    <menuitem action='Browse Coq Library' />
+    <menuitem action='Help for keyword' />
+    <separator />
+    <menuitem name='Abt' action='About Coq' />
+  </menu>
+</menubar>
+<toolbar name='CoqIde ToolBar'>
+  <toolitem action='Save' />
+  <toolitem action='Close buffer' />
+  <toolitem action='Forward' />
+  <toolitem action='Backward' />
+  <toolitem action='Go to' />
+  <toolitem action='Start' />
+  <toolitem action='End' />
+  <toolitem action='Interrupt' />
+  <toolitem action='Hide' />
+  <toolitem action='Previous' />
+  <toolitem action='Next' />
+  <toolitem action='Wizard' />
+</toolbar>
+</ui>"
+    (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "")
+    (Buffer.contents (list_items "Tactic" Coq_commands.tactics))
+    (Buffer.contents (list_items "Template" Coq_commands.commands))
+ in
+  ignore (ui_m#add_ui_from_string theui);
diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml
index 1b52dba3..c69f92e2 100644
--- a/ide/gtk_parsing.ml
+++ b/ide/gtk_parsing.ml
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $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)
+let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0)
+let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0)
+let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0)
+let bn = Glib.Utf8.to_unichar "\n" ~pos:(ref 0)
+let space = Glib.Utf8.to_unichar " " ~pos:(ref 0)
+let tab = Glib.Utf8.to_unichar "\t" ~pos:(ref 0)
 
 
 (* TODO: avoid num and prime at the head of a word *)
diff --git a/ide/highlight.mll b/ide/highlight.mll
deleted file mode 100644
index c288d6a3..00000000
--- a/ide/highlight.mll
+++ /dev/null
@@ -1,215 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: highlight.mll 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-{
-
-  open Lexing
-
-  type color = GText.tag
-
-  type highlight_order = int * int * color
-
-  let comment_start = ref 0
-
-  (* 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"; "Qed" ; "Defined" ; "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 ())
-	[ (* Theorems *)
-          "Theorem" ; "Lemma" ; "Fact" ; "Remark" ; "Corollary" ;
-	  "Proposition" ; "Property" ;
-          (* 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 starting = 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 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"))|
-    ("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 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, Tags.Script.decl }
-  | multiword_command
-      { 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, Tags.Script.kwd
-	  else if is_one_word_declaration id then
-	    lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl
-	  else
-	    next_interior_order lexbuf
-	end
-      }
-  | _    { starting := false; next_interior_order lexbuf}
-  | eof  { raise End_of_file }
-
-and next_interior_order = parse
-  | "(*"
-      { comment_start := lexeme_start lexbuf; comment lexbuf }
-  | ident as id
-      { if is_constr_kw id then
-	  lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd
-        else
-	  next_interior_order lexbuf }
-  | "." (" "|"\n"|"\t") { starting := true; next_starting_order lexbuf }
-  | _    { next_interior_order lexbuf}
-  | eof  { raise End_of_file }
-
-and comment = parse
-  | "*)" { !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 =
-    starting := true; (* approximation: assume the beginning of a sentence *)
-    if !highlighting then prerr_endline "Rejected highlight"
-    else begin
-      highlighting := true;
-      prerr_endline "Highlighting slice now";
-      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
-	  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 ~start ~stop o
-	  done
-	with End_of_file -> ()
-      end
-      with _ -> ());
-      highlighting := false
-    end
-
-  let highlight_current_line input_buffer =
-    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 i = get_insert input_buffer in
-      highlight_slice input_buffer
-	(i#backward_lines 10)
-	(ignore (i#nocopy#forward_lines 10);i)
-
-    with _ -> ()
-
-  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
index 63935db3..9bbf9b0d 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -1,3 +1,4 @@
+Minilib
 Okey
 Config_file
 Configwin_keys
@@ -12,12 +13,14 @@ Typed_notebook
 Config_lexer
 Utf8_convert
 Preferences
+Project_file
 Ideutils
+Ideproof
 Coq_lex
 Gtk_parsing
 Undo
 Coq
 Coq_commands
-Coq_tactics
 Command_windows
+Coqide_ui
 Coqide
diff --git a/ide/ide_mac_stubs.c b/ide/ide_mac_stubs.c
new file mode 100644
index 00000000..64deb71d
--- /dev/null
+++ b/ide/ide_mac_stubs.c
@@ -0,0 +1,85 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include <gtk/gtk.h>
+#include <lablgtk2/wrappers.h>
+#include <lablgtk2/ml_glib.h>
+#include <lablgtk2/ml_gobject.h>
+#include <igemacintegration/gtkosxapplication.h>
+
+GtkOSXApplication *theApp;
+value open_file_fun, forbid_quit_fun, themenubar, pref_item, about_item;
+
+static void osx_accel_map_foreach_lcb(gpointer data,const gchar *accel_path,
+				      guint accel_key, GdkModifierType accel_mods,
+				      gboolean changed) {
+  if (accel_mods & GDK_CONTROL_MASK) {
+    accel_mods |= GDK_META_MASK;
+    accel_mods &= (accel_mods & GDK_MOD1_MASK) ? ~GDK_MOD1_MASK : ~GDK_CONTROL_MASK;
+    if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) {
+      g_print("could not change accelerator %s\n",accel_path);
+    }
+  }
+  if (accel_mods & GDK_MOD1_MASK) {
+    accel_mods &= ~ GDK_MOD1_MASK;
+    accel_mods |= GDK_CONTROL_MASK;
+    if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) {
+      g_print("could not change accelerator %s\n",accel_path);
+    }
+  }
+}
+
+static gboolean deal_with_open(GtkOSXApplication *app, gchar *path, gpointer user_data)
+{
+  CAMLparam0();
+  CAMLlocal2(string_path, res);
+  string_path = caml_copy_string(path);
+  res = caml_callback_exn(open_file_fun,string_path);
+  gboolean truc = !(Is_exception_result(res));
+  CAMLreturnT(gboolean, truc);
+}
+
+static gboolean deal_with_quit(GtkOSXApplication *app, gpointer user_data)
+{
+  CAMLparam0();
+  CAMLlocal1(res);
+  res = caml_callback_exn(forbid_quit_fun,Val_unit);
+  gboolean truc = (Bool_val(res))||((Is_exception_result(res)));
+  CAMLreturnT(gboolean, truc);
+}
+
+CAMLprim value caml_gtk_mac_init(value open_file_the_fun, value forbid_quit_the_fun)
+{
+  CAMLparam2(open_file_the_fun,forbid_quit_the_fun);
+  open_file_fun = open_file_the_fun;
+  caml_register_generational_global_root(&open_file_fun);
+  forbid_quit_fun = forbid_quit_the_fun;
+  caml_register_generational_global_root(&forbid_quit_fun);
+  theApp = g_object_new(GTK_TYPE_OSX_APPLICATION, NULL);
+  g_signal_connect(theApp, "NSApplicationOpenFile", G_CALLBACK(deal_with_open), NULL);
+  g_signal_connect(theApp, "NSApplicationBlockTermination", G_CALLBACK(deal_with_quit), NULL);
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value caml_gtk_mac_ready(value menubar, value prefs, value about)
+{
+  GtkOSXApplicationMenuGroup * pref_grp, * about_grp;
+  CAMLparam3(menubar,prefs,about);
+  themenubar = menubar;
+  pref_item = prefs;
+  about_item = about;
+  caml_register_generational_global_root(&themenubar);
+  caml_register_generational_global_root(&pref_item);
+  caml_register_generational_global_root(&about_item);
+  /*  gtk_accel_map_foreach(NULL, osx_accel_map_foreach_lcb);*/
+  gtk_osxapplication_set_menu_bar(theApp,check_cast(GTK_MENU_SHELL,themenubar));
+  about_grp = gtk_osxapplication_add_app_menu_group(theApp);
+  pref_grp = gtk_osxapplication_add_app_menu_group(theApp);
+  gtk_osxapplication_add_app_menu_item(theApp,about_grp,check_cast(GTK_MENU_ITEM,about_item));
+  gtk_osxapplication_add_app_menu_item(theApp,pref_grp,check_cast(GTK_MENU_ITEM,pref_item));
+  gtk_osxapplication_ready(theApp);
+  CAMLreturn(Val_unit);
+}
diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c
new file mode 100644
index 00000000..c09bf37d
--- /dev/null
+++ b/ide/ide_win32_stubs.c
@@ -0,0 +1,49 @@
+#define _WIN32_WINNT 0x0501  /* Cf below, we restrict to  */
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <windows.h>
+
+/* Win32 emulation of kill -9 */
+
+/* The pid returned by Unix.create_process is actually a pseudo-pid,
+   made via a cast of the obtained HANDLE, (cf. win32unix/createprocess.c
+   in the sources of ocaml). Since we're still in the caller process,
+   we simply cast back to get an handle...
+   The 0 is the exit code we want for the terminated process.
+*/
+
+CAMLprim value win32_kill(value pseudopid) {
+  CAMLparam1(pseudopid);
+  TerminateProcess((HANDLE)(Long_val(pseudopid)), 0);
+  CAMLreturn(Val_unit);
+}
+
+
+/* Win32 emulation of a kill -2 (SIGINT) */
+
+/* This code rely of the fact that coqide is now without initial console.
+   Otherwise, no console creation in win32unix/createprocess.c, hence
+   the same console for coqide and all coqtop, and everybody will be
+   signaled at the same time by the code below. */
+
+/* Moreover, AttachConsole exists only since WinXP, and GetProcessId
+   since WinXP SP1. For avoiding the GetProcessId, we could adapt code
+   from win32unix/createprocess.c to make it return both the pid and the
+   handle. For avoiding the AttachConsole, I don't know, maybe having
+   an intermediate process between coqide and coqtop ? */
+
+CAMLprim value win32_interrupt(value pseudopid) {
+  CAMLparam1(pseudopid);
+  HANDLE h;
+  DWORD pid;
+  FreeConsole(); /* Normally unnecessary, just to be sure... */
+  h = (HANDLE)(Long_val(pseudopid));
+  pid = GetProcessId(h);
+  AttachConsole(pid);
+  /* We want to survive the Ctrl-C that will also concerns us */
+  SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */
+  GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */
+  FreeConsole();
+  CAMLreturn(Val_unit);
+}
diff --git a/ide/ideproof.ml b/ide/ideproof.ml
new file mode 100644
index 00000000..3c3324cb
--- /dev/null
+++ b/ide/ideproof.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+
+(* tag is the tag to be hooked, item is the item covered by this tag, make_menu
+ *  * is the template for building menu if needed, sel_cb is the callback if
+ *  there
+ *   * is a selection o said menu, hover_cb is the callback when there is only
+ *    * hovering *)
+let hook_tag_cb tag menu_content sel_cb hover_cb =
+  ignore (tag#connect#event ~callback:
+            (fun ~origin evt it ->
+               let iter = new GText.iter it in
+               let start = iter#backward_to_tag_toggle (Some tag) in
+               let stop = iter#forward_to_tag_toggle (Some tag) in
+               match GdkEvent.get_type evt with
+                 | `BUTTON_PRESS ->
+                     let ev = GdkEvent.Button.cast evt in
+                     if (GdkEvent.Button.button ev) <> 3 then false else begin
+                       let ctxt_menu = GMenu.menu () in
+                       let factory = new GMenu.factory ctxt_menu in
+                       List.iter
+                         (fun (text,cmd) -> ignore (factory#add_item text ~callback:(sel_cb cmd)))
+                         menu_content;
+                       ctxt_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev);
+                       true
+                     end
+                 | `MOTION_NOTIFY ->
+                     hover_cb start stop; false
+                 | _ -> false))
+
+let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
+  | [] -> assert false
+  | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals ->
+      let on_hover sel_start sel_stop =
+        proof#buffer#remove_tag
+          ~start:proof#buffer#start_iter
+          ~stop:sel_start
+          Tags.Proof.highlight;
+        proof#buffer#remove_tag
+          ~start:sel_stop
+          ~stop:proof#buffer#end_iter
+          Tags.Proof.highlight;
+        proof#buffer#apply_tag ~start:sel_start ~stop:sel_stop Tags.Proof.highlight
+      in
+      let goals_cnt = List.length rem_goals + 1 in
+      let head_str = Printf.sprintf
+        "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s")
+      in
+      let goal_str index total = Printf.sprintf
+        "\n______________________________________(%d/%d)\n" index total
+      in
+      (* Insert current goal and its hypotheses *)
+      let hyps_hints, goal_hints = match hints with
+      | None -> [], []
+      | Some (hl, h) -> (hl, h)
+      in
+      let rec insert_hyp hints hs = match hs with
+      | [] -> ()
+      | hyp :: hs ->
+        let tags, rem_hints = match hints with
+        | [] -> [], []
+        | hint :: hints ->
+          let tag = proof#buffer#create_tag [] in
+          let () = hook_tag_cb tag hint sel_cb on_hover in
+          [tag], hints
+        in
+        let () = proof#buffer#insert ~tags (hyp ^ "\n") in
+        insert_hyp rem_hints hs
+      in
+      let () = proof#buffer#insert head_str in
+      let () = insert_hyp hyps_hints hyps in
+      let () =
+        let tags = if goal_hints <> [] then
+          let tag = proof#buffer#create_tag [] in
+          let () = hook_tag_cb tag goal_hints sel_cb on_hover in
+          [tag]
+          else []
+        in
+        proof#buffer#insert (goal_str 1 goals_cnt);
+        proof#buffer#insert ~tags (cur_goal ^ "\n")
+      in
+      (* Insert remaining goals (no hypotheses) *)
+      let fold_goal i _ { Interface.goal_ccl = g } =
+        proof#buffer#insert (goal_str i goals_cnt);
+        proof#buffer#insert (g ^ "\n")
+      in
+      let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in
+      ignore(proof#buffer#place_cursor  
+        ~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2)));
+      ignore(proof#scroll_to_mark `INSERT)
+
+
+let mode_cesar (proof:GText.view) = function
+  | [] -> assert false
+  | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ ->
+      proof#buffer#insert "    *** Declarative Mode ***\n";
+      List.iter
+        (fun hyp -> proof#buffer#insert (hyp^"\n"))
+        hyps;
+      proof#buffer#insert "______________________________________\n";
+      proof#buffer#insert ("thesis := \n "^cur_goal^"\n");
+      ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT))
+
+let display mode (view:GText.view) goals hints evars =
+  let () = view#buffer#set_text "" in
+  match goals with
+  | None -> ()
+    (* No proof in progress *)
+  | Some { Interface.fg_goals = []; Interface.bg_goals = [] } ->
+    (* A proof has been finished, but not concluded *)
+    begin match evars with
+    | Some evs when evs <> [] ->
+      view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n";
+      let iter evar =
+        let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in
+        view#buffer#insert msg
+      in
+      List.iter iter evs
+    | _ ->
+      view#buffer#insert "Proof Completed."
+    end
+  | Some { Interface.fg_goals = []; Interface.bg_goals = bg } ->
+    (* No foreground proofs, but still unfocused ones *)
+    view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n";
+    let iter goal =
+      let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
+      view#buffer#insert msg
+    in
+    List.iter iter bg
+  | Some { Interface.fg_goals = fg } ->
+    mode view fg hints
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index a6be77f2..fd460c4e 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ideutils.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 
 open Preferences
 
@@ -18,11 +16,11 @@ exception Forbidden
 let status = GMisc.statusbar ()
 
 let push_info,pop_info =
-  let status_context = status#new_context "Messages" in
+  let status_context = status#new_context ~name:"Messages" in
     (fun s -> ignore (status_context#push s)),status_context#pop
 
 let flash_info =
-  let flash_context = status#new_context "Flash" in
+  let flash_context = status#new_context ~name:"Flash" in
     (fun ?(delay=5000) s -> flash_context#flash ~delay s)
 
 
@@ -31,20 +29,10 @@ let set_location = ref  (function s -> failwith "not ready")
 
 let pbar = GRange.progress_bar ~pulse_step:0.2 ()
 
-(* On a Win32 application with no console, writing to stderr raise
-   a Sys_error "bad file descriptor" *)
-let safe_prerr_endline msg = try prerr_endline msg with _ -> ()
-
-let debug = Flags.debug
+let debug = ref (false)
 
 let prerr_endline s =
-  if !debug then try (prerr_endline s;flush stderr) with _ -> ()
-let prerr_string s =
-  if !debug then try (prerr_string s;flush stderr) with _ -> ()
-
-let lib_ide_file f =
-  let coqlib = Envars.coqlib () in
-  Filename.concat (Filename.concat coqlib "ide") f
+  if !debug then try prerr_endline s;flush stderr with _ -> ()
 
 let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
 
@@ -102,7 +90,7 @@ let try_convert s =
   try
     do_convert s
   with _ ->
-    "(* Fatal error: wrong encoding in input.
+    "(* Fatal error: wrong encoding in input. \
 Please choose a correct encoding in the preference panel.*)";;
 
 
@@ -153,26 +141,6 @@ let set_highlight_timer f =
 	Some (GMain.Timeout.add ~ms:2000
 		~callback:(fun () -> f (); highlight_timer := None; true))
 
-
-(* Get back the standard coq out channels *)
-let init_stdout,read_stdout,clear_stdout =
-  let out_buff = Buffer.create 100 in
-  let out_ft = Format.formatter_of_buffer out_buff in
-  let deep_out_ft = Format.formatter_of_buffer out_buff in
-  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
-  (fun () ->
-    Pp_control.std_ft := out_ft;
-    Pp_control.err_ft := out_ft;
-    Pp_control.deep_ft := deep_out_ft;
-),
-  (fun () -> Format.pp_print_flush out_ft ();
-     let r = Buffer.contents out_buff in
-     prerr_endline "Output from Coq is: "; prerr_endline r;
-     Buffer.clear out_buff; r),
-  (fun () ->
-     Format.pp_print_flush out_ft (); Buffer.clear out_buff)
-
-
 let last_dir = ref ""
 
 let filter_all_files () = GFile.filter
@@ -310,7 +278,7 @@ let run_command f c =
   (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
 
 let browse f url =
-  let com = Flags.subst_command_placeholder !current.cmd_browse url in
+  let com = Minilib.subst_command_placeholder !current.cmd_browse url in
   let s = Sys.command com in
   if s = 127 then
     f ("Could not execute\n\""^com^
@@ -318,78 +286,45 @@ let browse f url =
 
 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
+    let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in
+    if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman
   else !current.doc_url
 
 let url_for_keyword =
   let ht = Hashtbl.create 97 in
-  lazy (
-  begin try
-    let cin =
-      try open_in (lib_ide_file "index_urls.txt")
+    lazy (
+      begin try
+	let cin =
+	  try let index_urls = Filename.concat (List.find
+            (fun x -> Sys.file_exists (Filename.concat x "index_urls.txt"))
+	    Minilib.xdg_config_dirs) "index_urls.txt" in
+	    open_in index_urls
+	  with Not_found ->
+	    let doc_url = doc_url () in
+	    let n = String.length doc_url in
+	      if n > 8 && String.sub doc_url 0 7 = "file://" then
+		open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
+	      else
+		raise Exit
+	in
+	  try while true do
+	    let s = input_line cin in
+	      try
+		let i = String.index s ',' in
+		let k = String.sub s 0 i in
+		let u = String.sub s (i + 1) (String.length s - i - 1) in
+		  Hashtbl.add ht k u
+	      with _ ->
+		Minilib.safe_prerr_endline "Warning: Cannot parse documentation index file."
+	  done with End_of_file ->
+	    close_in cin
       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
-	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)
-
+	Minilib.safe_prerr_endline "Warning: Cannot find documentation index file."
+      end;
+      Hashtbl.find ht : string -> string)
 
 let browse_keyword f text =
   try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u)
   with Not_found -> f ("No documentation found for \""^text^"\".\n")
 
-
-(*
-  checks if two file names refer to the same (existing) file by
-  comparing their device and inode.
-  It seems that under Windows, inode is always 0, so we cannot
-  accurately check if
-
-*)
-(* Optimised for partial application (in case many candidates must be
-   compared to f1). *)
-let same_file f1 =
-  try
-    let s1 = Unix.stat f1 in
-    (fun f2 ->
-      try
-        let s2 = Unix.stat f2 in
-        s1.Unix.st_dev = s2.Unix.st_dev &&
-          if Sys.os_type = "Win32" then f1 = f2
-          else s1.Unix.st_ino = s2.Unix.st_ino
-      with
-          Unix.Unix_error _ -> false)
-  with
-      Unix.Unix_error _ -> (fun _ -> false)
-
-let absolute_filename f =
-  if Filename.is_relative f then
-    Filename.concat (Sys.getcwd ()) f
-  else f
-
+let absolute_filename f = Minilib.correct_path f (Sys.getcwd ())
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index d6311c78..1e29d323 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ideutils.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 val async : ('a -> unit) -> 'a -> unit
 val sync  : ('a -> 'b) -> 'a -> 'b
 
@@ -18,8 +16,6 @@ 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
-val init_stdout : unit -> unit
-val clear_stdout : unit -> unit
 val debug : bool ref
 val disconnect_revert_timer : unit -> unit
 val disconnect_auto_save_timer : unit -> unit
@@ -31,15 +27,13 @@ val get_insert : < get_iter_at_mark : [> `INSERT] -> 'a; .. > -> 'a
 
 val is_char_start : char -> bool
 
-val lib_ide_file : string -> string
 val my_stat : string -> Unix.stats option
 
-val safe_prerr_endline : string -> unit
+(** debug printing *)
 val prerr_endline : string -> unit
-val prerr_string : string -> unit
+
 val print_id : 'a -> unit
 
-val read_stdout : unit -> string
 val revert_timer : GMain.Timeout.id option ref
 val auto_save_timer : GMain.Timeout.id option ref
 val select_file_for_open :
@@ -69,13 +63,6 @@ val set_location : (string -> unit) ref
 
 val pbar : GRange.progress_bar
 
-
-(*
-  checks if two file names refer to the same (existing) file
-*)
-
-val same_file : string -> string -> bool
-
 (*
   returns an absolute filename equivalent to given filename
 *)
diff --git a/ide/mac_default_accel_map b/ide/mac_default_accel_map
new file mode 100644
index 00000000..4d34636f
--- /dev/null
+++ b/ide/mac_default_accel_map
@@ -0,0 +1,372 @@
+; coqide.opt GtkAccelMap rc-file         -*- scheme -*-
+; this file is an automated accelerator map dump
+;
+; (gtk_accel_path "<DEFAULT ROOT>/C_anonical Structure/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/M_odule Type/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ompute/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_E.../" "")
+(gtk_accel_path "<Actions>/Templates/match" "<Shift><Meta>c")
+; (gtk_accel_path "<DEFAULT ROOT>/D_erive Inversion/" "")
+; (gtk_accel_path "<Actions>/Queries/Check" "F3")
+; (gtk_accel_path "<DEFAULT ROOT>/i_dtac/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/L_oad/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_ssert/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_irstorder using/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_olve/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_l.../" "")
+(gtk_accel_path "<Actions>/Templates/Inductive" "<Shift><Meta>i")
+; (gtk_accel_path "<DEFAULT ROOT>/a_ssert (__:__)/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_est Printing Synth/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_R.../" "")
+; (gtk_accel_path "<Actions>/Help/Browse Coq Library" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Extraction Optimize/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_imple inversion/" "")
+(gtk_accel_path "<Actions>/Edit/Copy" "<Meta>c")
+; (gtk_accel_path "<DEFAULT ROOT>/E_xtract Inductive/" "")
+(gtk_accel_path "<Actions>/Edit/Cut" "<Meta>x")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nfo/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_emove Printing If/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_apply/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/F_ixpoint/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_hange __ in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/l_apply/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_imple induction/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_ail/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_lim/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ewrite <- __ in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Printing Let/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_ransparent/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_d.../" "")
+(gtk_accel_path "<Actions>/Tactics/Wizard" "<Meta><Control>dollar")
+; (gtk_accel_path "<Actions>/Windows/Detach View" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_heorem/" "")
+(gtk_accel_path "<Actions>/Templates/Scheme" "<Shift><Meta>s")
+; (gtk_accel_path "<DEFAULT ROOT>/R_emark/" "")
+; (gtk_accel_path "<Actions>/Compile/Compile" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Relation/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ename __ into/" "")
+; (gtk_accel_path "<Actions>/File/Save as" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_irstorder/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/G_rammar/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_irstorder with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ed/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_efinition/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_equire Import/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_iscriminate/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntro after/" "")
+; (gtk_accel_path "<Actions>/Export/Latex" "")
+; (gtk_accel_path "<DEFAULT ROOT>/j_p/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_uto with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_ection/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ewrite/" "")
+; (gtk_accel_path "<Actions>/Export/Html" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_i.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_utorewrite/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/F_ocus/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_O.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/l_azy in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent inversion__clear __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_utrewrite/" "")
+(gtk_accel_path "<Actions>/Edit/Undo" "<Meta>u")
+; (gtk_accel_path "<DEFAULT ROOT>/c_onstructor __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ing/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent rewrite <-/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_limtype/" "")
+(gtk_accel_path "<Actions>/Tactics/simpl" "<Meta><Control>s")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Rewrite/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/V_ariable/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Implicit Arguments/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_implify__eq/" "")
+; (gtk_accel_path "<Actions>/Compile/Next error" "F7")
+; (gtk_accel_path "<Actions>/Edit/Edit" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Extraction Optimize/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_ypothesis/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_nd Silent./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_yntax/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ecide equality/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/O_paque/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_T.../" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_a.../" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_G.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ase/" "")
+(gtk_accel_path "<Actions>/Navigation/Backward" "<Meta><Control>Up")
+; (gtk_accel_path "<DEFAULT ROOT>/C_oFixpoint/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_rogram Fixpoint/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent inversion__clear/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ase __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_ssumption/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/t_ransitivity/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntros until/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_plit/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_xists/" "")
+(gtk_accel_path "<Actions>/Templates/Theorem" "<Shift><Meta>t")
+; (gtk_accel_path "<Actions>/Navigation/Navigation" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Unfold/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/I_mplicit Arguments/" "")
+; (gtk_accel_path "<Actions>/Help/Help" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ecompose sum/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T./" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Te_mplates/" "")
+(gtk_accel_path "<Actions>/Edit/Find in buffer" "<Meta>f")
+; (gtk_accel_path "<DEFAULT ROOT>/r_eplace __ with/" "")
+(gtk_accel_path "<Actions>/Tactics/omega" "<Meta><Control>o")
+; (gtk_accel_path "<DEFAULT ROOT>/S_cheme/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/L_emma/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion__clear __ in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_xtraction Inline/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_yntactic Definition/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nstantiate (__:=__)/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/C_hapter/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_L.../" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_f.../" "")
+; (gtk_accel_path "<Actions>/Queries/Queries" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_est Printing Wildcard/" "")
+(gtk_accel_path "<Actions>/File/Open" "<Meta>o")
+; (gtk_accel_path "<DEFAULT ROOT>/f_old __ in/" "")
+(gtk_accel_path "<Actions>/Navigation/Go to" "<Meta><Control>Right")
+; (gtk_accel_path "<Actions>/Export/Export to" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ongruence/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_learbody/" "")
+(gtk_accel_path "<Actions>/File/Close buffer" "<Meta>w")
+; (gtk_accel_path "<DEFAULT ROOT>/a_pply/" "")
+; (gtk_accel_path "<Actions>/Queries/SearchAbout" "F2")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntro/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Immediate/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/p_ose __:=__)/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Undo/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_s.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_rogram Definition/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_equire/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ompare/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_ymmetry in/" "")
+(gtk_accel_path "<Actions>/Display/Display coercions" "<Shift><Control>c")
+(gtk_accel_path "<Actions>/Navigation/Previous" "<Meta><Control>less")
+(gtk_accel_path "<Actions>/Display/Display all low-level contents" "<Shift><Control>l")
+; (gtk_accel_path "<DEFAULT ROOT>/C_oercion Local/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_ix __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd ML Path/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_xiom/" "")
+; (gtk_accel_path "<Actions>/Templates/Templates" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_bstract/" "")
+; (gtk_accel_path "<Actions>/Edit/Clear Undo Stack" "")
+(gtk_accel_path "<Actions>/File/New" "<Meta>n")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_hnf/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_o/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_xtract Constant/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_nd/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_Qed./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Rec ML Path/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_D.../" "")
+(gtk_accel_path "<Actions>/Navigation/Hide" "<Meta><Control>h")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ofix/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/_Try Tactics/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Printing Wildcard/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion__clear/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_V.../" "")
+; (gtk_accel_path "<Actions>/Export/Ps" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Hyps__limit/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Extern/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_unctional induction/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Extraction AutoInline/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nfocus/" "")
+; (gtk_accel_path "<Actions>/Edit/External editor" "")
+; (gtk_accel_path "<DEFAULT ROOT>/I_dentity Coercion/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_bsurd/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_hange/" "")
+(gtk_accel_path "<Actions>/Tactics/eauto" "<Meta><Control>e")
+; (gtk_accel_path "<DEFAULT ROOT>/O_bligations Tactic/" "")
+(gtk_accel_path "<Actions>/Tactics/trivial" "<Meta><Control>v")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent inversion/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_bv/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. /" "")
+; (gtk_accel_path "<DEFAULT ROOT>/p_ose/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_et (__:=__)/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_equire Export/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/L_tac/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Rec LoadPath/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_c.../" "")
+(gtk_accel_path "<Actions>/Navigation/End" "<Meta><Control>End")
+(gtk_accel_path "<Actions>/Templates/Lemma" "<Shift><Meta>l")
+(gtk_accel_path "<Actions>/Navigation/Start" "<Meta><Control>Home")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_I.../" "")
+(gtk_accel_path "<Actions>/File/Print..." "<Meta>p")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent rewrite ->/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_tructure/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_est Printing Let/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_ime/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/g_eneralize/" "")
+(gtk_accel_path "<Actions>/Display/Display all basic low-level contents" "<Shift><Control>a")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_p.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_old/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Resolve/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/M_utual Inductive/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion __ in/" "")
+; (gtk_accel_path "<Actions>/Windows/Show/Hide Toolbar" "")
+(gtk_accel_path "<Actions>/File/Save" "<Meta>s")
+; (gtk_accel_path "<Actions>/File/Save all" "")
+; (gtk_accel_path "<Actions>/Queries/Print" "F4")
+; (gtk_accel_path "<DEFAULT ROOT>/c_onstructor/" "")
+; (gtk_accel_path "<Actions>/Export/Dvi" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_etoid__replace/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_efined./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/I_nfix/" "")
+(gtk_accel_path "<Actions>/Navigation/Next" "<Meta><Control>greater")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Morphism/" "")
+; (gtk_accel_path "<Actions>/Windows/Windows" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_xact/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_bv in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/t_ry/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_A.../" "")
+(gtk_accel_path "<Actions>/Display/Display notations" "<Shift><Control>n")
+; (gtk_accel_path "<DEFAULT ROOT>/c_lear/" "")
+; (gtk_accel_path "<Actions>/Compile/Make" "F6")
+(gtk_accel_path "<Actions>/Tactics/eauto with *" "<Meta><Control>ampersand")
+; (gtk_accel_path "<Actions>/Help/Browse Coq Manual" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_N.../" "")
+(gtk_accel_path "<Actions>/File/Quit" "<Meta>q")
+; (gtk_accel_path "<DEFAULT ROOT>/u_nfold/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_u.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ouble induction/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Silent./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/V_ariables/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Printing Wildcard/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ewrite <-/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/I_nductive/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_auto with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_epeat/" "")
+; (gtk_accel_path "<Actions>/Queries/Locate" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Hyps__limit/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Abstract Semi Ring A Aplus Amult Aone Azero Aeq T./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ompute in/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_F.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/G_lobal Variable/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/t_auto/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_xtraction NoInline/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/u_nfold __ in/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_imple destruct/" "")
+(gtk_accel_path "<Actions>/Navigation/Interrupt" "<Meta><Control>Break")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_S.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_njection/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_ead Module/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_rogram Lemma/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/U_nset Silent./" "")
+(gtk_accel_path "<Actions>/Display/Display universe levels" "<Shift><Control>u")
+; (gtk_accel_path "<DEFAULT ROOT>/f_ourier/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_erive Inversion__clear/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_omega/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Undo/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_impl __ in/" "")
+; (gtk_accel_path "<Actions>/Windows/Show/Hide Query Pane" "Escape")
+; (gtk_accel_path "<DEFAULT ROOT>/R_estore State/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_emove Printing Let/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Printing If/" "")
+(gtk_accel_path "<Actions>/Tactics/tauto" "<Meta><Control>p")
+; (gtk_accel_path "<DEFAULT ROOT>/s_impl/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntros/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_ymmetry/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ut/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_efine/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_e.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_exact/" "")
+(gtk_accel_path "<Actions>/Navigation/Forward" "<Meta><Control>Down")
+(gtk_accel_path "<Actions>/Edit/Paste" "<Meta>v")
+; (gtk_accel_path "<DEFAULT ROOT>/C_oercion/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_r.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_estruct/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Setoid/" "")
+; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "")
+; (gtk_accel_path "<DEFAULT ROOT>/T_est Printing If/" "")
+; (gtk_accel_path "<Actions>/Display/Display" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_move __ after/" "")
+(gtk_accel_path "<Actions>/Edit/Complete Word" "<Meta>slash")
+; (gtk_accel_path "<DEFAULT ROOT>/s_ubst/" "")
+; (gtk_accel_path "<Actions>/Help/About Coq" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_etoid__rewrite/" "")
+; (gtk_accel_path "<Actions>/Tactics/Try Tactics" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_C.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/L_ocal/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/s_et/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_quote/" "")
+(gtk_accel_path "<Actions>/Templates/Definition" "<Shift><Meta>d")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Implicit Arguments/" "")
+; (gtk_accel_path "<Actions>/File/Revert all buffers" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_P.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/t_rivial/" "")
+(gtk_accel_path "<Actions>/Display/Display existential variable instances" "<Shift><Control>e")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_j.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd LoadPath/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/N_otation/" "")
+; (gtk_accel_path "<Actions>/Edit/Preferences" "")
+; (gtk_accel_path "<DEFAULT ROOT>/L_oad Verbose/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntro __ after/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_erive Dependent Inversion/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ependent inversion __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_rogram Theorem/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_xtraction Language/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_U.../" "")
+(gtk_accel_path "<Actions>/Display/Display raw matching expressions" "<Shift><Control>m")
+; (gtk_accel_path "<DEFAULT ROOT>/c_asetype/" "")
+(gtk_accel_path "<Actions>/Edit/Find backwards" "<Meta>b")
+; (gtk_accel_path "<DEFAULT ROOT>/S_ave./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/p_attern/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/M_odule/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_eclare ML Module/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_H.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/F_act/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/A_dd Field/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_emove LoadPath/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_Write State/" "")
+; (gtk_accel_path "<Actions>/Compile/Make makefile" "")
+; (gtk_accel_path "<DEFAULT ROOT>/C_oInductive/" "")
+; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
+; (gtk_accel_path "<DEFAULT ROOT>/l_eft/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_pply __ with/" "")
+(gtk_accel_path "<Actions>/File/Rehighlight" "<Meta>l")
+; (gtk_accel_path "<Actions>/File/File" "")
+; (gtk_accel_path "<DEFAULT ROOT>/D_erive Dependent Inversion__clear/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ecompose/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ewrite __ in/" "")
+(gtk_accel_path "<Actions>/Display/Display implicit arguments" "<Shift><Control>i")
+; (gtk_accel_path "<DEFAULT ROOT>/e_lim __ using/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/a_ssert (__:=__)/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion __ using/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_arameter/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/H_int Constructors/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/j_p <n>/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/p_rogress/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Templates/_M.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_lim __ with/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_irst/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/l_azy/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion/" "")
+(gtk_accel_path "<Actions>/Help/Help for keyword" "<Meta>h")
+; (gtk_accel_path "<DEFAULT ROOT>/a_uto/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/G_oal/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nversion __ using __ in/" "")
+(gtk_accel_path "<Actions>/Tactics/intuition" "<Meta><Control>i")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ed in/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_g.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/g_eneralize dependent/" "")
+; (gtk_accel_path "<Actions>/Queries/About" "F5")
+; (gtk_accel_path "<DEFAULT ROOT>/r_ight/" "")
+(gtk_accel_path "<Actions>/Tactics/auto" "<Meta><Control>a")
+(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Meta>f")
+; (gtk_accel_path "<DEFAULT ROOT>/r_eflexivity/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_nduction/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/i_ntuition/" "")
+; (gtk_accel_path "<CoqIde MenuBar>/Tactics/_t.../" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_ix/" "")
+; (gtk_accel_path "<Actions>/Export/Pdf" "")
+; (gtk_accel_path "<DEFAULT ROOT>/N_ext Obligation/" "")
+(gtk_accel_path "<Actions>/Tactics/auto with *" "<Meta><Control>asterisk")
+; (gtk_accel_path "<DEFAULT ROOT>/R_ecord/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/P_roof./" "")
+; (gtk_accel_path "<DEFAULT ROOT>/c_ontradiction/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/S_et Extraction AutoInline/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/e_auto/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/d_ecompose record/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/f_ield/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/E_val/" "")
+; (gtk_accel_path "<DEFAULT ROOT>/R_eset Extraction Inline/" "")
diff --git a/ide/minilib.ml b/ide/minilib.ml
new file mode 100644
index 00000000..cec77f3b
--- /dev/null
+++ b/ide/minilib.ml
@@ -0,0 +1,174 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** Some excerpt of Util and similar files to avoid loading the whole
+    module and its dependencies (and hence Compat and Camlp4) *)
+
+module Stringmap = Map.Make(String)
+
+let list_fold_left_i f =
+  let rec it_list_f i a = function
+    | [] -> a
+    | b::l -> it_list_f (i+1) (f i a b) l
+  in
+  it_list_f
+
+(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
+   [l1++l2=l] and [l1] has length [i].
+   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+
+let list_chop n l =
+  let rec chop_aux i acc = function
+    | tl when i=0 -> (List.rev acc, tl)
+    | h::t -> chop_aux (pred i) (h::acc) t
+    | [] -> failwith "list_chop"
+  in
+  chop_aux n [] l
+
+
+let list_map_i f =
+  let rec map_i_rec i = function
+    | [] -> []
+    | x::l -> let v = f i x in v :: map_i_rec (i+1) l
+  in
+  map_i_rec
+
+
+let list_index x =
+  let rec index_x n = function
+    | y::l -> if x = y then n else index_x (succ n) l
+    | [] -> raise Not_found
+  in
+  index_x 1
+
+let list_index0 x l = list_index x l - 1
+
+let list_filter_i p =
+  let rec filter_i_rec i = function
+    | [] -> []
+    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+  in
+  filter_i_rec 0
+
+let string_map f s =
+  let l = String.length s in
+  let r = String.create l in
+  for i= 0 to (l - 1) do r.[i] <- f (s.[i]) done;
+  r
+
+let subst_command_placeholder s t =
+  Str.global_replace (Str.regexp_string "%s") t s
+
+let path_to_list p =
+  let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in
+    Str.split sep p
+
+(* On win32, the home directory is probably not in $HOME, but in
+   some other environment variable *)
+
+let home =
+  try Sys.getenv "HOME" with Not_found ->
+    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
+      try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name
+
+let xdg_config_home =
+  try
+    Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq"
+  with Not_found ->
+    Filename.concat home "/.config/coq"
+
+let xdg_config_dirs =
+  xdg_config_home :: (try
+    List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
+  with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with |None -> [] |Some d -> [d]))
+
+let xdg_data_home =
+  try
+    Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq"
+  with Not_found ->
+    Filename.concat home "/.local/share/coq"
+
+let xdg_data_dirs =
+  xdg_data_home :: (try
+    List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+  with Not_found ->
+    "/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with |None -> [] |Some d -> [d]))
+
+let coqtop_path = ref ""
+
+(* On a Win32 application with no console, writing to stderr raise
+   a Sys_error "bad file descriptor", hence the "try" below.
+   Ideally, we should re-route message to a log file somewhere, or
+   print in the response buffer.
+*)
+
+let safe_prerr_endline s =
+  try prerr_endline s;flush stderr with _ -> ()
+
+(* Hints to partially detects if two paths refer to the same repertory *)
+let rec remove_path_dot p =
+  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
+  let n = String.length curdir in
+  let l = String.length p in
+  if l > n && String.sub p 0 n = curdir then
+    let n' =
+      let sl = String.length Filename.dir_sep in
+      let i = ref n in
+	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
+    remove_path_dot (String.sub p n' (l - n'))
+  else
+    p
+
+let strip_path p =
+  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+  let n = String.length cwd in
+  let l = String.length p in
+  if l > n && String.sub p 0 n = cwd then
+    let n' =
+      let sl = String.length Filename.dir_sep in
+      let i = ref n in
+	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
+    remove_path_dot (String.sub p n' (l - n'))
+  else
+    remove_path_dot p
+
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  try
+    Sys.chdir p;
+    let p' = Sys.getcwd () in
+    Sys.chdir current;
+    p'
+  with Sys_error _ ->
+    (* We give up to find a canonical name and just simplify it... *)
+    strip_path p
+
+let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f
+
+(*
+  checks if two file names refer to the same (existing) file by
+  comparing their device and inode.
+  It seems that under Windows, inode is always 0, so we cannot
+  accurately check if
+
+*)
+(* Optimised for partial application (in case many candidates must be
+   compared to f1). *)
+let same_file f1 =
+  try
+    let s1 = Unix.stat f1 in
+    (fun f2 ->
+      try
+        let s2 = Unix.stat f2 in
+        s1.Unix.st_dev = s2.Unix.st_dev &&
+          if Sys.os_type = "Win32" then f1 = f2
+          else s1.Unix.st_ino = s2.Unix.st_ino
+      with
+          Unix.Unix_error _ -> false)
+  with
+      Unix.Unix_error _ -> (fun _ -> false)
diff --git a/ide/minilib.mli b/ide/minilib.mli
new file mode 100644
index 00000000..53d6c87c
--- /dev/null
+++ b/ide/minilib.mli
@@ -0,0 +1,44 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** Some excerpts of Util and similar files to avoid depending on them
+    and hence on Compat and Camlp4 *)
+
+module Stringmap : Map.S with type key = string
+
+val list_fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+val list_filter_i : (int -> 'a -> bool) -> 'a list -> 'a list
+val list_chop : int -> 'a list -> 'a list * 'a list
+val list_index0 : 'a -> 'a list -> int
+
+val string_map : (char -> char) -> string -> string
+
+val subst_command_placeholder : string -> string -> string
+
+val home : string
+val xdg_config_home : string
+val xdg_config_dirs : string list
+val xdg_data_home : string
+val xdg_data_dirs : string list
+
+val coqtop_path : string ref
+
+(** safe version of Pervasives.prerr_endline
+    (avoid exception in win32 without console) *)
+val safe_prerr_endline : string -> unit
+
+val remove_path_dot : string -> string
+val strip_path : string -> string
+val canonical_path_name : string -> string
+(** correct_path f dir = dir/f if f is relative *)
+val correct_path : string -> string -> string
+
+(** checks if two file names refer to the same (existing) file *)
+val same_file : string -> string -> bool
+
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 790bf560..02673098 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -1,53 +1,44 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: preferences.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Configwin
 open Printf
-open Util
 
-let pref_file = Filename.concat System.home ".coqiderc"
+let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc"
 
-let accel_file = Filename.concat System.home ".coqide.keys"
+let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys"
 
 let mod_to_str (m:Gdk.Tags.modifier) =
   match m with
-    | `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"
-
-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
-    | s -> `MOD1
+    | `MOD1 -> "<Alt>"
+    | `MOD2 -> "<Mod2>"
+    | `MOD3 -> "<Mod3>"
+    | `MOD4 -> "<Mod4>"
+    | `MOD5 -> "<Mod5>"
+    | `CONTROL -> "<Control>"
+    | `SHIFT -> "<Shift>"
+    |  `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> ""
+
+let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l
+
+let str_to_mod_list s = snd (GtkData.AccelGroup.parse s)
+
+type project_behavior = Ignore_args | Append_args | Subst_args
+
+let string_of_project_behavior = function
+  |Ignore_args -> "ignored"
+  |Append_args -> "appended to arguments"
+  |Subst_args -> "taken instead of arguments"
+
+let project_behavior_of_string s =
+  if s = "taken instead of arguments" then Subst_args
+  else if s = "appended to arguments" then Append_args
+  else Ignore_args
 
 type pref =
     {
@@ -63,6 +54,9 @@ type pref =
       mutable auto_save_delay : int;
       mutable auto_save_name : string * string;
 
+      mutable read_project : project_behavior;
+      mutable project_file_name : string;
+
       mutable encoding_use_locale : bool;
       mutable encoding_use_utf8 : bool;
       mutable encoding_manual : string;
@@ -70,11 +64,11 @@ type pref =
       mutable automatic_tactics : string list;
       mutable cmd_print : string;
 
-      mutable modifier_for_navigation : Gdk.Tags.modifier list;
-      mutable modifier_for_templates : Gdk.Tags.modifier list;
-      mutable modifier_for_tactics : Gdk.Tags.modifier list;
-      mutable modifier_for_display : Gdk.Tags.modifier list;
-      mutable modifiers_valid : Gdk.Tags.modifier list;
+      mutable modifier_for_navigation : string;
+      mutable modifier_for_templates : string;
+      mutable modifier_for_tactics : string;
+      mutable modifier_for_display : string;
+      mutable modifiers_valid : string;
 
       mutable cmd_browse : string;
       mutable cmd_editor : string;
@@ -117,6 +111,9 @@ let (current:pref ref) =
     auto_save_delay = 10000;
     auto_save_name = "#","#";
 
+    read_project = Ignore_args;
+    project_file_name = "_CoqProject";
+
     encoding_use_locale = true;
     encoding_use_utf8 = false;
     encoding_manual = "ISO_8859-1";
@@ -124,18 +121,20 @@ let (current:pref ref) =
     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];
+    modifier_for_navigation = "<Control><Alt>";
+    modifier_for_templates = "<Control><Shift>";
+    modifier_for_tactics = "<Control><Alt>";
+    modifier_for_display = "<Alt><Shift>";
+    modifiers_valid = "<Alt><Control><Shift>";
 
 
     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";
+    text_font = Pango.Font.from_string (match Coq_config.gtk_platform with
+					  |`QUARTZ -> "Arial Unicode MS 11"
+					  |_ -> "Monospace 10");
 
     doc_url = Coq_config.wwwrefman;
     library_url = Coq_config.wwwstdlib;
@@ -168,13 +167,15 @@ let contextual_menus_on_goal = ref (fun x -> ())
 let resize_window = ref (fun () -> ())
 
 let save_pref () =
+  if not (Sys.file_exists Minilib.xdg_config_home)
+  then Unix.mkdir Minilib.xdg_config_home 0o700;
   (try GtkData.AccelMap.save accel_file
   with _ -> ());
   let p = !current in
-  try
-    let add = Stringmap.add in
+
+    let add = Minilib.Stringmap.add in
     let (++) x f = f x in
-    Stringmap.empty ++
+    Minilib.Stringmap.empty ++
     add "cmd_coqc" [p.cmd_coqc] ++
     add "cmd_make" [p.cmd_make] ++
     add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
@@ -186,22 +187,20 @@ let save_pref () =
     add "auto_save_delay" [string_of_int p.auto_save_delay] ++
     add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++
 
+    add "project_options" [string_of_project_behavior p.read_project] ++
+    add "project_file_name" [p.project_file_name] ++
+
     add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++
     add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++
     add "encoding_manual" [p.encoding_manual] ++
 
     add "automatic_tactics" p.automatic_tactics ++
     add "cmd_print" [p.cmd_print] ++
-    add "modifier_for_navigation"
-      (List.map mod_to_str p.modifier_for_navigation) ++
-    add "modifier_for_templates"
-      (List.map mod_to_str p.modifier_for_templates) ++
-    add "modifier_for_tactics"
-      (List.map mod_to_str p.modifier_for_tactics) ++
-    add "modifier_for_display"
-      (List.map mod_to_str p.modifier_for_display) ++
-    add "modifiers_valid"
-      (List.map mod_to_str p.modifiers_valid) ++
+    add "modifier_for_navigation" [p.modifier_for_navigation] ++
+    add "modifier_for_templates" [p.modifier_for_templates] ++
+    add "modifier_for_tactics" [p.modifier_for_tactics] ++
+    add "modifier_for_display" [p.modifier_for_display] ++
+    add "modifiers_valid" [p.modifiers_valid] ++
     add "cmd_browse" [p.cmd_browse] ++
     add "cmd_editor" [p.cmd_editor] ++
 
@@ -222,15 +221,17 @@ let save_pref () =
     add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
     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 accel_dir = List.find
+    (fun x -> Sys.file_exists (Filename.concat x "coqide.keys"))
+    Minilib.xdg_config_dirs in
+  GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys");
   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
+    let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in
     let set_hd k f = set k (fun v -> f (List.hd v)) in
     let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in
     let set_int k f = set_hd k (fun v -> f (int_of_string v)) in
@@ -251,19 +252,22 @@ let load_pref () =
     set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v);
     set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v);
     set_hd "encoding_manual" (fun v -> np.encoding_manual <- v);
+    set_hd "project_options"
+      (fun v -> np.read_project <- (project_behavior_of_string v));
+    set_hd "project_file_name" (fun v -> np.project_file_name <- v);
     set "automatic_tactics"
       (fun v -> np.automatic_tactics <- v);
     set_hd "cmd_print" (fun v -> np.cmd_print <- v);
-    set "modifier_for_navigation"
-      (fun v -> np.modifier_for_navigation <- List.map str_to_mod v);
-    set "modifier_for_templates"
-      (fun v -> np.modifier_for_templates <- List.map str_to_mod v);
-    set "modifier_for_tactics"
-      (fun v -> np.modifier_for_tactics <- List.map str_to_mod v);
-    set "modifier_for_display"
-      (fun v -> np.modifier_for_display <- List.map str_to_mod v);
-    set "modifiers_valid"
-      (fun v -> np.modifiers_valid <- List.map str_to_mod v);
+    set_hd "modifier_for_navigation"
+      (fun v -> np.modifier_for_navigation <- v);
+    set_hd "modifier_for_templates"
+      (fun v -> np.modifier_for_templates <- v);
+    set_hd "modifier_for_tactics"
+      (fun v -> np.modifier_for_tactics <- v);
+    set_hd "modifier_for_display"
+      (fun v -> np.modifier_for_display <- v);
+    set_hd "modifiers_valid"
+      (fun v -> np.modifiers_valid <- v);
     set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v);
     set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v);
     set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v);
@@ -274,7 +278,7 @@ let load_pref () =
         v <> Coq_config.wwwcoq ^ "doc" &&
 	v <> Coq_config.wwwcoq ^ "doc/"
       then
-	prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v);
+	(*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);
@@ -289,21 +293,10 @@ let load_pref () =
     set_bool "lax_syntax" (fun v -> np.lax_syntax <- v);
     set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
     set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
-    current := np;
+    current := np
 (*
     Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-  with e ->
-    prerr_endline ("Could not load preferences ("^
-		   (Printexc.to_string e)^").")
-
-let split_string_format s =
-  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 =
@@ -462,46 +455,62 @@ let configure ?(apply=(fun () -> ())) () =
       (if !current.encoding_use_utf8 then "UTF-8"
        else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual)
   in
+  let read_project =
+    combo
+      "Project file options are"
+      ~f:(fun s -> !current.read_project <- project_behavior_of_string s)
+      ~editable:false
+      [string_of_project_behavior Subst_args;
+       string_of_project_behavior Append_args;
+       string_of_project_behavior Ignore_args]
+      (string_of_project_behavior !current.read_project)
+  in
+  let project_file_name =
+    string "Default name for project file"
+      ~f:(fun s -> !current.project_file_name <- s)
+      !current.project_file_name
+  in
   let help_string =
     "restart to apply"
   in
+  let the_valid_mod = str_to_mod_list !current.modifiers_valid in
   let modifier_for_tactics =
     modifiers
-      ~allow:!current.modifiers_valid
-      ~f:(fun l -> !current.modifier_for_tactics <- l)
+      ~allow:the_valid_mod
+      ~f:(fun l -> !current.modifier_for_tactics <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Tactics Menu"
-      !current.modifier_for_tactics
+      (str_to_mod_list !current.modifier_for_tactics)
   in
   let modifier_for_templates =
     modifiers
-      ~allow:!current.modifiers_valid
-      ~f:(fun l -> !current.modifier_for_templates <- l)
+      ~allow:the_valid_mod
+      ~f:(fun l -> !current.modifier_for_templates <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Templates Menu"
-      !current.modifier_for_templates
+      (str_to_mod_list !current.modifier_for_templates)
   in
   let modifier_for_navigation =
     modifiers
-      ~allow:!current.modifiers_valid
-      ~f:(fun l -> !current.modifier_for_navigation <- l)
+      ~allow:the_valid_mod
+      ~f:(fun l -> !current.modifier_for_navigation <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Navigation Menu"
-      !current.modifier_for_navigation
+      (str_to_mod_list !current.modifier_for_navigation)
   in
   let modifier_for_display =
     modifiers
-      ~allow:!current.modifiers_valid
-      ~f:(fun l -> !current.modifier_for_display <- l)
+      ~allow:the_valid_mod
+      ~f:(fun l -> !current.modifier_for_display <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Display Menu"
-      !current.modifier_for_display
+      (str_to_mod_list !current.modifier_for_display)
   in
   let modifiers_valid =
     modifiers
-      ~f:(fun l -> !current.modifiers_valid <- l)
+      ~f:(fun l -> !current.modifiers_valid <- mod_list_to_str l)
       "Allowed modifiers"
-      !current.modifiers_valid
+      the_valid_mod
   in
   let cmd_editor =
     let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in
@@ -520,8 +529,7 @@ let configure ?(apply=(fun () -> ())) () =
       "netscape -remote \"openURL(%s)\"";
       "mozilla -remote \"openURL(%s)\"";
       "firefox -remote \"openURL(%s,new-windows)\" || firefox %s &";
-      "seamonkey -remote \"openURL(%s)\" || seamonkey %s &";
-      "open -a Safari %s &"
+      "seamonkey -remote \"openURL(%s)\" || seamonkey %s &"
     ] in
     combo
       ~help:"(%s for url)"
@@ -534,6 +542,8 @@ let configure ?(apply=(fun () -> ())) () =
   in
   let doc_url =
     let predefined = [
+      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]);
+      Coq_config.wwwrefman;
       use_default_doc_url
     ] in
     combo
@@ -545,11 +555,13 @@ let configure ?(apply=(fun () -> ())) () =
       !current.doc_url in
   let library_url =
     let predefined = [
+      "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
       Coq_config.wwwstdlib
     ] in
     combo
       "Library URL"
       ~f:(fun s -> !current.library_url <- s)
+      ~new_allowed: true
       (predefined@[if List.mem !current.library_url predefined then ""
                    else !current.library_url])
       !current.library_url
@@ -577,27 +589,30 @@ let configure ?(apply=(fun () -> ())) () =
 (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
    (shame on Benjamin) *)
   let cmds =
-    [Section("Fonts",
+    [Section("Fonts", Some `SELECT_FONT,
 	     [config_font]);
-     Section("Files",
+     Section("Files", Some `DIRECTORY,
 	     [global_auto_revert;global_auto_revert_delay;
 	      auto_save; auto_save_delay; (* auto_save_name*)
 	      encodings;
 	     ]);
+     Section("Project", Some (`STOCK "gtk-page-setup"),
+	     [project_file_name;read_project;
+	     ]);
 (*
      Section("Appearance",
 	     config_appearance);
 *)
-     Section("Externals",
+     Section("Externals", None,
 	     [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;
 	      cmd_editor;
 	      cmd_browse;doc_url;library_url]);
-     Section("Tactics Wizard",
+     Section("Tactics Wizard", None,
 	     [automatic_tactics]);
-     Section("Shortcuts",
+     Section("Shortcuts", Some `PREFERENCES,
 	     [modifiers_valid; modifier_for_tactics;
 	      modifier_for_templates; modifier_for_display; modifier_for_navigation]);
-     Section("Misc",
+     Section("Misc", Some `ADD,
 	     misc)]
   in
 (*
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 472ae30f..f55088f1 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: preferences.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+type project_behavior = Ignore_args | Append_args | Subst_args
 
 type pref =
     {
@@ -22,6 +22,9 @@ type pref =
       mutable auto_save_delay : int;
       mutable auto_save_name : string * string;
 
+      mutable read_project : project_behavior;
+      mutable project_file_name : string;
+
       mutable encoding_use_locale : bool;
       mutable encoding_use_utf8 : bool;
       mutable encoding_manual : string;
@@ -29,11 +32,11 @@ type pref =
       mutable automatic_tactics : string list;
       mutable cmd_print : string;
 
-      mutable modifier_for_navigation : Gdk.Tags.modifier list;
-      mutable modifier_for_templates : Gdk.Tags.modifier list;
-      mutable modifier_for_tactics : Gdk.Tags.modifier list;
-      mutable modifier_for_display : Gdk.Tags.modifier list;
-      mutable modifiers_valid : Gdk.Tags.modifier list;
+      mutable modifier_for_navigation : string;
+      mutable modifier_for_templates : string;
+      mutable modifier_for_tactics : string;
+      mutable modifier_for_display : string;
+      mutable modifiers_valid : string;
 
       mutable cmd_browse : string;
       mutable cmd_editor : string;
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
new file mode 100644
index 00000000..6bee0fec
--- /dev/null
+++ b/ide/project_file.ml4
@@ -0,0 +1,190 @@
+type target =
+  | ML of string (* ML file : foo.ml -> (ML "foo.ml") *)
+  | MLI of string (* MLI file : foo.mli -> (MLI "foo.mli") *)
+  | ML4 of string (* ML4 file : foo.ml4 -> (ML4 "foo.ml4") *)
+  | MLLIB of string (* MLLIB file : foo.mllib -> (MLLIB "foo.mllib") *)
+  | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *)
+  | V of string  (* V file : foo.v -> (V "foo") *)
+  | Arg of string
+  | Special of string * string * string (* file, dependencies, command *)
+  | Subdir of string
+  | Def of string * string (* X=foo -> Def ("X","foo") *)
+  | Include of string
+  | RInclude of string * string (* -R physicalpath logicalpath *)
+
+type install =
+  | NoInstall
+  | TraditionalInstall
+  | UserInstall
+  | UnspecInstall
+
+exception Parsing_error
+let rec parse_string = parser
+  | [< '' ' | '\n' | '\t' >] -> ""
+  | [< 'c; s >] -> (String.make 1 c)^(parse_string s)
+  | [< >] -> ""
+and parse_string2 = parser
+  | [< ''"' >] -> ""
+  | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s)
+and parse_skip_comment = parser
+  | [< ''\n'; s >] -> s
+  | [< 'c; s >] -> parse_skip_comment s
+  | [< >] -> [< >]
+and parse_args = parser
+  | [< '' ' | '\n' | '\t'; s >] -> parse_args s
+  | [< ''#'; s >] -> parse_args (parse_skip_comment s)
+  | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s
+  | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s)
+  | [< >] -> []
+
+
+let parse f =
+  let c = open_in f in
+  let res = parse_args (Stream.of_channel c) in
+    close_in c;
+    res
+
+let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function
+  | [] -> opts,List.rev l
+  | ("-h"|"--help") :: _ ->
+    raise Parsing_error
+  | ("-no-opt"|"-byte") :: r ->
+    process_cmd_line orig_dir (project_file,makefile,install,false) l r
+  | ("-full"|"-opt") :: r ->
+    process_cmd_line orig_dir (project_file,makefile,install,true) l r
+  | "-impredicative-set" :: r ->
+    Minilib.safe_prerr_endline "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.";
+    process_cmd_line orig_dir opts (Arg "-impredicative_set" :: l) r
+  | "-no-install" :: r ->
+    Minilib.safe_prerr_endline "Option -no-install is deprecated. Use \"-install none\" instead";
+    process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r
+  | "-install" :: d :: r ->
+    if install <> UnspecInstall then Minilib.safe_prerr_endline "Warning: -install sets more than once.";
+    let install =
+      match d with
+	| "user" -> UserInstall
+	| "none" -> NoInstall
+	| "global" -> TraditionalInstall
+	| _ -> Minilib.safe_prerr_endline (String.concat "" ["Warning: invalid option '"; d; "' passed to -install."]);
+          install
+    in
+    process_cmd_line orig_dir (project_file,makefile,install,opt) l r
+  | "-custom" :: com :: dependencies :: file :: r ->
+    process_cmd_line orig_dir opts (Special (file,dependencies,com) :: l) r
+  | "-I" :: d :: r ->
+    process_cmd_line orig_dir opts ((Include (Minilib.correct_path d orig_dir)) :: l) r
+  | "-R" :: p :: lp :: r ->
+    process_cmd_line orig_dir opts (RInclude (Minilib.correct_path p orig_dir,lp) :: l) r
+  | ("-I"|"-custom") :: _ ->
+    raise Parsing_error
+  | "-f" :: file :: r ->
+    let file = Minilib.remove_path_dot (Minilib.correct_path file orig_dir) in
+    let () = match project_file with
+      | None -> ()
+      | Some _ -> Minilib.safe_prerr_endline
+	"Warning: Several features will not work with multiple project files."
+    in
+    let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in
+      process_cmd_line orig_dir opts' l' r
+  | ["-f"] ->
+    raise Parsing_error
+  | "-o" :: file :: r ->
+      begin try
+	let _ = String.index file '/' in
+	  raise Parsing_error
+      with Not_found ->
+	let () = match makefile with
+	  |None -> ()
+	  |Some f ->
+	     Minilib.safe_prerr_endline ("Warning: Only one output file is genererated. "^f^" will not be.")
+	in process_cmd_line orig_dir (project_file,Some file,install,opt) l r
+      end
+  | v :: "=" :: def :: r ->
+    process_cmd_line orig_dir opts (Def (v,def) :: l) r
+  | "-arg" :: a :: r ->
+    process_cmd_line orig_dir opts (Arg a :: l) r
+  | f :: r ->
+      let f = Minilib.correct_path f orig_dir in
+	process_cmd_line orig_dir opts ((
+          if Filename.check_suffix f ".v" then V f
+	  else if (Filename.check_suffix f ".ml") then ML f
+	  else if (Filename.check_suffix f ".ml4") then ML4 f
+	  else if (Filename.check_suffix f ".mli") then MLI f
+	  else if (Filename.check_suffix f ".mllib") then MLLIB f
+	  else if (Filename.check_suffix f ".mlpack") then MLPACK f
+	  else Subdir f) :: l) r
+
+let rec post_canonize f =
+  if Filename.basename f = Filename.current_dir_name
+  then let dir = Filename.dirname f in
+    if dir = Filename.current_dir_name then f else post_canonize dir
+  else f
+
+(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(i_inc,r_inc),(args,defs)) *)
+let split_arguments =
+  let rec aux = function
+  | V n :: r ->
+	let (v,m,o,s),i,d = aux r in ((Minilib.remove_path_dot n::v,m,o,s),i,d)
+  | ML n :: r ->
+      let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
+      ((v,(mli,ml4,Minilib.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
+  | MLI n :: r ->
+      let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
+      ((v,(Minilib.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
+  | ML4 n :: r ->
+      let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
+      ((v,(mli,Minilib.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
+  | MLLIB n :: r ->
+      let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
+      ((v,(mli,ml4,ml,Minilib.remove_path_dot n::mllib,mlpack),o,s),i,d)
+  | MLPACK n :: r ->
+      let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
+      ((v,(mli,ml4,ml,mllib,Minilib.remove_path_dot n::mlpack),o,s),i,d)
+  | Special (n,dep,c) :: r ->
+      let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,c)::o,s),i,d)
+  | Subdir n :: r ->
+      let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d)
+  | Include p :: r ->
+      let t,(i,r),d = aux r in (t,((Minilib.remove_path_dot (post_canonize p),
+				    Minilib.canonical_path_name p)::i,r),d)
+  | RInclude (p,l) :: r ->
+      let t,(i,r),d = aux r in (t,(i,(Minilib.remove_path_dot (post_canonize p),l,
+				      Minilib.canonical_path_name p)::r),d)
+  | Def (v,def) :: r ->
+      let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs))
+  | Arg a :: r ->
+      let t,i,(args,defs) = aux r in (t,i,(a::args,defs))
+  | [] -> ([],([],[],[],[],[]),[],[]),([],[]),([],[])
+  in aux
+
+let read_project_file f =
+  split_arguments
+    (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f)))
+
+let args_from_project file project_files default_name =
+  let is_f = Minilib.same_file file in
+  let contains_file dir =
+      List.exists (fun x -> is_f (Minilib.correct_path x dir))
+  in
+  let build_cmd_line i_inc r_inc args =
+    List.fold_right (fun (_,i) o -> "-I" :: i :: o) i_inc
+      (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc
+	 (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))
+  in try
+      let (_,(_,(i_inc,r_inc),(args,_))) =
+	List.find (fun (dir,((v_files,_,_,_),_,_)) ->
+		     contains_file dir v_files) project_files in
+	build_cmd_line i_inc r_inc args
+    with Not_found ->
+      let rec find_project_file dir = try
+	let ((v_files,_,_,_),(i_inc,r_inc),(args,_)) =
+	  read_project_file (Filename.concat dir default_name) in
+	  if contains_file dir v_files
+	  then build_cmd_line i_inc r_inc args
+	  else let newdir = Filename.dirname dir in
+	    Minilib.safe_prerr_endline newdir;
+	    if dir = newdir then [] else find_project_file newdir
+      with Sys_error s ->
+	let newdir = Filename.dirname dir in
+	  if dir = newdir then [] else find_project_file newdir
+      in find_project_file (Filename.dirname file)
diff --git a/ide/tags.ml b/ide/tags.ml
index aacac46e..52ba54dc 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
-
 
 let make_tag (tt:GText.tag_table) ~name prop =
   let new_tag = GText.tag ~name () in
@@ -32,7 +30,7 @@ struct
   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" []
+  let sentence = make_tag table ~name:"sentence" []
 end
 module Proof =
 struct
diff --git a/ide/typed_notebook.ml b/ide/typed_notebook.ml
index 3dd2279f..499d56bd 100644
--- a/ide/typed_notebook.ml
+++ b/ide/typed_notebook.ml
@@ -1,68 +1,67 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqide.ml 11952 2009-03-02 15:29:08Z vgross $ *)
-
-class ['a] typed_notebook default_build nb =
+class ['a] typed_notebook make_page kill_page 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
+  method append_term (term:'a) =
+    let tab_label,menu_label,page = make_page 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
+    let lower,higher = Minilib.list_chop real_pos term_list in
       term_list <- lower@[term]@higher;
       real_pos
 (* XXX - Temporary hack to compile with archaic lablgtk
   method insert_term ?(build=default_build) ?pos (term:'a) =
     let tab_label,menu_label,page = build term in
     let real_pos = super#insert_page ?tab_label ?menu_label ?pos page in
-    let lower,higher = Util.list_split_at real_pos term_list in
+    let lower,higher = Minilib.list_chop 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
+  method prepend_term (term:'a) =
+    let tab_label,menu_label,page = make_page 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
+    let lower,higher = Minilib.list_chop 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
+  method set_term (term:'a) =
+    let tab_label,menu_label,page = make_page 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;
+      term_list <- Minilib.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
+    Minilib.list_index0 p term_list
 
   method pages = term_list
 
-  method current_term = List.nth term_list super#current_page
+  method remove_page index =
+    term_list <- Minilib.list_filter_i (fun i x -> if i = index then kill_page x; i <> index) term_list;
+    super#remove_page index
+
+  method current_term =
+    List.nth term_list super#current_page
 end
 
-let create build =
+let create make kill =
   GtkPack.Notebook.make_params []
     ~cont:(GContainer.pack_container
              ~create:(fun pl ->
                         let nb = GtkPack.Notebook.create pl in
-                         (new typed_notebook build nb)))
+                         (new typed_notebook make kill nb)))
 
diff --git a/ide/uim/coqide-custom.scm b/ide/uim/coqide-custom.scm
deleted file mode 100644
index 622f5063..00000000
--- a/ide/uim/coqide-custom.scm
+++ /dev/null
@@ -1,99 +0,0 @@
-;;; 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-latin-ltx
-	      (N_ "TeX")
-	      (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
deleted file mode 100644
index af25b613..00000000
--- a/ide/uim/coqide-rules.scm
+++ /dev/null
@@ -1,1142 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;  v      ;   The Coq Proof Assistant  /  The Coq Development Team     ;;
-;; <O___,, ;   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     ;;
-;;   \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-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
deleted file mode 100644
index 62355ac2..00000000
--- a/ide/uim/coqide.scm
+++ /dev/null
@@ -1,277 +0,0 @@
-;;; 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 55d0f288..57724297 100644
--- a/ide/undo.ml
+++ b/ide/undo.ml
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: undo.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open GText
 open Ideutils
+open GText
 type action =
   | Insert of string * int * int (* content*pos*length *)
   | Delete of string * int * int (* content*pos*length *)
diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli
index 1326a486..d9451fd1 100644
--- a/ide/undo_lablgtk_ge212.mli
+++ b/ide/undo_lablgtk_ge212.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_ge26.mli 7580 2005-11-18 17:09:10Z herbelin $ i*)
-
 (* An undoable view class *)
 
 class undoable_view : ([> Gtk.text_view] as 'a) Gtk.obj ->
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli
index 698b34c5..a2eb65bd 100644
--- a/ide/undo_lablgtk_ge26.mli
+++ b/ide/undo_lablgtk_ge26.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_ge26.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* An undoable view class *)
 
 class undoable_view : [> Gtk.text_view] Gtk.obj ->
diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli
index e99d3141..b193007b 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/ide/undo_lablgtk_lt26.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_lt26.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* An undoable view class *)
 
 class undoable_view : Gtk.text_view Gtk.obj ->
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index ce0c4836..d29ae0bd 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: utf8_convert.mll 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 {
   open Lexing
   let b = Buffer.create 127
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml
index d972639f..921d3d9c 100644
--- a/ide/utils/config_file.ml
+++ b/ide/utils/config_file.ml
@@ -23,8 +23,6 @@
 (*                                                                               *)
 (*********************************************************************************)
 
-(* $Id: config_file.ml 10348 2007-12-06 17:36:14Z aspiwack $ *)
-
 (* TODO *)
 (* section comments *)
 (* better obsoletes: no "{}", line cuts *)
diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml
index 05bf54eb..3ff60799 100644
--- a/ide/utils/configwin.ml
+++ b/ide/utils/configwin.ml
@@ -27,8 +27,8 @@ type parameter_kind = Configwin_types.parameter_kind
 
 type configuration_structure =
     Configwin_types.configuration_structure =
-    Section of string * parameter_kind list
-  | Section_list of string * configuration_structure list
+    Section of string * GtkStock.id option * parameter_kind list
+  | Section_list of string * GtkStock.id option * configuration_structure list
 
 type return_button =
     Configwin_types.return_button =
diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli
index bbfb7a04..c5fbf39a 100644
--- a/ide/utils/configwin.mli
+++ b/ide/utils/configwin.mli
@@ -32,10 +32,10 @@ type parameter_kind;;
 
 (** This type represents the structure of the configuration window. *)
 type configuration_structure =
-  | Section of string * parameter_kind list
-       (** label of the section, parameters *)
-  | Section_list of string * configuration_structure list
-       (** label of the section, list of the sub sections *)
+  | Section of string * GtkStock.id option * parameter_kind list
+       (** label of the section, icon, parameters *)
+  | Section_list of string * GtkStock.id option * configuration_structure list
+       (** label of the section, icon, list of the sub sections *)
 ;;
 
 (** To indicate what button pushed the user when the window is closed. *)
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml
index 3833acfa..9ddc90ef 100644
--- a/ide/utils/configwin_ihm.ml
+++ b/ide/utils/configwin_ihm.ml
@@ -29,6 +29,12 @@ open Configwin_types
 
 module O = Config_file
 
+class type widget =
+  object
+    method box : GObj.widget
+    method apply : unit -> unit
+  end
+
 let file_html_config = Filename.concat Configwin_messages.home ".configwin_html"
 
 let debug = false
@@ -320,17 +326,17 @@ class ['a] list_selection_box
       in
       let _ = dbg "list_selection_box: connecting wb_add" in
       (* connect the functions to the buttons *)
-      ignore (wb_add#connect#clicked f_add);
+      ignore (wb_add#connect#clicked ~callback:f_add);
       let _ = dbg "list_selection_box: connecting wb_remove" in
-      ignore (wb_remove#connect#clicked f_remove);
+      ignore (wb_remove#connect#clicked ~callback:f_remove);
       let _ = dbg "list_selection_box: connecting wb_up" in
-      ignore (wb_up#connect#clicked (fun () -> self#up_selected));
+      ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected));
       (
        match f_edit_opt with
 	 None -> ()
        | Some f ->
 	   let _ = dbg "list_selection_box: connecting wb_edit" in
-	   ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f))
+	   ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f))
       );
       (* connect the selection and deselection of items in the clist *)
       let f_select ~row ~column ~event =
@@ -350,9 +356,9 @@ class ['a] list_selection_box
       in
       (* connect the select and deselect events *)
       let _ = dbg "list_selection_box: connecting select_row" in
-      ignore(wlist#connect#select_row f_select);
+      ignore(wlist#connect#select_row ~callback:f_select);
       let _ = dbg "list_selection_box: connecting unselect_row" in
-      ignore(wlist#connect#unselect_row f_unselect);
+      ignore(wlist#connect#unselect_row ~callback:f_unselect);
 
       (* initialize the clist with the listref *)
       self#update !listref
@@ -393,38 +399,50 @@ class string_param_box param (tt:GData.tooltips) =
 
 (** This class is used to build a box for a combo parameter.*)
 class combo_param_box param (tt:GData.tooltips) =
-  let _ = dbg "combo_param_box" in
-  let hbox = GPack.hbox () in
-  let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
-  let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in
-  let wc = GEdit.combo
-      ~popdown_strings: param.combo_choices
-      ~value_in_list: (not param.combo_new_allowed)
-      (* ~allow_empty: param.combo_blank_allowed *)
-      ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
-      ()
-  in
-  let _ =
-    match param.combo_help with
-      None -> ()
-    | Some help ->
-	tt#set_tip ~text: help ~privat: help wev#coerce
-  in
-  let _ = wc#entry#set_editable param.combo_editable in
-  let _ = wc#entry#set_text param.combo_value in
-
-  object (self)
-    (** This method returns the main box ready to be packed. *)
-    method box = hbox#coerce
+    let _ = dbg "combo_param_box" in
+    let hbox = GPack.hbox () in
+    let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
+    let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in
+    let _ =
+      match param.combo_help with
+	  None -> ()
+	| Some help ->
+	    tt#set_tip ~text: help ~privat: help wev#coerce
+    in
+    let get_value = if not param.combo_new_allowed then
+      let wc = GEdit.combo_box_text
+	~strings: param.combo_choices
+	?active:(let rec aux i = function
+		   |[] -> None
+		   |h::_ when h = param.combo_value -> Some i
+		   |_::t -> aux (succ i) t
+		 in aux 0 param.combo_choices)
+	~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
+	()
+      in
+	fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s
+    else
+      let (wc,_) = GEdit.combo_box_entry_text
+	~strings: param.combo_choices
+	~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
+	()
+      in
+      let _ = wc#entry#set_editable param.combo_editable in
+      let _ = wc#entry#set_text param.combo_value in
+	fun () -> wc#entry#text
+    in
+object (self)
+  (** This method returns the main box ready to be packed. *)
+  method box = hbox#coerce
     (** This method applies the new value of the parameter. *)
-    method apply =
-      let new_value = wc#entry#text in
+  method apply =
+    let new_value = get_value () in
       if new_value <> param.combo_value then
 	let _ = param.combo_f_apply new_value in
-	param.combo_value <- new_value
+	  param.combo_value <- new_value
       else
 	()
-  end ;;
+end ;;
 
 (** Class used to pack a custom box. *)
 class custom_param_box param (tt:GData.tooltips) =
@@ -488,9 +506,9 @@ class color_param_box param (tt:GData.tooltips) =
     in
     let wb_ok = dialog#ok_button in
     let wb_cancel = dialog#cancel_button in
-    let _ = dialog#connect#destroy GMain.Main.quit in
+    let _ = dialog#connect#destroy ~callback:GMain.Main.quit in
     let _ = wb_ok#connect#clicked
-	(fun () ->
+	~callback:(fun () ->
 (*	  let color = dialog#colorsel#color in
 	  let r = (Gdk.Color.red color) in
 	  let g = (Gdk.Color.green color)in
@@ -505,11 +523,11 @@ class color_param_box param (tt:GData.tooltips) =
 	  dialog#destroy ()
 	)
     in
-    let _ = wb_cancel#connect#clicked dialog#destroy in
+    let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in
     GMain.Main.main ()
   in
   let _ =
-    if param.color_editable then ignore (wb#connect#clicked f_sel)
+    if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel)
   in
 
   object (self)
@@ -525,7 +543,7 @@ class color_param_box param (tt:GData.tooltips) =
 	()
 
     initializer
-      ignore (we#connect#changed (fun () -> set_color we#text));
+      ignore (we#connect#changed ~callback:(fun () -> set_color we#text));
 
   end ;;
 
@@ -573,19 +591,19 @@ class font_param_box param (tt:GData.tooltips) =
     dialog#selection#set_font_name !v;
     let wb_ok = dialog#ok_button in
     let wb_cancel = dialog#cancel_button in
-    let _ = dialog#connect#destroy GMain.Main.quit in
+    let _ = dialog#connect#destroy ~callback:GMain.Main.quit in
     let _ = wb_ok#connect#clicked
-	(fun () ->
+	~callback:(fun () ->
 	  let font = dialog#selection#font_name in
 	  we#set_text font ;
 	  set_entry_font (Some font);
 	  dialog#destroy ()
 	)
     in
-    let _ = wb_cancel#connect#clicked dialog#destroy in
+    let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in
     GMain.Main.main ()
   in
-  let _ = if param.font_editable then ignore (wb#connect#clicked f_sel) in
+  let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) in
 
   object (self)
     (** This method returns the main box ready to be packed. *)
@@ -730,7 +748,7 @@ class filename_param_box param (tt:GData.tooltips) =
   in
   let _ =
     if param.string_editable then
-      let _ = wb#connect#clicked f_click in
+      let _ = wb#connect#clicked ~callback:f_click in
       ()
     else
       ()
@@ -782,7 +800,7 @@ class hotkey_param_box param (tt:GData.tooltips) =
   in
   let _ =
     if param.hk_editable then
-      ignore (we#event#connect#key_press capture)
+      ignore (we#event#connect#key_press ~callback:capture)
     else
       ()
   in
@@ -811,7 +829,7 @@ class modifiers_param_box param =
                                   ~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
+                                ~callback:(fun _ -> if but#active then value := modifier::!value
                                  else value := List.filter ((<>) modifier) !value)))
             param.md_allow
   in
@@ -867,7 +885,7 @@ class date_param_box param (tt:GData.tooltips) =
   in
   let _ =
     if param.date_editable then
-      let _ = wb#connect#clicked f_click in
+      let _ = wb#connect#clicked ~callback:f_click in
       ()
     else
       ()
@@ -910,106 +928,179 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) =
       param.list_value <- !listref
   end ;;
 
-(** This class is used to build a box from a configuration structure
-   and adds the page to the given notebook. *)
-class configuration_box (tt:GData.tooltips) conf_struct (notebook : GPack.notebook) =
-  (* we build different widgets, according to the conf_struct parameter *)
-  let main_box = GPack.vbox () in
-  let (label, child_boxes) =
+(** This class creates a configuration box from a configuration structure *)
+class configuration_box (tt : GData.tooltips) conf_struct =
+
+  let main_box = GPack.hbox () in
+
+  let columns = new GTree.column_list in
+  let icon_col = columns#add GtkStock.conv in
+  let label_col = columns#add Gobject.Data.string in
+  let box_col = columns#add Gobject.Data.caml in
+  let () = columns#lock () in
+
+  let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in
+
+  (* Tree view part *)
+  let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in
+  let tree = GTree.tree_store columns in
+  let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in
+  let selection = view#selection in
+  let _ = selection#set_mode `SINGLE in
+
+  let menu_box = GPack.vbox ~packing:pane#pack2 () in
+
+  let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in
+  let col = GTree.view_column ~renderer () in
+  let _ = view#append_column col in
+
+  let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in
+  let col = GTree.view_column ~renderer () in
+  let _ = view#append_column col in
+
+  let make_param (main_box : #GPack.box) = function
+  | String_param p ->
+    let box = new string_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Combo_param p ->
+    let box = new combo_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Text_param p ->
+    let box = new text_param_box p tt in
+    let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
+    box
+  | Bool_param p ->
+    let box = new bool_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Filename_param p ->
+    let box = new filename_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | List_param f ->
+    let box = f tt in
+    let _ = main_box#pack ~expand: true ~padding: 2 box#box in
+    box
+  | Custom_param p ->
+    let box = new custom_param_box p tt in
+    let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
+    box
+  | Color_param p ->
+    let box = new color_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Font_param p ->
+    let box = new font_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Date_param p ->
+    let box = new date_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Hotkey_param p ->
+    let box = new hotkey_param_box p tt in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Modifiers_param p ->
+    let box = new modifiers_param_box p in
+    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+    box
+  | Html_param p ->
+    let box = new html_param_box p tt in
+    let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
+    box
+  in
+
+  let set_icon iter = function
+  | None -> ()
+  | Some icon -> tree#set iter icon_col icon
+  in
+
+  (* Populate the tree *)
+
+  let rec make_tree iter conf_struct =
+    (* box is not shown at first *)
+    let box = GPack.vbox ~packing:menu_box#add ~show:false () in
+    let new_iter = match iter with
+    | None -> tree#append ()
+    | Some parent -> tree#append ~parent ()
+    in
     match conf_struct with
-      Section (label, param_list) ->
-	let f parameter =
-	  match parameter with
-	    String_param p ->
-	      let box = new string_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Combo_param p ->
-	      let box = new combo_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Text_param p ->
-	      let box = new text_param_box p tt in
-	      let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
-	      box
-	  | Bool_param p ->
-	      let box = new bool_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Filename_param p ->
-	      let box = new filename_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | List_param f ->
-	      let box = f tt in
-	      let _ = main_box#pack ~expand: true ~padding: 2 box#box in
-	      box
-	  | Custom_param p ->
-	      let box = new custom_param_box p tt in
-	      let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
-	      box
-	  | Color_param p ->
-	      let box = new color_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Font_param p ->
-	      let box = new font_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Date_param p ->
-	      let box = new date_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Hotkey_param p ->
-	      let box = new hotkey_param_box p tt in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-	      box
-	  | Modifiers_param p ->
-	      let box = new modifiers_param_box p in
-	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		box
-	  | Html_param p ->
-	      let box = new html_param_box p tt in
-	      let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
-	      box
-	in
-	let list_children_boxes = List.map f param_list in
-
-	(label, list_children_boxes)
-
-    | Section_list (label, struct_list) ->
-	let wnote = GPack.notebook
-            (*homogeneous_tabs: true*)
-	    ~scrollable: true
-	    ~show_tabs: true
-	    ~tab_border: 3
-	    ~packing: (main_box#pack ~expand: true)
-	    ()
-	in
-	(* we create all the children boxes *)
-	let f structure =
-	  let new_box = new configuration_box tt structure wnote in
-	  new_box
-	in
-	let list_child_boxes = List.map f struct_list in
-	(label, list_child_boxes)
+    | Section (label, icon, param_list) ->
+      let params = List.map (make_param box) param_list in
+      let widget =
+        object
+          method box = box#coerce
+          method apply () = List.iter (fun param -> param#apply) params
+        end
+      in
+      let () = tree#set new_iter label_col label in
+      let () = set_icon new_iter icon in
+      let () = tree#set new_iter box_col widget in
+      ()
+    | Section_list (label, icon, struct_list) ->
+      let widget =
+        object
+      (* Section_list does not contain any effect widget, so we do not have to
+         apply anything. *)
+          method apply () = ()
+          method box = box#coerce
+        end
+      in
+      let () = tree#set new_iter label_col label in
+      let () = set_icon new_iter icon in
+      let () = tree#set new_iter box_col widget in
+      List.iter (make_tree (Some new_iter)) struct_list
+  in
+
+  let () = List.iter (make_tree None) conf_struct in
+
+  (* Dealing with signals *)
+
+  let current_prop : widget option ref = ref None in
+
+  let select_iter iter =
+    let () = match !current_prop with
+    | None -> ()
+    | Some box -> box#box#misc#hide ()
+    in
+    let box = tree#get ~row:iter ~column:box_col in
+    let () = box#box#misc#show () in
+    current_prop := Some box
+  in
 
+  let when_selected () =
+    let rows = selection#get_selected_rows in
+    match rows with
+    | [] -> ()
+    | row :: _ ->
+      let iter = tree#get_iter row in
+      select_iter iter
   in
-  let page_label = GMisc.label ~text: label () in
-  let _ = notebook#append_page
-      ~tab_label: page_label#coerce
-      main_box#coerce
+
+  (* Focus on a box when selected *)
+
+  let _ = selection#connect#changed ~callback:when_selected in
+
+  let _ = match tree#get_iter_first with
+  | None -> ()
+  | Some iter -> select_iter iter
   in
 
-  object (self)
-    (** This method returns the main box ready to be packed. *)
-    method box = main_box#coerce
-    (** This method make the new values of the paramters applied, recursively in
-       all boxes.*)
+  object
+
+    method box = main_box
+
     method apply =
-      List.iter (fun box -> box#apply) child_boxes
+      let foreach _ iter =
+        let widget = tree#get ~row:iter ~column:box_col in
+        widget#apply(); false
+      in
+      tree#foreach foreach
+
   end
-;;
 
 (** Create a vbox with the list of given configuration structure list,
    and the given list of buttons (defined by their label and callback).
@@ -1017,24 +1108,12 @@ class configuration_box (tt:GData.tooltips) conf_struct (notebook : GPack.notebo
    of each parameter is called.
 *)
 let tabbed_box conf_struct_list buttons tooltips =
-  let vbox = GPack.vbox () in
-  let wnote = GPack.notebook
-      (*homogeneous_tabs: true*)
-      ~scrollable: true
-      ~show_tabs: true
-      ~tab_border: 3
-      ~packing: (vbox#pack ~expand: true)
-      ()
+  let param_box =
+       new configuration_box tooltips conf_struct_list
   in
-  let list_param_box =
-    List.map
-      (fun conf_struct -> new configuration_box tooltips conf_struct wnote)
-      conf_struct_list
+  let f_apply () = param_box#apply
   in
-  let f_apply () =
-    List.iter (fun param_box -> param_box#apply) list_param_box  ;
-  in
-  let hbox_buttons = GPack.hbox ~packing: (vbox#pack ~expand: false ~padding: 4) () in
+  let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in
   let rec iter_buttons ?(grab=false) = function
       [] ->
         ()
@@ -1051,14 +1130,14 @@ let tabbed_box conf_struct_list buttons tooltips =
   in
   iter_buttons ~grab: true buttons;
 
-  vbox
+  param_box#box
 
 (** This function takes a configuration structure list and creates a window
    to configure the various parameters. *)
 let edit ?(with_apply=true)
     ?(apply=(fun () -> ()))
     title ?(width=400) ?(height=400)
-    conf_struct_list =
+    conf_struct =
   let dialog = GWindow.dialog
     ~position:`CENTER
     ~modal: true ~title: title
@@ -1066,47 +1145,34 @@ let edit ?(with_apply=true)
     ()
   in
   let tooltips = GData.tooltips () in
-  let wnote = GPack.notebook
-    (*homogeneous_tabs: true*)
-    ~scrollable: true
-    ~show_tabs: true
-    ~tab_border: 3
-    ~packing: (dialog#vbox#pack ~expand: true)
-    ()
-  in
-  let list_param_box =
-    List.map
-      (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;
+  let config_box = new configuration_box tooltips conf_struct in
 
-    dialog#add_button Configwin_messages.mOk `OK;
-    dialog#add_button Configwin_messages.mCancel `CANCEL;
+  let _ = dialog#vbox#add config_box#box#coerce in
 
-    let f_apply () =
-      List.iter (fun param_box -> param_box#apply) list_param_box  ;
-      apply ()
-    in
-    let destroy () =
-      tooltips#destroy () ;
-      dialog#destroy ();
-    in
-    let rec iter rep =
-      try
-	match dialog#run () with
-	  | `APPLY  -> f_apply (); iter Return_apply
-	  | `OK -> f_apply (); destroy (); Return_ok
-	  | _ -> destroy (); rep
-      with
-	  Failure s ->
-	    GToolbox.message_box "Error" s; iter rep
-	| e ->
-	    GToolbox.message_box "Error" (Printexc.to_string e); iter rep
-    in
-      iter Return_cancel
+  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 destroy () =
+    tooltips#destroy () ;
+    dialog#destroy ();
+  in
+  let rec iter rep =
+    try
+      match dialog#run () with
+        | `APPLY  -> config_box#apply; iter Return_apply
+        | `OK -> config_box#apply; destroy (); Return_ok
+        | _ -> destroy (); rep
+    with
+        Failure s ->
+          GToolbox.message_box ~title:"Error" s; iter rep
+      | e ->
+          GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep
+  in
+    iter Return_cancel
 
 (** Create a vbox with the list of given parameters. *)
 let box param_list tt =
@@ -1205,9 +1271,9 @@ let simple_edit ?(with_apply=true)
       | _ -> destroy (); rep
     with
       Failure s ->
-	GToolbox.message_box "Error" s; iter rep
+	GToolbox.message_box ~title:"Error" s; iter rep
     | e ->
-	GToolbox.message_box "Error" (Printexc.to_string e); iter rep
+	GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep
   in
   iter Return_cancel
 
diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml
index 26f5b61b..de292431 100644
--- a/ide/utils/configwin_messages.ml
+++ b/ide/utils/configwin_messages.ml
@@ -30,7 +30,7 @@ let version = "1.2";;
 
 let html_config = "Configwin bindings configurator for html parameters"
 
-let home = System.home
+let home = Minilib.home
 
 let mCapture = "Capture";;
 let mType_key = "Type key" ;;
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
index 90d5756b..5e2b1e7c 100644
--- a/ide/utils/configwin_types.ml
+++ b/ide/utils/configwin_types.ml
@@ -263,8 +263,8 @@ type parameter_kind =
 
 (** This type represents the structure of the configuration window. *)
 type configuration_structure =
-  | Section of string * parameter_kind list (** label of the section, parameters *)
-  | Section_list of string * configuration_structure list (** label of the section, list of the sub sections *)
+  | Section of string * GtkStock.id option * parameter_kind list (** label of the section, icon, parameters *)
+  | Section_list of string * GtkStock.id option * configuration_structure list (** label of the section, list of the sub sections *)
 ;;
 
 (** To indicate what button was pushed by the user when the window is closed. *)
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index dc339622..193b38dd 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrextern.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Pp
 open Util
@@ -23,7 +21,7 @@ open Environ
 open Libnames
 open Impargs
 open Topconstr
-open Rawterm
+open Glob_term
 open Pattern
 open Nametab
 open Notation
@@ -31,7 +29,7 @@ open Reserve
 open Detyping
 (*i*)
 
-(* Translation from rawconstr to front constr *)
+(* Translation from glob_constr to front constr *)
 
 (**********************************************************************)
 (* Parametrization                                                    *)
@@ -76,6 +74,49 @@ let without_symbols f = Flags.with_option print_no_symbol f
 let with_meta_as_hole f = Flags.with_option print_meta_as_hole f
 
 (**********************************************************************)
+(* Control printing of records *)
+
+let is_record indsp =
+  try
+    let _ = Recordops.lookup_structure indsp in
+    true
+  with Not_found -> false
+
+let encode_record r =
+  let indsp = global_inductive r in
+  if not (is_record indsp) then
+    user_err_loc (loc_of_reference r,"encode_record",
+    str "This type is not a structure type.");
+  indsp
+
+module PrintingRecordRecord =
+  PrintingInductiveMake (struct
+    let encode = encode_record
+    let field = "Record"
+    let title = "Types leading to pretty-printing using record notation: "
+    let member_message s b =
+      str "Terms of " ++ s ++
+      str
+      (if b then " are printed using record notation"
+      else " are not printed using record notation")
+  end)
+
+module PrintingRecordConstructor =
+  PrintingInductiveMake (struct
+    let encode = encode_record
+    let field = "Constructor"
+    let title = "Types leading to pretty-printing using constructor form: "
+    let member_message s b =
+      str "Terms of " ++ s ++
+      str
+      (if b then " are printed using constructor form"
+      else " are not printed using constructor form")
+  end)
+
+module PrintingRecord = Goptions.MakeRefTable(PrintingRecordRecord)
+module PrintingConstructor = Goptions.MakeRefTable(PrintingRecordConstructor)
+
+(**********************************************************************)
 (* Various externalisation functions *)
 
 let insert_delimiters e = function
@@ -117,6 +158,8 @@ let rec check_same_pattern p1 p2 =
         check_same_pattern a1 a2
     | CPatCstr(_,c1,a1), CPatCstr(_,c2,a2) when c1=c2 ->
         List.iter2 check_same_pattern a1 a2
+    | CPatCstrExpl(_,c1,a1), CPatCstrExpl(_,c2,a2) when c1=c2 ->
+        List.iter2 check_same_pattern a1 a2
     | CPatAtom(_,r1), CPatAtom(_,r2) when r1=r2 -> ()
     | CPatPrim(_,i1), CPatPrim(_,i2) when i1=i2 -> ()
     | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 ->
@@ -204,82 +247,13 @@ and check_same_fix_binder bl1 bl2 =
 
 let same c d = try check_same_type c d; true with _ -> false
 
-(* Idem for rawconstr *)
-
-let array_iter2 f v1 v2 =
-  List.iter2 f (Array.to_list v1) (Array.to_list v2)
-
-let rec same_patt p1 p2 =
-  match p1, p2 with
-      PatVar(_,na1), PatVar(_,na2) -> if na1<>na2 then failwith "PatVar"
-    | PatCstr(_,c1,pl1,al1), PatCstr(_,c2,pl2,al2) ->
-        if c1<>c2 || al1 <> al2 then failwith "PatCstr";
-        List.iter2 same_patt pl1 pl2
-    | _ -> failwith "same_patt"
-
-let rec same_raw c d =
-  match c,d with
-   | RRef(_,gr1), RRef(_,gr2) -> if gr1<>gr2 then failwith "RRef"
-   | RVar(_,id1), RVar(_,id2) -> if id1<>id2 then failwith "RVar"
-   | REvar(_,e1,a1), REvar(_,e2,a2) ->
-       if e1 <> e2 then failwith "REvar";
-       Option.iter2(List.iter2 same_raw) a1 a2
-  | RPatVar(_,pv1), RPatVar(_,pv2) -> if pv1<>pv2 then failwith "RPatVar"
-  | RApp(_,f1,a1), RApp(_,f2,a2) ->
-      List.iter2 same_raw (f1::a1) (f2::a2)
-  | RLambda(_,na1,bk1,t1,m1), RLambda(_,na2,bk2,t2,m2) ->
-      if na1 <> na2 then failwith "RLambda";
-      same_raw t1 t2; same_raw m1 m2
-  | RProd(_,na1,bk1,t1,m1), RProd(_,na2,bk2,t2,m2) ->
-      if na1 <> na2 then failwith "RProd";
-      same_raw t1 t2; same_raw m1 m2
-  | RLetIn(_,na1,t1,m1), RLetIn(_,na2,t2,m2) ->
-      if na1 <> na2 then failwith "RLetIn";
-      same_raw t1 t2; same_raw m1 m2
-  | RCases(_,_,_,c1,b1), RCases(_,_,_,c2,b2) ->
-      List.iter2
-        (fun (t1,(al1,oind1)) (t2,(al2,oind2)) ->
-          same_raw t1 t2;
-          if al1 <> al2 then failwith "RCases";
-          Option.iter2(fun (_,i1,_,nl1) (_,i2,_,nl2) ->
-            if i1<>i2 || nl1 <> nl2 then failwith "RCases") oind1 oind2) c1 c2;
-      List.iter2 (fun (_,_,pl1,b1) (_,_,pl2,b2) ->
-        List.iter2 same_patt pl1 pl2;
-        same_raw b1 b2) b1 b2
-  | RLetTuple(_,nl1,_,b1,c1), RLetTuple(_,nl2,_,b2,c2) ->
-      if nl1<>nl2 then failwith "RLetTuple";
-      same_raw b1 b2;
-      same_raw c1 c2
-  | RIf(_,b1,_,t1,e1),RIf(_,b2,_,t2,e2) ->
-      same_raw b1 b2; same_raw t1 t2; same_raw e1 e2
-  | RRec(_,fk1,na1,bl1,ty1,def1), RRec(_,fk2,na2,bl2,ty2,def2) ->
-      if fk1 <> fk2 || na1 <> na2 then failwith "RRec";
-      array_iter2
-        (List.iter2 (fun (na1,bk1,bd1,ty1) (na2,bk2,bd2,ty2) ->
-          if na1<>na2 then failwith "RRec";
-          Option.iter2 same_raw bd1 bd2;
-          same_raw ty1 ty2)) bl1 bl2;
-      array_iter2 same_raw ty1 ty2;
-      array_iter2 same_raw def1 def2
-  | RSort(_,s1), RSort(_,s2) -> if s1<>s2 then failwith "RSort"
-  | RHole _, _ -> ()
-  | _, RHole _ -> ()
-  | RCast(_,c1,_),r2 -> same_raw c1 r2
-  | 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 =
-  try same_raw c d; true
-  with Failure _ | Invalid_argument _ -> false
-
 (**********************************************************************)
 (* mapping patterns to cases_pattern_expr                                *)
 
 let has_curly_brackets ntn =
   String.length ntn >= 6 & (String.sub ntn 0 6 = "{ _ } " or
     String.sub ntn (String.length ntn - 6) 6 = " { _ }" or
-    string_string_contains ntn " { _ } ")
+    string_string_contains ~where:ntn ~what:" { _ } ")
 
 let rec wildcards ntn n =
   if n = String.length ntn then []
@@ -347,7 +321,7 @@ let mkPat loc qid l =
   (* Normally irrelevant test with v8 syntax, but let's do it anyway *)
   if l = [] then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,l)
 
- (* Better to use extern_rawconstr composed with injection/retraction ?? *)
+ (* Better to use extern_glob_constr composed with injection/retraction ?? *)
 let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
   try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
@@ -370,7 +344,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
       let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
       let p =
 	try
-	  if !Flags.raw_print then raise Exit;
+          if !Flags.raw_print then raise Exit;
 	  let projs = Recordops.lookup_projections (fst cstrsp) in
 	  let rec ip projs args acc =
 	    match projs with
@@ -464,8 +438,11 @@ let is_projection nargs = function
 
 let is_hole = function CHole _ -> true | _ -> false
 
-let is_significant_implicit a impl tail =
-  not (is_hole a) or (tail = [] & not (List.for_all is_status_implicit impl))
+let is_significant_implicit a =
+  not (is_hole a)
+
+let is_needed_for_correct_partial_application tail imp =
+  tail = [] & not (maximal_insertion_of imp)
 
 (* Implicit args indexes are in ascending order *)
 (* inctx is useful only if there is a last argument to be deduced from ctxt *)
@@ -477,8 +454,9 @@ let explicitize loc inctx impl (cf,f) args =
         let visible =
           !Flags.raw_print or
           (!print_implicits & !print_implicits_explicit_args) or
+          (is_needed_for_correct_partial_application tail imp) or
 	  (!print_implicits_defensive &
-	   is_significant_implicit a impl tail &
+	   is_significant_implicit a &
 	   not (is_inferable_implicit inctx n imp))
 	in
         if visible then
@@ -532,7 +510,7 @@ let rec extern_args extern scopes env args subscopes =
 	extern argscopes env a :: extern_args extern scopes env args subscopes
 
 let rec remove_coercions inctx = function
-  | RApp (loc,RRef (_,r),args) as c
+  | GApp (loc,GRef (_,r),args) as c
       when  not (!Flags.raw_print or !print_coercions)
       ->
       let nargs = List.length args in
@@ -551,22 +529,17 @@ let rec remove_coercions inctx = function
 		 been confused with ordinary application or would have need
                  a surrounding context and the coercion to funclass would
                  have been made explicit to match *)
-	      if l = [] then a' else RApp (loc,a',l)
+	      if l = [] then a' else GApp (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))
+  | GApp (loc,GApp(_,a,l'),l) -> flatten_application (GApp (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
-
 (**********************************************************************)
-(* mapping rawterms to numerals (in presence of coercions, choose the *)
+(* mapping glob_constr to numerals (in presence of coercions, choose the *)
 (* one with no delimiter if possible)                                 *)
 
 let extern_possible_prim_token scopes r =
@@ -574,7 +547,7 @@ let extern_possible_prim_token scopes r =
     let (sc,n) = uninterp_prim_token r in
     match availability_of_prim_token n sc scopes with
     | None -> None
-    | Some key -> Some (insert_delimiters (CPrim (loc_of_rawconstr r,n)) key)
+    | Some key -> Some (insert_delimiters (CPrim (loc_of_glob_constr r,n)) key)
   with No_match ->
     None
 
@@ -586,12 +559,12 @@ let extern_optimal_prim_token scopes r r' =
   | _ -> raise No_match
 
 (**********************************************************************)
-(* mapping rawterms to constr_expr                                    *)
+(* mapping glob_constr to constr_expr                                    *)
 
-let extern_rawsort = function
-  | RProp _ as s -> s
-  | RType (Some _) as s when !print_universes -> s
-  | RType _ -> RType None
+let extern_glob_sort = function
+  | GProp _ as s -> s
+  | GType (Some _) as s when !print_universes -> s
+  | GType _ -> GType None
 
 let rec extern inctx scopes vars r =
   let r' = remove_coercions inctx r in
@@ -604,31 +577,37 @@ let rec extern inctx scopes vars r =
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     extern_symbol scopes vars r'' (uninterp_notations r'')
   with No_match -> match r' with
-  | RRef (loc,ref) ->
+  | GRef (loc,ref) ->
       extern_global loc (select_stronger_impargs (implicits_of_global ref))
         (extern_reference loc vars ref)
 
-  | RVar (loc,id) -> CRef (Ident (loc,id))
+  | GVar (loc,id) -> CRef (Ident (loc,id))
 
-  | REvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None)
+  | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None)
 
-  | REvar (loc,n,l) ->
+  | GEvar (loc,n,l) ->
       extern_evar loc n (Option.map (List.map (extern false scopes vars)) l)
 
-  | RPatVar (loc,n) ->
+  | GPatVar (loc,n) ->
       if !print_meta_as_hole then CHole (loc, None) else CPatVar (loc,n)
 
-  | RApp (loc,f,args) ->
+  | GApp (loc,f,args) ->
       (match f with
-	 | RRef (rloc,ref) ->
+	 | GRef (rloc,ref) ->
 	     let subscopes = find_arguments_scope ref in
 	     let args =
 	       extern_args (extern true) (snd scopes) vars args subscopes in
 	     begin
 	       try
-		 if !Flags.raw_print then raise Exit;
+                 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
+                 if PrintingRecord.active (fst cstrsp) then
+                   ()
+                 else if PrintingConstructor.active (fst cstrsp) then
+                   raise Exit
+                 else if not !Flags.record_print then
+                   raise Exit;
 		 let projs = struc.Recordops.s_PROJ in
 		 let locals = struc.Recordops.s_PROJKIND in
 		 let rec cut args n =
@@ -666,66 +645,66 @@ let rec extern inctx scopes vars r =
 	     explicitize loc inctx [] (None,sub_extern false scopes vars f)
                (List.map (sub_extern true scopes vars) args))
 
-  | RProd (loc,Anonymous,_,t,c) ->
+  | GProd (loc,Anonymous,_,t,c) ->
       (* Anonymous product are never factorized *)
       CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c)
 
-  | RLetIn (loc,na,t,c) ->
+  | GLetIn (loc,na,t,c) ->
       CLetIn (loc,(loc,na),sub_extern false scopes vars t,
               extern inctx scopes (add_vname vars na) c)
 
-  | RProd (loc,na,bk,t,c) ->
+  | GProd (loc,na,bk,t,c) ->
       let t = extern_typ scopes vars (anonymize_if_reserved na t) in
       let (idl,c) = factorize_prod scopes (add_vname vars na) t c in
       CProdN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
 
-  | RLambda (loc,na,bk,t,c) ->
+  | GLambda (loc,na,bk,t,c) ->
       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) ->
+  | GCases (loc,sty,rtntypopt,tml,eqns) ->
       let vars' =
 	List.fold_right (name_fold Idset.add)
 	  (cases_predicate_names tml) vars in
       let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in
       let tml = List.map (fun (tm,(na,x)) ->
         let na' = match na,tm with
-            Anonymous, RVar (_,id) when
-              rtntypopt<>None & occur_rawconstr id (Option.get rtntypopt)
+            Anonymous, GVar (_,id) when
+              rtntypopt<>None & occur_glob_constr id (Option.get rtntypopt)
               -> Some (dummy_loc,Anonymous)
           | Anonymous, _ -> None
-          | Name id, RVar (_,id') when id=id' -> None
+          | Name id, GVar (_,id') when id=id' -> None
           | Name _, _ -> Some (dummy_loc,na) in
 	(sub_extern false scopes vars tm,
 	(na',Option.map (fun (loc,ind,n,nal) ->
 	  let params = list_tabulate
-	    (fun _ -> RHole (dummy_loc,Evd.InternalHole)) n in
+	    (fun _ -> GHole (dummy_loc,Evd.InternalHole)) n in
 	  let args = List.map (function
-	    | 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
+	    | Anonymous -> GHole (dummy_loc,Evd.InternalHole)
+	    | Name id -> GVar (dummy_loc,id)) nal in
+	  let t = GApp (dummy_loc,GRef (dummy_loc,IndRef ind),params@args) in
 	  (extern_typ scopes vars t)) x))) tml in
       let eqns = List.map (extern_eqn inctx scopes vars) eqns in
       CCases (loc,sty,rtntypopt',tml,eqns)
 
-  | RLetTuple (loc,nal,(na,typopt),tm,b) ->
+  | GLetTuple (loc,nal,(na,typopt),tm,b) ->
       CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal,
         (Option.map (fun _ -> (dummy_loc,na)) typopt,
          Option.map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern false scopes vars tm,
         extern inctx scopes (List.fold_left add_vname vars nal) b)
 
-  | RIf (loc,c,(na,typopt),b1,b2) ->
+  | GIf (loc,c,(na,typopt),b1,b2) ->
       CIf (loc,sub_extern false scopes vars c,
         (Option.map (fun _ -> (dummy_loc,na)) typopt,
          Option.map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2)
 
-  | RRec (loc,fk,idv,blv,tyv,bv) ->
+  | GRec (loc,fk,idv,blv,tyv,bv) ->
       let vars' = Array.fold_right Idset.add idv vars in
       (match fk with
-	 | RFix (nv,n) ->
+	 | GFix (nv,n) ->
 	     let listdecl =
 	       Array.mapi (fun i fi ->
                  let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
@@ -742,7 +721,7 @@ let rec extern inctx scopes vars r =
                   extern false scopes vars1 def)) idv
 	     in
 	     CFix (loc,(loc,idv.(n)),Array.to_list listdecl)
-	 | RCoFix n ->
+	 | GCoFix n ->
 	     let listdecl =
                Array.mapi (fun i fi ->
                  let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in
@@ -753,17 +732,15 @@ let rec extern inctx scopes vars r =
 	     in
 	     CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl))
 
-  | RSort (loc,s) -> CSort (loc,extern_rawsort s)
+  | GSort (loc,s) -> CSort (loc,extern_glob_sort s)
 
-  | RHole (loc,e) -> CHole (loc, Some e)
+  | GHole (loc,e) -> CHole (loc, Some e)
 
-  | RCast (loc,c, CastConv (k,t)) ->
+  | GCast (loc,c, CastConv (k,t)) ->
       CCast (loc,sub_extern true scopes vars c, CastConv (k,extern_typ scopes vars t))
-  | RCast (loc,c, CastCoerce) ->
+  | GCast (loc,c, CastCoerce) ->
       CCast (loc,sub_extern true scopes vars c, CastCoerce)
 
-  | RDynamic (loc,d) -> CDynamic (loc,d)
-
 and extern_typ (_,scopes) =
   extern true (Some Notation.type_scope,scopes)
 
@@ -774,7 +751,7 @@ and factorize_prod scopes vars aty c =
     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
-  | RProd (loc,(Name id as na),bk,ty,c)
+  | GProd (loc,(Name id as na),bk,ty,c)
       when same aty (extern_typ scopes vars (anonymize_if_reserved na ty))
 	& not (occur_var_constr_expr id aty) (* avoid na in ty escapes scope *)
 	-> let (nal,c) = factorize_prod scopes (Idset.add id vars) aty c in
@@ -786,7 +763,7 @@ and factorize_lambda inctx scopes vars aty c =
     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
-  | RLambda (loc,na,bk,ty,c)
+  | GLambda (loc,na,bk,ty,c)
       when same aty (extern_typ scopes vars (anonymize_if_reserved na ty))
 	& not (occur_name na aty) (* To avoid na in ty' escapes scope *)
 	-> let (nal,c) =
@@ -822,33 +799,40 @@ and extern_eqn inctx scopes vars (loc,ids,pl,c) =
 and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
-      let loc = Rawterm.loc_of_rawconstr t in
+      let loc = Glob_term.loc_of_glob_constr t in
       try
 	(* Adjusts to the number of arguments expected by the notation *)
 	let (t,args,argsscopes,argsimpls) = match t,n with
-	  | RApp (_,(RRef (_,ref) as f),args), Some n
+	  | GApp (_,f,args), Some n
 	      when List.length args >= n ->
 	      let args1, args2 = list_chop n args in
-	      let subscopes =
-		try list_skipn n (find_arguments_scope ref) with _ -> [] in
-	      let impls =
-		let impls =
-		  select_impargs_size
-		    (List.length args) (implicits_of_global ref) in
-		try list_skipn n impls with _ -> [] in
-	      (if n = 0 then f else RApp (dummy_loc,f,args1)),
+              let subscopes, impls =
+                match f with
+                | GRef (_,ref) ->
+	          let subscopes =
+		    try list_skipn n (find_arguments_scope ref) with _ -> [] in
+	          let impls =
+		    let impls =
+		      select_impargs_size
+		        (List.length args) (implicits_of_global ref) in
+		    try list_skipn n impls with _ -> [] in
+                  subscopes,impls
+                | _ ->
+                  [], [] in
+	      (if n = 0 then f else GApp (dummy_loc,f,args1)),
 	      args2, subscopes, impls
-	  | RApp (_,(RRef (_,ref) as f),args), None ->
+	  | GApp (_,(GRef (_,ref) as f),args), None ->
 	      let subscopes = find_arguments_scope ref in
 	      let impls =
 		  select_impargs_size
 		    (List.length args) (implicits_of_global ref) in
 	      f, args, subscopes, impls
-	  | RRef _, Some 0 -> RApp (dummy_loc,t,[]), [], [], []
+	  | GRef _, Some 0 -> GApp (dummy_loc,t,[]), [], [], []
           | _, None -> t, [], [], []
           | _ -> raise No_match in
 	(* Try matching ... *)
-	let terms,termlists,binders = match_aconstr t pat in
+	let terms,termlists,binders =
+          match_aconstr !print_universes t pat in
 	(* Try availability of interpretation ... *)
         let e =
           match keyrule with
@@ -888,16 +872,16 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
 	  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 (m,r) -> CMeasureRec (extern true scopes vars m,
+    GStructRec -> CStructRec
+  | GWfRec c -> CWfRec (extern true scopes vars c)
+  | GMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m,
 				     Option.map (extern true scopes vars) r)
 
 
-let extern_rawconstr vars c =
+let extern_glob_constr vars c =
   extern false (None,[]) vars c
 
-let extern_rawtype vars c =
+let extern_glob_type vars c =
   extern_typ (None,[]) vars c
 
 (******************************************************************)
@@ -920,89 +904,70 @@ let extern_constr at_top env t =
 let extern_type at_top env t =
   let avoid = if at_top then ids_of_context env else [] in
   let r = Detyping.detype at_top avoid (names_of_rel_context env) t in
-  extern_rawtype (vars_of_env env) r
+  extern_glob_type (vars_of_env env) r
 
-let extern_sort s = extern_rawsort (detype_sort s)
+let extern_sort s = extern_glob_sort (detype_sort s)
 
 (******************************************************************)
 (* Main translation function from pattern -> constr_expr *)
 
-let rec raw_of_pat env = function
-  | PRef ref -> RRef (loc,ref)
-  | PVar id -> RVar (loc,id)
-  | PEvar (n,l) -> REvar (loc,n,Some (array_map_to_list (raw_of_pat env) l))
+let any_any_branch =
+  (* | _ => _ *)
+  (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evd.InternalHole))
+
+let rec glob_of_pat env = function
+  | PRef ref -> GRef (loc,ref)
+  | PVar id -> GVar (loc,id)
+  | PEvar (n,l) -> GEvar (loc,n,Some (array_map_to_list (glob_of_pat env) l))
   | PRel n ->
       let id = try match lookup_name_of_rel n env with
 	| Name id   -> id
 	| Anonymous ->
-	    anomaly "rawconstr_of_pattern: index to an anonymous variable"
+	    anomaly "glob_constr_of_pattern: index to an anonymous variable"
       with Not_found -> id_of_string ("_UNBOUND_REL_"^(string_of_int n)) in
-      RVar (loc,id)
-  | PMeta None -> RHole (loc,Evd.InternalHole)
-  | PMeta (Some n) -> RPatVar (loc,(false,n))
+      GVar (loc,id)
+  | PMeta None -> GHole (loc,Evd.InternalHole)
+  | PMeta (Some n) -> GPatVar (loc,(false,n))
   | PApp (f,args) ->
-      RApp (loc,raw_of_pat env f,array_map_to_list (raw_of_pat env) args)
+      GApp (loc,glob_of_pat env f,array_map_to_list (glob_of_pat env) args)
   | PSoApp (n,args) ->
-      RApp (loc,RPatVar (loc,(true,n)),
-        List.map (raw_of_pat env) args)
+      GApp (loc,GPatVar (loc,(true,n)),
+        List.map (glob_of_pat env) args)
   | PProd (na,t,c) ->
-      RProd (loc,na,Explicit,raw_of_pat env t,raw_of_pat (na::env) c)
+      GProd (loc,na,Explicit,glob_of_pat env t,glob_of_pat (na::env) c)
   | PLetIn (na,t,c) ->
-      RLetIn (loc,na,raw_of_pat env t, raw_of_pat (na::env) c)
+      GLetIn (loc,na,glob_of_pat env t, glob_of_pat (na::env) c)
   | PLambda (na,t,c) ->
-      RLambda (loc,na,Explicit,raw_of_pat env t, raw_of_pat (na::env) c)
+      GLambda (loc,na,Explicit,glob_of_pat env t, glob_of_pat (na::env) c)
   | PIf (c,b1,b2) ->
-      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
-      RLetTuple (loc,nal,(Anonymous,None),raw_of_pat env tm,b)
-  | PCase (_,PMeta None,tm,[||]) ->
-      RCases (loc,RegularStyle,None,[raw_of_pat env tm,(Anonymous,None)],[])
-  | PCase ((_,cstr_nargs,indo,ind_nargs),p,tm,bv) ->
-      let brs = Array.to_list (Array.map (raw_of_pat env) bv) in
-      let brns = Array.to_list cstr_nargs in
-        (* ind is None only if no branch and no return type *)
-      let ind = Option.get indo in
-      let mat = simple_cases_matrix_of_branches ind brns brs in
-      let indnames,rtn =
-	if p = PMeta None then (Anonymous,None),None
-	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)
+      GIf (loc, glob_of_pat env c, (Anonymous,None),
+           glob_of_pat env b1, glob_of_pat env b2)
+  | PCase ({cip_style=LetStyle; cip_ind_args=None},PMeta None,tm,[(0,n,b)]) ->
+      let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env b) in
+      GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env tm,b)
+  | PCase (info,p,tm,bl) ->
+      let mat = match bl, info.cip_ind with
+	| [], _ -> []
+	| _, Some ind ->
+	  let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env c)) bl in
+	  simple_cases_matrix_of_branches ind bl'
+	| _, None -> anomaly "PCase with some branches but unknown inductive"
+      in
+      let mat = if info.cip_extensible then mat @ [any_any_branch] else mat
+      in
+      let indnames,rtn = match p, info.cip_ind, info.cip_ind_args with
+	| PMeta None, _, _ -> (Anonymous,None),None
+	| _, Some ind, Some (nparams,nargs) ->
+	  return_type_of_predicate ind nparams nargs (glob_of_pat env p)
+	| _ -> anomaly "PCase with non-trivial predicate but unknown inductive"
+      in
+      GCases (loc,RegularStyle,rtn,[glob_of_pat env tm,indnames],mat)
   | PFix f -> Detyping.detype false [] env (mkFix f)
   | PCoFix c -> Detyping.detype false [] env (mkCoFix c)
-  | PSort s -> RSort (loc,s)
-
-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
-    let id = next_name_away_with_default "x" x avoid in
-    PatVar (dummy_loc,Name id),(Name id)::env,id::ids
-  in
-  let rec buildrec ids patlist env n b =
-    if n=0 then
-      (dummy_loc, ids,
-       [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
-       raw_of_pat env b)
-    else
-      match b with
-	| 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) ->
-	    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
-  buildrec [] [] env construct_nargs branch
+  | PSort s -> GSort (loc,s)
 
 let extern_constr_pattern env pat =
-  extern true (None,[]) Idset.empty (raw_of_pat env pat)
+  extern true (None,[]) Idset.empty (glob_of_pat env pat)
 
 let extern_rel_context where env sign =
   let a = detype_rel_context where [] (names_of_rel_context env) sign in
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index d0ccde2a..e1fdd068 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrextern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -17,35 +14,33 @@ open Sign
 open Environ
 open Libnames
 open Nametab
-open Rawterm
+open Glob_term
 open Pattern
 open Topconstr
 open Notation
-(*i*)
 
-(* v7->v8 translation *)
 val check_same_type : constr_expr -> constr_expr -> unit
 
-(* Translation of pattern, cases pattern, rawterm and term into syntax
+(** Translation of pattern, cases pattern, glob_constr and term into syntax
    trees for printing *)
 
 val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr
-val extern_rawconstr : Idset.t -> rawconstr -> constr_expr
-val extern_rawtype : Idset.t -> rawconstr -> constr_expr
+val extern_glob_constr : Idset.t -> glob_constr -> constr_expr
+val extern_glob_type : Idset.t -> glob_constr -> constr_expr
 val extern_constr_pattern : names_context -> constr_pattern -> constr_expr
 
-(* 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
 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_sort : sorts -> glob_sort
 val extern_rel_context : constr option -> env ->
   rel_context -> local_binder list
 
-(* Printing options *)
+(** Printing options *)
 val print_implicits : bool ref
 val print_implicits_defensive : bool ref
 val print_arguments : bool ref
@@ -55,25 +50,25 @@ val print_universes : bool ref
 val print_no_symbol : bool ref
 val print_projections : bool ref
 
-(* Debug printing options *)
+(** Debug printing options *)
 val set_debug_global_reference_printer :
   (loc -> global_reference -> reference) -> unit
 
-(* This governs printing of implicit arguments. If [with_implicits] is
+(** This governs printing of implicit arguments. If [with_implicits] is
    on and not [with_arguments] then implicit args are printed prefixed
    by "!"; if [with_implicits] and [with_arguments] are both on the
    function and not the arguments is prefixed by "!" *)
 val with_implicits : ('a -> 'b) -> 'a -> 'b
 val with_arguments : ('a -> 'b) -> 'a -> 'b
 
-(* This forces printing of coercions *)
+(** This forces printing of coercions *)
 val with_coercions : ('a -> 'b) -> 'a -> 'b
 
-(* This forces printing universe names of Type{.} *)
+(** This forces printing universe names of Type\{.\} *)
 val with_universes : ('a -> 'b) -> 'a -> 'b
 
-(* This suppresses printing of numeral and symbols *)
+(** This suppresses printing of numeral and symbols *)
 val without_symbols : ('a -> 'b) -> 'a -> 'b
 
-(* This prints metas as anonymous holes *)
+(** This prints metas as anonymous holes *)
 val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 4310a01e..b161d001 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrintern.ml 14656 2011-11-16 08:46:31Z herbelin $ *)
-
 open Pp
 open Util
 open Flags
@@ -16,7 +14,7 @@ open Nameops
 open Namegen
 open Libnames
 open Impargs
-open Rawterm
+open Glob_term
 open Pattern
 open Pretyping
 open Cases
@@ -32,6 +30,7 @@ type var_internalization_type =
   | Inductive of identifier list (* list of params *)
   | Recursive
   | Method
+  | Variable
 
 type var_internalization_data =
     (* type of the "free" variable, for coqdoc, e.g. while typing the
@@ -46,9 +45,9 @@ type var_internalization_data =
     scope_name option list
 
 type internalization_env =
-    (identifier * var_internalization_data) list
+    (var_internalization_data) Idmap.t
 
-type raw_binder = (name * binding_kind * rawconstr option * rawconstr)
+type glob_binder = (name * binding_kind * glob_constr option * glob_constr)
 
 let interning_grammar = ref false
 
@@ -167,7 +166,7 @@ let error_inductive_parameter_not_implicit loc =
 (* Pre-computing the implicit arguments and arguments scopes needed   *)
 (* for interpretation *)
 
-let empty_internalization_env = []
+let empty_internalization_env = Idmap.empty
 
 let compute_explicitable_implicit imps = function
   | Inductive params ->
@@ -175,7 +174,7 @@ let compute_explicitable_implicit imps = function
       let sub_impl,_ = list_chop (List.length params) imps in
       let sub_impl' = List.filter is_status_implicit sub_impl in
       List.map name_of_implicit sub_impl'
-  | Recursive | Method ->
+  | Recursive | Method | Variable ->
       (* Unable to know in advance what the implicit arguments will be *)
       []
 
@@ -185,8 +184,9 @@ let compute_internalization_data env ty typ impl =
   (ty, expls_impl, impl, compute_arguments_scope typ)
 
 let compute_internalization_env env ty =
-  list_map3
-    (fun id typ impl -> (id,compute_internalization_data env ty typ impl))
+  list_fold_left3
+    (fun map id typ impl -> Idmap.add id (compute_internalization_data env ty typ impl) map)
+    empty_internalization_env
 
 (**********************************************************************)
 (* Contracting "{ _ }" in notations *)
@@ -234,6 +234,13 @@ let contract_pat_notation ntn (l,ll) =
   (* side effect; don't inline *)
   !ntn',(l,ll)
 
+type intern_env = {
+  ids: Names.Idset.t;
+  unb: bool;
+  tmp_scope: Topconstr.tmp_scope_name option;
+  scopes: Topconstr.scope_name list;
+  impls: internalization_env }
+
 (**********************************************************************)
 (* Remembering the parsing scope of variables in notations            *)
 
@@ -262,7 +269,7 @@ let error_expect_binder_notation_type loc id =
     pr_id id ++
     str " is expected to occur in binding position in the right-hand side.")
 
-let set_var_scope loc id istermvar (_,_,scopt,scopes) ntnvars =
+let set_var_scope loc id istermvar env ntnvars =
   try
     let idscopes,typ = List.assoc id ntnvars in
     if !idscopes <> None &
@@ -270,12 +277,12 @@ let set_var_scope loc id istermvar (_,_,scopt,scopes) ntnvars =
          we can tolerate having a variable occurring several times in
          different scopes: *) typ <> NtnInternTypeIdent &
       make_current_scope (Option.get !idscopes)
-      <> make_current_scope (scopt,scopes) then
+      <> make_current_scope (env.tmp_scope,env.scopes) then
 	error_inconsistent_scope loc id
 	  (make_current_scope (Option.get !idscopes))
-	  (make_current_scope (scopt,scopes))
+	  (make_current_scope (env.tmp_scope,env.scopes))
     else
-      idscopes := Some (scopt,scopes);
+      idscopes := Some (env.tmp_scope,env.scopes);
     match typ with
     | NtnInternTypeBinder ->
 	if istermvar then error_expect_binder_notation_type loc id
@@ -289,24 +296,43 @@ let set_var_scope loc id istermvar (_,_,scopt,scopes) ntnvars =
     (* Not in a notation *)
     ()
 
-let set_type_scope (ids,unb,tmp_scope,scopes) =
-  (ids,unb,Some Notation.type_scope,scopes)
+let set_type_scope env = {env with tmp_scope = Some Notation.type_scope}
 
-let reset_tmp_scope (ids,unb,tmp_scope,scopes) =
-  (ids,unb,None,scopes)
+let reset_tmp_scope env = {env with tmp_scope = None}
 
-let rec it_mkRProd env body =
+let rec it_mkGProd env body =
   match env with
-      (na, bk, _, t) :: tl -> it_mkRProd tl (RProd (dummy_loc, na, bk, t, body))
+      (na, bk, _, t) :: tl -> it_mkGProd tl (GProd (dummy_loc, na, bk, t, body))
     | [] -> body
 
-let rec it_mkRLambda env body =
+let rec it_mkGLambda env body =
   match env with
-      (na, bk, _, t) :: tl -> it_mkRLambda tl (RLambda (dummy_loc, na, bk, t, body))
+      (na, bk, _, t) :: tl -> it_mkGLambda tl (GLambda (dummy_loc, na, bk, t, body))
     | [] -> body
 
 (**********************************************************************)
 (* Utilities for binders                                              *)
+let build_impls = function
+  |Implicit -> (function
+		  |Name id ->  Some (id, Impargs.Manual, (true,true))
+		  |Anonymous -> anomaly "Anonymous implicit argument")
+  |Explicit -> fun _ -> None
+
+let impls_type_list ?(args = []) =
+  let rec aux acc = function
+    |GProd (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c
+    |_ -> (Variable,[],List.append args (List.rev acc),[])
+  in aux []
+
+let impls_term_list ?(args = []) =
+  let rec aux acc = function
+    |GLambda (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c
+    |GRec (_, fix_kind, nas, args, tys, bds) ->
+       let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in
+       let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in
+	 aux acc' bds.(nb)
+    |_ -> (Variable,[],List.append args (List.rev acc),[])
+  in aux []
 
 let check_capture loc ty = function
   | Name id when occur_var_constr_expr id ty ->
@@ -315,50 +341,55 @@ let check_capture loc ty = function
       ()
 
 let locate_if_isevar loc na = function
-  | RHole _ ->
+  | GHole _ ->
       (try match na with
-	| Name id ->  Reserve.find_reserved_type id
+	| Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id)
 	| Anonymous -> raise Not_found
-      with Not_found -> RHole (loc, Evd.BinderType na))
+      with Not_found -> GHole (loc, Evd.BinderType na))
   | x -> x
 
-let reset_hidden_inductive_implicit_test (ltacvars,namedctxvars,ntnvars,impls) =
-  let f = function id,(Inductive _,b,c,d) -> id,(Inductive [],b,c,d) | x -> x in
-  (ltacvars,namedctxvars,ntnvars,List.map f impls)
+let reset_hidden_inductive_implicit_test env =
+  { env with impls = Idmap.fold (fun id x ->
+       let x = match x with
+         | (Inductive _,b,c,d) -> (Inductive [],b,c,d)
+         | x -> x
+       in Idmap.add id x) env.impls Idmap.empty }
 
-let check_hidden_implicit_parameters id (_,_,_,impls) =
-  if List.exists (function
-    | (_,(Inductive indparams,_,_,_)) -> List.mem id indparams
+let check_hidden_implicit_parameters id impls =
+  if Idmap.exists (fun _ -> function
+    | (Inductive indparams,_,_,_) -> List.mem id indparams
     | _ -> false) impls
   then
     errorlabstrm "" (strbrk "A parameter of an inductive type " ++
     pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.")
 
-let push_name_env ?(global_level=false) lvar (ids,unb,tmpsc,scopes as env) =
+let push_name_env ?(global_level=false) lvar implargs env =
   function
   | loc,Anonymous ->
       if global_level then
 	user_err_loc (loc,"", str "Anonymous variables not allowed");
       env
   | loc,Name id ->
-      check_hidden_implicit_parameters id lvar;
-      set_var_scope loc id false env (let (_,_,ntnvars,_) = lvar in ntnvars);
+      check_hidden_implicit_parameters id env.impls ;
+      set_var_scope loc id false env (let (_,ntnvars) = lvar in ntnvars);
       if global_level then Dumpglob.dump_definition (loc,id) true "var"
       else Dumpglob.dump_binding loc id;
-      (Idset.add id ids,unb,tmpsc,scopes)
+      {env with ids = Idset.add id env.ids; impls = Idmap.add id implargs env.impls}
 
 let intern_generalized_binder ?(global_level=false) intern_type lvar
-    (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty =
-  let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in
+    env bl (loc, na) b b' t ty =
+  let ids = (match na with Anonymous -> fun x -> x | Name na -> Idset.add na) env.ids in
   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.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in
-  let env' = List.fold_left (fun env (x, l) -> push_name_env ~global_level 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 ty' = intern_type {env with ids = ids; unb = true} ty in
+  let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in
+  let env' = List.fold_left
+    (fun env (x, l) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x))
+    env fvs in
+  let bl = List.map (fun (id, loc) -> (Name id, b, None, GHole (loc, Evd.BinderType (Name id)))) fvs in
   let na = match na with
     | Anonymous ->
 	if global_level then na
@@ -371,7 +402,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar
 	    in Implicit_quantifiers.make_fresh ids' (Global.env ()) id
 	  in Name name
     | _ -> na
-  in (push_name_env ~global_level lvar env' (loc,na)), (na,b',None,ty') :: List.rev bl
+  in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (na,b',None,ty') :: List.rev bl
 
 let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function
   | LocalRawAssum(nal,bk,ty) ->
@@ -382,36 +413,37 @@ let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,b
 	  let ty = locate_if_isevar loc na (intern_type env ty) in
 	    List.fold_left
 	     (fun (env,bl) na ->
-	       (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+	       (push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl))
 	      (env,bl) nal
       | Generalized (b,b',t) ->
 	  let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in
 	    env, b @ bl)
   | LocalRawDef((loc,na as locna),def) ->
-      (push_name_env lvar env locna,
-      (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
+      let indef = intern env def in
+      (push_name_env lvar (impls_term_list indef) env locna,
+      (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl)
 
-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.generalizable_vars_of_rawconstr ~bound:ids c in
+let intern_generalization intern env lvar loc bk ak c =
+  let c = intern {env with unb = true} c in
+  let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:env.ids c in
   let env', c' =
     let abs =
       let pi =
 	match ak with
 	| Some AbsPi -> true
-	| None when tmp_scope = Some Notation.type_scope
-	    || List.mem Notation.type_scope scopes -> true
+	| None when env.tmp_scope = Some Notation.type_scope
+	    || List.mem Notation.type_scope env.scopes -> true
 	| _ -> false
       in
 	if pi then
 	  (fun (id, loc') acc ->
-	    RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
+	    GProd (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc))
 	else
 	  (fun (id, loc') acc ->
-	    RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
+	    GLambda (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc))
     in
       List.fold_right (fun (id, loc as lid) (env, acc) ->
-	let env' = push_name_env lvar env (loc, Name id) in
+	let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in
 	  (env', abs lid acc)) fvs (env,c)
   in c'
 
@@ -425,14 +457,15 @@ let iterate_binder intern lvar (env,bl) = function
 	  let ty = intern_type env ty in
 	  let ty = locate_if_isevar loc na ty in
 	  List.fold_left
-	    (fun (env,bl) na -> (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+	    (fun (env,bl) na -> (push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl))
 	    (env,bl) nal
       | Generalized (b,b',t) ->
 	  let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in
 	    env, b @ bl)
   | LocalRawDef((loc,na as locna),def) ->
-      (push_name_env lvar env locna,
-      (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
+      let indef = intern env def in
+      (push_name_env lvar (impls_term_list indef) env locna,
+      (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl)
 
 (**********************************************************************)
 (* Syntax extensions                                                  *)
@@ -450,14 +483,14 @@ let find_fresh_name renaming (terms,termlists,binders) id =
   next_ident_away id fvs
 
 let traverse_binder (terms,_,_ as subst)
-    (renaming,(ids,unb,tmpsc,scopes as env))=
+    (renaming,env)=
  function
  | Anonymous -> (renaming,env),Anonymous
  | Name id ->
   try
     (* Binders bound in the notation are considered first-order objects *)
     let _,na = coerce_to_name (fst (List.assoc id terms)) in
-    (renaming,(name_fold Idset.add na ids,unb,tmpsc,scopes)), na
+    (renaming,{env with ids = name_fold Idset.add na env.ids}), na
   with Not_found ->
     (* Binders not bound in the notation do not capture variables *)
     (* outside the notation (i.e. in the substitution) *)
@@ -465,7 +498,7 @@ let traverse_binder (terms,_,_ as subst)
     let renaming' = if id=id' then renaming else (id,id')::renaming in
     (renaming',env), Name id'
 
-let make_letins loc = List.fold_right (fun (na,b,t) c -> RLetIn (loc,na,b,c))
+let make_letins loc = List.fold_right (fun (na,b,t) c -> GLetIn (loc,na,b,c))
 
 let rec subordinate_letins letins = function
   (* binders come in reverse order; the non-let are returned in reverse order together *)
@@ -479,13 +512,13 @@ let rec subordinate_letins letins = function
       letins,[]
 
 let rec subst_iterator y t = function
-  | RVar (_,id) as x -> if id = y then t else x
-  | x -> map_rawconstr (subst_iterator y t) x
+  | GVar (_,id) as x -> if id = y then t else x
+  | x -> map_glob_constr (subst_iterator y t) x
 
-let subst_aconstr_in_rawconstr loc intern lvar subst infos c =
+let subst_aconstr_in_glob_constr loc intern lvar subst infos c =
   let (terms,termlists,binders) = subst in
-  let rec aux (terms,binderopt as subst') (renaming,(ids,unb,_,scopes as env)) c =
-    let subinfos = renaming,(ids,unb,None,scopes) in
+  let rec aux (terms,binderopt as subst') (renaming,env) c =
+    let subinfos = renaming,{env with tmp_scope = None} in
     match c with
     | AVar id ->
       begin
@@ -493,13 +526,14 @@ let subst_aconstr_in_rawconstr loc intern lvar subst infos c =
 	(* of the notations *)
 	try
 	  let (a,(scopt,subscopes)) = List.assoc id terms in
-	  intern (ids,unb,scopt,subscopes@scopes) a
+	  intern {env with tmp_scope = scopt;
+		    scopes = subscopes @ env.scopes} a
 	with Not_found ->
 	try
-	  RVar (loc,List.assoc id renaming)
+	  GVar (loc,List.assoc id renaming)
 	with Not_found ->
 	  (* Happens for local notation joint with inductive/fixpoint defs *)
-	  RVar (loc,id)
+	  GVar (loc,id)
       end
     | AList (x,_,iter,terminator,lassoc) ->
       (try
@@ -516,7 +550,7 @@ let subst_aconstr_in_rawconstr loc intern lvar subst infos c =
       let na =
         try snd (coerce_to_name (fst (List.assoc id terms)))
         with Not_found -> na in
-      RHole (loc,Evd.BinderType na)
+      GHole (loc,Evd.BinderType na)
     | ABinderList (x,_,iter,terminator) ->
       (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
@@ -533,12 +567,12 @@ let subst_aconstr_in_rawconstr loc intern lvar subst infos c =
           anomaly "Inconsistent substitution of recursive notation")
     | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt ->
         let (na,bk,t),letins = snd (Option.get binderopt) in
-	RProd (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
+	GProd (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
     | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt ->
         let (na,bk,t),letins = snd (Option.get binderopt) in
-	RLambda (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
+	GLambda (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
     | t ->
-      rawconstr_of_aconstr_with_binders loc (traverse_binder subst)
+      glob_constr_of_aconstr_with_binders loc (traverse_binder subst)
 	(aux subst') subinfos t
   in aux (terms,None) infos c
 
@@ -551,15 +585,15 @@ let split_by_type ids =
 
 let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l
 
-let intern_notation intern (_,_,tmp_scope,scopes as env) lvar loc ntn fullargs =
+let intern_notation intern env lvar loc ntn fullargs =
   let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in
-  let ((ids,c),df) = interp_notation loc ntn (tmp_scope,scopes) in
+  let ((ids,c),df) = interp_notation loc ntn (env.tmp_scope,env.scopes) in
   Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df;
   let ids,idsl,idsbl = split_by_type ids in
   let terms = make_subst ids args in
   let termlists = make_subst idsl argslist in
   let binders = make_subst idsbl bll in
-  subst_aconstr_in_rawconstr loc intern lvar
+  subst_aconstr_in_glob_constr loc intern lvar
     (terms,termlists,binders) ([],env) c
 
 (**********************************************************************)
@@ -569,30 +603,32 @@ let string_of_ty = function
   | Inductive _ -> "ind"
   | Recursive -> "def"
   | Method -> "meth"
+  | Variable -> "var"
 
-let intern_var (ids,_,_,_ as genv) (ltacvars,namedctxvars,ntnvars,impls) loc id =
+let intern_var genv (ltacvars,ntnvars) namedctx loc id =
   let (ltacvars,unbndltacvars) = ltacvars in
   (* Is [id] an inductive type potentially with implicit *)
   try
-    let ty,expl_impls,impls,argsc = List.assoc id impls in
+    let ty,expl_impls,impls,argsc = Idmap.find id genv.impls in
     let expl_impls = List.map
       (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in
     let tys = string_of_ty ty in
     Dumpglob.dump_reference loc "<>" (string_of_id id) tys;
-    RVar (loc,id), make_implicits_list impls, argsc, expl_impls
+    GVar (loc,id), make_implicits_list impls, argsc, expl_impls
   with Not_found ->
   (* Is [id] bound in current term or is an ltac var bound to constr *)
-  if Idset.mem id ids or List.mem id ltacvars
+  if Idset.mem id genv.ids or List.mem id ltacvars
   then
-    RVar (loc,id), [], [], []
+    GVar (loc,id), [], [], []
   (* Is [id] a notation variable *)
+
   else if List.mem_assoc id ntnvars
   then
-    (set_var_scope loc id true genv ntnvars; RVar (loc,id), [], [], [])
+    (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], [])
   (* Is [id] the special variable for recursive notations *)
   else if ntnvars <> [] && id = ldots_var
   then
-    RVar (loc,id), [], [], []
+    GVar (loc,id), [], [], []
   else
   (* Is [id] bound to a free name in ltac (this is an ltac error message) *)
   try
@@ -602,7 +638,7 @@ let intern_var (ids,_,_,_ as genv) (ltacvars,namedctxvars,ntnvars,impls) loc id
       | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
   with Not_found ->
     (* Is [id] a goal or section variable *)
-    let _ = Sign.lookup_named id namedctxvars in
+    let _ = Sign.lookup_named id namedctx in
       try
 	(* [id] a section variable *)
 	(* Redundant: could be done in intern_qualid *)
@@ -610,14 +646,14 @@ let intern_var (ids,_,_,_ as genv) (ltacvars,namedctxvars,ntnvars,impls) loc id
 	let impls = implicits_of_global ref in
 	let scopes = find_arguments_scope ref in
 	Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var";
-	RRef (loc, ref), impls, scopes, []
+	GRef (loc, ref), impls, scopes, []
       with _ ->
 	(* [id] a goal variable *)
-	RVar (loc,id), [], [], []
+	GVar (loc,id), [], [], []
 
 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
+  | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[]
+  | GApp (_,GRef (_,ref),l) as x
       when l <> [] & Flags.version_strictly_greater Flags.V8_2 ->
       let n = List.length l in
       x,List.map (drop_first_implicits n) (implicits_of_global ref),
@@ -650,7 +686,7 @@ let intern_reference ref =
 let intern_qualid loc qid intern env lvar args =
   match intern_extended_global_of_qualid (loc,qid) with
   | TrueGlobal ref ->
-      RRef (loc, ref), args
+      GRef (loc, ref), args
   | SynDef sp ->
       let (ids,c) = Syntax_def.search_syntactic_definition sp in
       let nids = List.length ids in
@@ -658,20 +694,20 @@ let intern_qualid loc qid intern env lvar args =
       let args1,args2 = list_chop nids args in
       check_no_explicitation args1;
       let subst = make_subst ids (List.map fst args1) in
-      subst_aconstr_in_rawconstr loc intern lvar (subst,[],[]) ([],env) c, args2
+      subst_aconstr_in_glob_constr loc intern lvar (subst,[],[]) ([],env) c, args2
 
 (* Rule out section vars since these should have been found by intern_var *)
 let intern_non_secvar_qualid loc qid intern env lvar args =
   match intern_qualid loc qid intern env lvar args with
-    | RRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid
+    | GRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid
     | r -> r
 
-let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function
+let intern_applied_reference intern env namedctx lvar args = function
   | Qualid (loc, qid) ->
       let r,args2 = intern_qualid loc qid intern env lvar args in
       find_appl_head_data r, args2
   | Ident (loc, id) ->
-      try intern_var env lvar loc id, args
+      try intern_var env lvar namedctx loc id, args
       with Not_found ->
       let qid = qualid_of_ident id in
       try
@@ -679,19 +715,21 @@ let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function
 	find_appl_head_data r, args2
       with e ->
 	(* Extra allowance for non globalizing functions *)
-	if !interning_grammar || unb then
-	  (RVar (loc,id), [], [], []),args
+	if !interning_grammar || env.unb then
+	  (GVar (loc,id), [], [], []),args
 	else raise e
 
 let interp_reference vars r =
   let (r,_,_,_),_ =
     intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc)
-      (Idset.empty,false,None,[]) (vars,[],[],[]) [] r
+      {ids = Idset.empty; unb = false ;
+       tmp_scope = None; scopes = []; impls = empty_internalization_env} []
+      (vars,[]) [] r
   in r
 
-let apply_scope_env (ids,unb,_,scopes) = function
-  | [] -> (ids,unb,None,scopes), []
-  | sc::scl -> (ids,unb,sc,scopes), scl
+let apply_scope_env env = function
+  | [] -> {env with tmp_scope = None}, []
+  | sc::scl -> {env with tmp_scope = sc}, scl
 
 let rec simple_adjust_scopes n = function
   | [] -> if n=0 then [] else None :: simple_adjust_scopes (n-1) []
@@ -766,8 +804,8 @@ let alias_of = function
   | (id::_,_) -> Name id
 
 let message_redundant_alias (id1,id2) =
-  if_verbose warning
-   ("Alias variable "^(string_of_id id1)^" is merged with "^(string_of_id id2))
+  if_warn msg_warning
+    (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2)
 
 (* Expanding notations *)
 
@@ -794,7 +832,7 @@ let rec subst_pat_iterator y t (subst,p) = match p with
       let pl = simple_product_of_cases_patterns l' in
       List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl
 
-let subst_cases_pattern loc alias intern fullsubst scopes a =
+let subst_cases_pattern loc alias intern fullsubst env a =
   let rec aux alias (subst,substlist as fullsubst) = function
   | AVar id ->
       begin
@@ -802,7 +840,8 @@ let subst_cases_pattern loc alias intern fullsubst scopes a =
 	(* of the notations *)
 	try
 	  let (a,(scopt,subscopes)) = List.assoc id subst in
-	    intern (subscopes@scopes) ([],[]) scopt a
+	    intern {env with scopes=subscopes@env.scopes;
+		      tmp_scope = scopt} ([],[]) a
 	with Not_found ->
 	  if id = ldots_var then [], [[], PatVar (loc,Name id)] else
 	  anomaly ("Unbound pattern notation variable: "^(string_of_id id))
@@ -847,7 +886,7 @@ type pattern_qualid_kind =
       ((identifier * identifier) list * cases_pattern) list) list
   | VarPat of identifier
 
-let find_constructor ref f aliases pats scopes =
+let find_constructor ref f aliases pats env =
   let (loc,qid) = qualid_of_reference ref in
   let gref =
     try locate_extended qid
@@ -865,7 +904,7 @@ let find_constructor ref f aliases pats scopes =
 	   if List.length pats < nvars then error_not_enough_arguments loc;
 	   let pats1,pats2 = list_chop nvars pats in
 	   let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) vars pats1 in
-	   let idspl1 = List.map (subst_cases_pattern loc Anonymous f (subst,[]) scopes) args in
+	   let idspl1 = List.map (subst_cases_pattern loc Anonymous f (subst,[]) env) args in
 	   cstr, idspl1, pats2
        | _ -> raise Not_found)
 
@@ -884,9 +923,9 @@ let find_pattern_variable = function
   | Ident (loc,id) -> id
   | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x))
 
-let maybe_constructor ref f aliases scopes =
+let maybe_constructor ref f aliases env =
   try
-    let c,idspl1,pl2 = find_constructor ref f aliases [] scopes in
+    let c,idspl1,pl2 = find_constructor ref f aliases [] env in
     assert (pl2 = []);
     ConstrPat (c,idspl1)
   with
@@ -894,12 +933,12 @@ let maybe_constructor ref f aliases scopes =
     | InternalizationError _ -> VarPat (find_pattern_variable ref)
       (* patt var also exists globally but does not satisfy preconditions *)
     | (Environ.NotEvaluableConst _ | Not_found) ->
-        if_verbose msg_warning (str "pattern " ++ pr_reference ref ++
+        if_warn msg_warning (str "pattern " ++ pr_reference ref ++
               str " is understood as a pattern variable");
         VarPat (find_pattern_variable ref)
 
-let mustbe_constructor loc ref f aliases patl scopes =
-  try find_constructor ref f aliases patl scopes
+let mustbe_constructor loc ref f aliases patl env =
+  try find_constructor ref f aliases patl env
   with (Environ.NotEvaluableConst _ | Not_found) ->
     raise (InternalizationError (loc,NotAConstructor ref))
 
@@ -918,7 +957,7 @@ let sort_fields mode loc l completer =
 	    try Recordops.find_projection
 	      (global_reference_of_reference refer)
 	    with Not_found ->
-	      user_err_loc (loc, "intern", str"Not a projection")
+	      user_err_loc (loc_of_reference refer, "intern", pr_reference refer ++ str": Not a projection")
 	    in
 	  (* elimination of the first field from the projections *)
 	  let rec build_patt l m i acc =
@@ -958,6 +997,10 @@ let sort_fields mode loc l completer =
 	    | [] -> accpatt
 	    | p::q->
 	       let refer, patt = p in
+	       let glob_refer = try global_reference_of_reference refer
+	       with |Not_found ->
+		 user_err_loc (loc_of_reference refer, "intern",
+			       str "The field \"" ++ pr_reference refer ++ str "\" does not exist.") in
 	       let rec add_patt l acc =
 		 match l with
 		   | [] ->
@@ -965,7 +1008,7 @@ let sort_fields mode loc l completer =
 			 (loc, "",
 			  str "This record contains fields of different records.")
 		   | (i, a) :: b->
-		       if global_reference_of_reference refer = a
+		       if glob_refer = a
 		       then (i,List.rev_append acc l)
 		       else add_patt b ((i,a)::acc)
 	         in
@@ -988,12 +1031,12 @@ let sort_fields mode loc l completer =
 	Some (nparams, base_constructor,
 	  List.rev (clean_list sorted_indexed_pattern 0 []))
 
-let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
+let rec intern_cases_pattern genv env (ids,asubst as aliases) pat =
   let intern_pat = intern_cases_pattern genv in
   match pat with
   | CPatAlias (loc, p, id) ->
       let aliases' = merge_aliases aliases id in
-      intern_pat scopes aliases' tmp_scope p
+      intern_pat env aliases' p
     | CPatRecord (loc, l) ->
 	let sorted_fields = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in
 	let self_patt =
@@ -1001,41 +1044,42 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
 	    | 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
+	intern_pat env aliases self_patt
+  | CPatCstr (loc, head, pl) | CPatCstrExpl (loc, head, pl) ->
+      let c,idslpl1,pl2 = mustbe_constructor loc head intern_pat aliases pl env in
       check_constructor_length genv loc c idslpl1 pl2;
       let argscs2 = find_remaining_constructor_scopes idslpl1 pl2 c in
-      let idslpl2 = List.map2 (intern_pat scopes ([],[])) argscs2 pl2 in
+      let idslpl2 = List.map2 (fun x -> intern_pat {env with tmp_scope = x} ([],[])) argscs2 pl2 in
       let (ids',pll) = product_of_cases_patterns ids (idslpl1@idslpl2) in
       let pl' = List.map (fun (asubst,pl) ->
         (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in
       ids',pl'
   | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]))
       when Bigint.is_strictly_pos p ->
-      intern_pat scopes aliases tmp_scope (CPatPrim(loc,Numeral(Bigint.neg p)))
+      intern_pat env aliases (CPatPrim(loc,Numeral(Bigint.neg p)))
   | CPatNotation (_,"( _ )",([a],[])) ->
-      intern_pat scopes aliases tmp_scope a
+      intern_pat env aliases a
   | CPatNotation (loc, ntn, fullargs) ->
       let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in
-      let ((ids',c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
+      let ((ids',c),df) = Notation.interp_notation loc ntn (env.tmp_scope,env.scopes) in
       let (ids',idsl',_) = split_by_type ids' in
       Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df;
       let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in
       let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in
       let ids'',pl =
 	subst_cases_pattern loc (alias_of aliases) intern_pat (subst,substlist)
-	  scopes c
+	  env c
       in ids@ids'', pl
   | CPatPrim (loc, p) ->
       let a = alias_of aliases in
       let (c,_) = Notation.interp_prim_token_cases_pattern loc p a
-	(tmp_scope,scopes) in
+	(env.tmp_scope,env.scopes) in
       (ids,[asubst,c])
   | CPatDelimiters (loc, key, e) ->
-      intern_pat (find_delimiters_scope loc key::scopes) aliases None e
+      intern_pat {env with scopes=find_delimiters_scope loc key::env.scopes;
+		    tmp_scope = None} aliases e
   | CPatAtom (loc, Some head) ->
-      (match maybe_constructor head intern_pat aliases scopes with
+      (match maybe_constructor head intern_pat aliases env with
 	 | ConstrPat (c,idspl) ->
 	     check_constructor_length genv loc c idspl [];
 	     let (ids',pll) = product_of_cases_patterns ids idspl in
@@ -1048,7 +1092,7 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
       (ids,[asubst, PatVar (loc,alias_of aliases)])
   | CPatOr (loc, pl) ->
       assert (pl <> []);
-      let pl' = List.map (intern_pat scopes aliases tmp_scope) pl in
+      let pl' = List.map (intern_pat env aliases) pl in
       let (idsl,pl') = List.split pl' in
       let ids = List.hd idsl in
       check_or_pat_variables loc ids (List.tl idsl);
@@ -1067,7 +1111,7 @@ let merge_impargs l args =
 
 let check_projection isproj nargs r =
   match (r,isproj) with
-  | RRef (loc, ref), Some _ ->
+  | GRef (loc, ref), Some _ ->
       (try
 	let n = Recordops.find_projection_nparams ref + 1 in
 	if nargs <> n then
@@ -1075,15 +1119,15 @@ let check_projection isproj nargs r =
       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.")
+  | _, Some _ -> user_err_loc (loc_of_glob_constr r, "", str "Not a projection.")
   | _, None -> ()
 
 let get_implicit_name n imps =
   Some (Impargs.name_of_implicit (List.nth imps (n-1)))
 
 let set_hole_implicit i b = function
-  | RRef (loc,r) | RApp (_,RRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b))
-  | RVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b))
+  | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b))
+  | GVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b))
   | _ -> anomaly "Only refs have implicits"
 
 let exists_implicit_name id =
@@ -1127,13 +1171,13 @@ let extract_explicit_arg imps args =
 (* Main loop                                                          *)
 
 let internalize sigma globalenv env allow_patvar lvar c =
-  let rec intern (ids,unb,tmp_scope,scopes as env) = function
+  let rec intern env = function
     | CRef ref as x ->
 	let (c,imp,subscopes,l),_ =
-	  intern_applied_reference intern env lvar [] ref in
+	  intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in
 	(match intern_impargs c env imp subscopes l with
-          | [] -> c
-          | l -> RApp (constr_loc x, c, l))
+           | [] -> c
+           | l -> GApp (constr_loc x, c, l))
     | CFix (loc, (locid,iddef), dl) ->
         let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in
         let dl = Array.of_list dl in
@@ -1142,30 +1186,34 @@ let internalize sigma globalenv env allow_patvar lvar c =
           with Not_found ->
 	    raise (InternalizationError (locid,UnboundFixName (false,iddef)))
 	in
-        let idl = Array.map
-          (fun (id,(n,order),bl,ty,bd) ->
+	let idl_temp = Array.map
+          (fun (id,(n,order),bl,ty,_) ->
 	     let intern_ro_arg f =
 	       let before, after = split_at_annot bl n in
-	       let ((ids',_,_,_) as env',rbefore) =
+	       let (env',rbefore) =
 		 List.fold_left intern_local_binder (env,[]) before in
-	       let ro = f (intern (ids', unb, tmp_scope, scopes)) in
+	       let ro = f (intern env') in
 	       let n' = Option.map (fun _ -> List.length rbefore) n in
 		 n', ro, List.fold_left intern_local_binder (env',rbefore) after
 	     in
-	     let n, ro, ((ids',_,_,_),rbl) =
+	     let n, ro, (env',rbl) =
 	       match order with
 	       | CStructRec ->
-		   intern_ro_arg (fun _ -> RStructRec)
+		   intern_ro_arg (fun _ -> GStructRec)
 	       | CWfRec c ->
-		   intern_ro_arg (fun f -> RWfRec (f c))
+		   intern_ro_arg (fun f -> GWfRec (f c))
 	       | CMeasureRec (m,r) ->
-		   intern_ro_arg (fun f -> RMeasureRec (f m, Option.map f r))
+		   intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r))
 	     in
-	     let ids'' = List.fold_right Idset.add lf ids' in
-	     ((n, ro), List.rev rbl,
-             intern_type (ids',unb,tmp_scope,scopes) ty,
-             intern (ids'',unb,None,scopes) bd)) dl in
-	RRec (loc,RFix
+	       ((n, ro), List.rev rbl, intern_type env' ty, env')) dl in
+        let idl = array_map2 (fun (_,_,_,_,bd) (a,b,c,env') ->
+	     let env'' = list_fold_left_i (fun i en name -> 
+					     let (_,bli,tyi,_) = idl_temp.(i) in
+					     let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in
+					       push_name_env lvar (impls_type_list ~args:fix_args tyi)
+					    en (dummy_loc, Name name)) 0 env' lf in
+             (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in
+	GRec (loc,GFix
 	      (Array.map (fun (ro,_,_,_) -> ro) idl,n),
               Array.of_list lf,
               Array.map (fun (_,bl,_,_) -> bl) idl,
@@ -1179,21 +1227,26 @@ let internalize sigma globalenv env allow_patvar lvar c =
           with Not_found ->
 	    raise (InternalizationError (locid,UnboundFixName (true,iddef)))
 	in
-        let idl = Array.map
-          (fun (id,bl,ty,bd) ->
-            let ((ids',_,_,_),rbl) =
+        let idl_tmp = Array.map
+          (fun (id,bl,ty,_) ->
+            let (env',rbl) =
               List.fold_left intern_local_binder (env,[]) bl in
-	    let ids'' = List.fold_right Idset.add lf ids' in
             (List.rev rbl,
-             intern_type (ids',unb,tmp_scope,scopes) ty,
-             intern (ids'',unb,None,scopes) bd)) dl in
-	RRec (loc,RCoFix n,
+             intern_type env' ty,env')) dl in
+	let idl = array_map2 (fun (_,_,_,bd) (b,c,env') ->
+	     let env'' = list_fold_left_i (fun i en name ->
+					     let (bli,tyi,_) = idl_tmp.(i) in
+					     let cofix_args =  List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in
+	       push_name_env lvar (impls_type_list ~args:cofix_args tyi)
+					    en (dummy_loc, Name name)) 0 env' lf in
+             (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in
+	GRec (loc,GCoFix n,
               Array.of_list lf,
               Array.map (fun (bl,_,_) -> bl) idl,
               Array.map (fun (_,ty,_) -> ty) idl,
               Array.map (fun (_,_,bd) -> bd) idl)
     | CArrow (loc,c1,c2) ->
-        RProd (loc, Anonymous, Explicit, intern_type env c1, intern_type env c2)
+        GProd (loc, Anonymous, Explicit, intern_type env c1, intern_type env c2)
     | CProdN (loc,[],c2) ->
         intern_type env c2
     | CProdN (loc,(nal,bk,ty)::bll,c2) ->
@@ -1203,8 +1256,9 @@ let internalize sigma globalenv env allow_patvar lvar c =
     | CLambdaN (loc,(nal,bk,ty)::bll,c2) ->
 	iterate_lam loc (reset_tmp_scope env) bk ty (CLambdaN (loc, bll, c2)) nal
     | CLetIn (loc,na,c1,c2) ->
-	RLetIn (loc, snd na, intern (reset_tmp_scope env) c1,
-          intern (push_name_env lvar env na) c2)
+	let inc1 = intern (reset_tmp_scope env) c1 in
+	GLetIn (loc, snd na, inc1,
+          intern (push_name_env lvar (impls_term_list inc1) env na) c2)
     | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[]))
 	when Bigint.is_strictly_pos p ->
 	intern env (CPrim (loc,Numeral (Bigint.neg p)))
@@ -1214,16 +1268,17 @@ let internalize sigma globalenv env allow_patvar lvar c =
     | CGeneralization (loc,b,a,c) ->
         intern_generalization intern env lvar loc b a c
     | CPrim (loc, p) ->
-	fst (Notation.interp_prim_token loc p (tmp_scope,scopes))
+	fst (Notation.interp_prim_token loc p (env.tmp_scope,env.scopes))
     | CDelimiters (loc, key, e) ->
-	intern (ids,unb,None,find_delimiters_scope loc key::scopes) e
+	intern {env with tmp_scope = None;
+		  scopes = find_delimiters_scope loc key :: env.scopes} e
     | CAppExpl (loc, (isproj,ref), args) ->
         let (f,_,args_scopes,_),args =
 	  let args = List.map (fun a -> (a,None)) args in
-	  intern_applied_reference intern env lvar args ref in
+	  intern_applied_reference intern env (Environ.named_context globalenv) 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))
+	(* Rem: GApp(_,f,[]) stands for @f *)
+	GApp (loc, f, intern_args env args_scopes (List.map fst args))
     | CApp (loc, (isproj,f), args) ->
         let isproj,f,args = match f with
           (* Compact notations like "t.(f args') args" *)
@@ -1232,7 +1287,7 @@ let internalize sigma globalenv env allow_patvar lvar c =
           | _ -> isproj,f,args in
 	let (c,impargs,args_scopes,l),args =
           match f with
-            | CRef ref -> intern_applied_reference intern env lvar args ref
+            | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref
             | CNotation (loc,ntn,([],[],[])) ->
                 let c = intern_notation intern env lvar loc ntn ([],[],[]) in
                 find_appl_head_data c, args
@@ -1242,8 +1297,8 @@ let internalize sigma globalenv env allow_patvar lvar c =
 	check_projection isproj (List.length args) c;
 	(match c with
           (* Now compact "(f args') args" *)
-	  | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args)
-	  | _ -> RApp (loc, c, args))
+	  | GApp (loc', f', args') -> GApp (join_loc loc' loc, f',args'@args)
+	  | _ -> GApp (loc, c, args))
     | CRecord (loc, _, fs) ->
 	let cargs =
 	  sort_fields true loc fs
@@ -1261,48 +1316,40 @@ let internalize sigma globalenv env allow_patvar lvar c =
         let tms,env' = List.fold_right
           (fun citm (inds,env) ->
 	    let (tm,ind),nal = intern_case_item env citm in
-	    (tm,ind)::inds,List.fold_left
-              (push_name_env (reset_hidden_inductive_implicit_test lvar))
-              env nal)
+	    (tm,ind)::inds,List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal)
 	  tms ([],env) in
         let rtnpo = Option.map (intern_type env') rtnpo in
         let eqns' = List.map (intern_eqn (List.length tms) env) eqns in
-	RCases (loc, sty, rtnpo, tms, List.flatten eqns')
+	GCases (loc, sty, rtnpo, tms, List.flatten eqns')
     | CLetTuple (loc, nal, (na,po), b, c) ->
 	let env' = reset_tmp_scope env in
         let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in
         let p' = Option.map (fun p ->
-          let env'' = List.fold_left 
-            (push_name_env (reset_hidden_inductive_implicit_test lvar))
-            env ids in
+          let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) env ids in
 	  intern_type env'' p) po in
-        RLetTuple (loc, List.map snd nal, (na', p'), b',
-                   intern (List.fold_left (push_name_env lvar) env nal) c)
+        GLetTuple (loc, List.map snd nal, (na', p'), b',
+                   intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c)
     | CIf (loc, c, (na,po), b1, b2) ->
 	let env' = reset_tmp_scope env in
         let ((c',(na',_)),ids) = intern_case_item env' (c,(na,None)) in
         let p' = Option.map (fun p ->
-          let env'' = List.fold_left
-            (push_name_env (reset_hidden_inductive_implicit_test lvar))
-            env ids in
+          let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) ids in
 	  intern_type env'' p) po in
-        RIf (loc, c', (na', p'), intern env b1, intern env b2)
+        GIf (loc, c', (na', p'), intern env b1, intern env b2)
     | CHole (loc, k) ->
-	RHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true))
+	GHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true))
     | CPatVar (loc, n) when allow_patvar ->
-	RPatVar (loc, n)
+	GPatVar (loc, n)
     | CPatVar (loc, _) ->
 	raise (InternalizationError (loc,IllegalMetavariable))
     | CEvar (loc, n, l) ->
-	REvar (loc, n, Option.map (List.map (intern env)) l)
+	GEvar (loc, n, Option.map (List.map (intern env)) l)
     | CSort (loc, s) ->
-	RSort(loc,s)
+	GSort(loc,s)
     | CCast (loc, c1, CastConv (k, c2)) ->
-	RCast (loc,intern env c1, CastConv (k, intern_type env c2))
+	GCast (loc,intern env c1, CastConv (k, intern_type env c2))
     | CCast (loc, c1, CastCoerce) ->
-	RCast (loc,intern env c1, CastCoerce)
-
-    | CDynamic (loc,d) -> RDynamic (loc,d)
+	GCast (loc,intern env c1, CastCoerce)
 
   and intern_type env = intern (set_type_scope env)
 
@@ -1310,52 +1357,52 @@ let internalize sigma globalenv env allow_patvar lvar c =
     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) =
+  and intern_multiple_pattern env n (loc,pl) =
     let idsl_pll =
-      List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in
+      List.map (intern_cases_pattern globalenv {env with tmp_scope = None} ([],[])) pl in
     check_number_of_pattern loc n pl;
     product_of_cases_patterns [] idsl_pll
 
   (* Expands a disjunction of multiple pattern *)
-  and intern_disjunctive_multiple_pattern scopes loc n mpl =
+  and intern_disjunctive_multiple_pattern env loc n mpl =
     assert (mpl <> []);
-    let mpl' = List.map (intern_multiple_pattern scopes n) mpl in
+    let mpl' = List.map (intern_multiple_pattern env n) mpl in
     let (idsl,mpl') = List.split mpl' in
     let ids = List.hd idsl in
     check_or_pat_variables loc ids (List.tl idsl);
     (ids,List.flatten mpl')
 
   (* Expands a pattern-matching clause [lhs => rhs] *)
-  and intern_eqn n (ids,unb,tmp_scope,scopes) (loc,lhs,rhs) =
-    let eqn_ids,pll = intern_disjunctive_multiple_pattern scopes loc n lhs in
+  and intern_eqn n env (loc,lhs,rhs) =
+    let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in
     (* Linearity implies the order in ids is irrelevant *)
     check_linearity lhs eqn_ids;
-    let env_ids = List.fold_right Idset.add eqn_ids ids in
+    let env_ids = List.fold_right Idset.add eqn_ids env.ids in
     List.map (fun (asubst,pl) ->
       let rhs = replace_vars_constr_expr asubst rhs in
       List.iter message_redundant_alias asubst;
-      let rhs' = intern (env_ids,unb,tmp_scope,scopes) rhs in
+      let rhs' = intern {env with ids = env_ids} rhs in
       (loc,eqn_ids,pl,rhs')) pll
 
-  and intern_case_item (vars,unb,_,scopes as env) (tm,(na,t)) =
+  and intern_case_item env (tm,(na,t)) =
     let tm' = intern env tm in
     let ids,typ = match t with
     | Some t ->
 	let tids = ids_of_cases_indtype t in
 	let tids = List.fold_right Idset.add tids Idset.empty in
-	let t = intern_type (tids,unb,None,scopes) t in
+	let t = intern_type {env with ids = tids; tmp_scope = None} t in
 	let loc,ind,l = match t with
-	    | RRef (loc,IndRef ind) -> (loc,ind,[])
-	    | RApp (loc,RRef (_,IndRef ind),l) -> (loc,ind,l)
-	    | _ -> error_bad_inductive_type (loc_of_rawconstr t) in
+	    | GRef (loc,IndRef ind) -> (loc,ind,[])
+	    | GApp (loc,GRef (_,IndRef ind),l) -> (loc,ind,l)
+	    | _ -> error_bad_inductive_type (loc_of_glob_constr t) in
 	let nparams, nrealargs = inductive_nargs globalenv ind in
 	let nindargs = nparams + nrealargs in
 	if List.length l <> nindargs then
 	  error_wrong_numarg_inductive_loc loc globalenv ind nindargs;
 	let nal = List.map (function
-	  | RHole (loc,_) -> loc,Anonymous
-	  | RVar (loc,id) -> loc,Name id
-	  | c -> user_err_loc (loc_of_rawconstr c,"",str "Not a name.")) l in
+	  | GHole (loc,_) -> loc,Anonymous
+	  | GVar (loc,id) -> loc,Name id
+	  | c -> user_err_loc (loc_of_glob_constr c,"",str "Not a name.")) l in
 	let parnal,realnal = list_chop nparams nal in
 	if List.exists (fun (_,na) -> na <> Anonymous) parnal then
 	  error_inductive_parameter_not_implicit loc;
@@ -1363,8 +1410,8 @@ let internalize sigma globalenv env allow_patvar lvar c =
     | None ->
 	[], None in
     let na = match tm', na with
-      | RVar (loc,id), None when Idset.mem id vars -> loc,Name id
-      | RRef (loc, VarRef id), None -> loc,Name id
+      | GVar (loc,id), None when Idset.mem id env.ids -> loc,Name id
+      | GRef (loc, VarRef id), None -> loc,Name id
       | _, None -> dummy_loc,Anonymous
       | _, Some (loc,na) -> loc,na in
     (tm',(snd na,typ)), na::ids
@@ -1373,9 +1420,9 @@ let internalize sigma globalenv env allow_patvar lvar c =
     let rec default env bk = function
     | (loc1,na as locna)::nal ->
 	if nal <> [] then check_capture loc1 ty na;
-	let body = default (push_name_env lvar env locna) bk nal in
 	let ty = locate_if_isevar loc1 na (intern_type env ty) in
-	  RProd (join_loc loc1 loc2, na, bk, ty, body)
+	let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in
+	  GProd (join_loc loc1 loc2, na, bk, ty, body)
     | [] -> intern_type env body
     in
       match bk with
@@ -1383,22 +1430,22 @@ let internalize sigma globalenv env allow_patvar lvar c =
 	| 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
+	      it_mkGProd ibind body
 
   and iterate_lam loc2 env bk ty body nal =
     let rec default env bk = function
       | (loc1,na as locna)::nal ->
 	  if nal <> [] then check_capture loc1 ty na;
-	  let body = default (push_name_env lvar env locna) bk nal in
 	  let ty = locate_if_isevar loc1 na (intern_type env ty) in
-	    RLambda (join_loc loc1 loc2, na, bk, ty, body)
+	  let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in
+	    GLambda (join_loc loc1 loc2, na, bk, ty, body)
       | [] -> intern env body
     in match bk with
       | Default b -> default env b nal
       | Generalized (b, b', t) ->
 	  let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
 	  let body = intern env body in
-	    it_mkRLambda ibind body
+	    it_mkGLambda ibind body
 
   and intern_impargs c env l subscopes args =
     let l = select_impargs_size (List.length args) l in
@@ -1418,7 +1465,7 @@ let internalize 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) (force_inference_of imp) c) ::
+	    GHole (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') ->
@@ -1426,7 +1473,7 @@ let internalize sigma globalenv env allow_patvar lvar c =
       | (imp::impl', []) ->
 	  if eargs <> [] then
 	    (let (id,(loc,_)) = List.hd eargs in
-	       user_err_loc (loc,"",str "Not enough non implicit
+	       user_err_loc (loc,"",str "Not enough non implicit \
 	    arguments to accept the argument bound to " ++
 		 pr_id id ++ str"."));
 	  []
@@ -1450,7 +1497,7 @@ let internalize sigma globalenv env allow_patvar lvar c =
 	  explain_internalization_error e)
 
 (**************************************************************************)
-(* Functions to translate constr_expr into rawconstr                       *)
+(* Functions to translate constr_expr into glob_constr                    *)
 (**************************************************************************)
 
 let extract_ids env =
@@ -1459,32 +1506,34 @@ let extract_ids env =
     Idset.empty
 
 let intern_gen isarity sigma env
-               ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
+               ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
   let tmp_scope =
     if isarity then Some Notation.type_scope else None in
-    internalize sigma env (extract_ids env, false, tmp_scope,[])
-      allow_patvar (ltacvars,Environ.named_context env, [], impls) c
+    internalize sigma env {ids = extract_ids env; unb = false;
+			   tmp_scope = tmp_scope; scopes = [];
+			  impls = impls}
+      allow_patvar (ltacvars, []) 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 =
+let intern_pattern globalenv patt =
   try
-    intern_cases_pattern env [] ([],[]) None patt
+    intern_cases_pattern globalenv {ids = extract_ids globalenv; unb = false;
+				    tmp_scope = None; scopes = [];
+				    impls = empty_internalization_env} ([],[]) patt
   with
       InternalizationError (loc,e) ->
 	user_err_loc (loc,"internalize",explain_internalization_error e)
 
 
-type manual_implicits = (explicitation * (bool * bool * bool)) list
-
 (*********************************************************************)
 (* Functions to parse and interpret constructions *)
 
 let interp_gen kind sigma env
-               ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
+               ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
   let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in
     Default.understand_gen kind sigma env c
@@ -1492,10 +1541,10 @@ let interp_gen kind sigma env
 let interp_constr sigma env c =
   interp_gen (OfType None) sigma env c
 
-let interp_type sigma env ?(impls=[]) c =
+let interp_type sigma env ?(impls=empty_internalization_env) c =
   interp_gen IsType sigma env ~impls c
 
-let interp_casted_constr sigma env ?(impls=[]) c typ =
+let interp_casted_constr sigma env ?(impls=empty_internalization_env) c typ =
   interp_gen (OfType (Some typ)) sigma env ~impls c
 
 let interp_open_constr sigma env c =
@@ -1503,19 +1552,19 @@ let interp_open_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 sigma = ref sigma in
+  let evars = ref (Gmap.empty : (identifier,glob_constr) Gmap.t) in
   let rec patvar_to_evar r = match r with
-    | RPatVar (loc,(_,id)) ->
+    | GPatVar (loc,(_,id)) ->
 	( try Gmap.find id !evars
 	  with Not_found ->
 	    let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in
 	    let ev = Evarutil.e_new_evar sigma env ev in
-	    let rev = REvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in
+	    let rev = GEvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in
 	    evars := Gmap.add id rev !evars;
 	    rev
 	)
-    | _ -> map_rawconstr patvar_to_evar r in
+    | _ -> map_glob_constr patvar_to_evar r in
   let raw = patvar_to_evar raw in
   Default.understand_tcc !sigma env raw
 
@@ -1523,7 +1572,7 @@ let interp_constr_judgment sigma env c =
   Default.understand_judgment sigma env (intern_constr sigma env c)
 
 let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true)
-    env ?(impls=[]) kind c =
+    env ?(impls=empty_internalization_env) kind c =
   let evdref =
     match evdref with
     | None -> ref Evd.empty
@@ -1531,43 +1580,44 @@ let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true)
   in
   let istype = kind = IsType in
   let c = intern_gen istype ~impls !evdref env c in
-  let imps = Implicit_quantifiers.implicits_of_rawterm ~with_products:istype c in
+  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:istype c in
     Default.understand_tcc_evars ~fail_evar evdref env kind c, imps
 
 let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true)
-    env ?(impls=[]) c typ =
+    env ?(impls=empty_internalization_env) c typ =
   interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c
 
-let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c =
+let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c =
   interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c
 
-let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c =
+let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c =
   interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c
 
-let interp_constr_evars_gen evdref env ?(impls=[]) kind c =
-  let c = intern_gen (kind=IsType) ~impls ( !evdref) env c in
+let interp_constr_evars_gen evdref env ?(impls=empty_internalization_env) kind c =
+  let c = intern_gen (kind=IsType) ~impls !evdref env c in
     Default.understand_tcc_evars evdref env kind c
 
-let interp_casted_constr_evars evdref env ?(impls=[]) c typ =
+let interp_casted_constr_evars evdref env ?(impls=empty_internalization_env) c typ =
   interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
 
-let interp_type_evars evdref env ?(impls=[]) c =
+let interp_type_evars evdref env ?(impls=empty_internalization_env) c =
   interp_constr_evars_gen evdref env IsType ~impls 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
+  pattern_of_glob_constr c
 
-let interp_aconstr ?(impls=[]) vars recvars a =
+let interp_aconstr ?(impls=empty_internalization_env) vars recvars a =
   let env = Global.env () in
   (* [vl] is intended to remember the scope of the free variables of [a] *)
   let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in
-  let c = internalize Evd.empty (Global.env()) (extract_ids env, false, None, [])
-    false (([],[]),Environ.named_context env,vl,impls) a in
+  let c = internalize Evd.empty (Global.env()) {ids = extract_ids env; unb = false;
+						tmp_scope = None; scopes = []; impls = impls}
+    false (([],[]),vl) a in
   (* Translate and check that [c] has all its free variables bound in [vars] *)
-  let a = aconstr_of_rawconstr vars recvars c in
+  let a = aconstr_of_glob_constr vars recvars c in
   (* Splits variables into those that are binding, bound, or both *)
   (* binding and bound *)
   let out_scope = function None -> None,[] | Some (a,l) -> a,l in
@@ -1579,12 +1629,12 @@ let interp_aconstr ?(impls=[]) vars recvars a =
 
 let interp_binder sigma env na t =
   let t = intern_gen true sigma env t in
-  let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+  let t' = locate_if_isevar (loc_of_glob_constr t) na t in
   Default.understand_type sigma env t'
 
 let interp_binder_evars evdref env na t =
   let t = intern_gen true !evdref env t in
-  let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+  let t' = locate_if_isevar (loc_of_glob_constr t) na t in
   Default.understand_tcc_evars evdref env IsType t'
 
 open Environ
@@ -1595,11 +1645,12 @@ let my_intern_constr sigma env lvar acc c =
 
 let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c
 
-let intern_context global_level sigma env params =
-  let lvar = (([],[]),Environ.named_context env, [], []) in
-    snd (List.fold_left
+let intern_context global_level sigma env impl_env params =
+  let lvar = (([],[]), []) in
+  let lenv, bl = List.fold_left
 	    (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar)
-	    ((extract_ids env,false,None,[]), []) params)
+	    ({ids = extract_ids env; unb = false;
+	      tmp_scope = None; scopes = []; impls = impl_env}, []) params in (lenv.impls, bl)
 
 let interp_rawcontext_gen understand_type understand_judgment env bl =
   let (env, par, _, impls) =
@@ -1607,7 +1658,7 @@ let interp_rawcontext_gen understand_type understand_judgment env bl =
       (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' = locate_if_isevar (loc_of_glob_constr t) na t in
 	      let t = understand_type env t' in
 	      let d = (na,None,t) in
 	      let impls =
@@ -1624,15 +1675,15 @@ let interp_rawcontext_gen understand_type understand_judgment env bl =
       (env,[],1,[]) (List.rev bl)
   in (env, par), impls
 
-let interp_context_gen understand_type understand_judgment ?(global_level=false) sigma env params =
-  let bl = intern_context global_level sigma env params in
-    interp_rawcontext_gen understand_type understand_judgment env bl
+let interp_context_gen understand_type understand_judgment ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params =
+  let int_env,bl = intern_context global_level sigma env impl_env params in
+    int_env, interp_rawcontext_gen understand_type understand_judgment env bl
 
-let interp_context ?(global_level=false) sigma env params =
-  interp_context_gen (Default.understand_type sigma) 
-    (Default.understand_judgment sigma) ~global_level sigma env params
+let interp_context ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params =
+  interp_context_gen (Default.understand_type sigma)
+    (Default.understand_judgment sigma) ~global_level ~impl_env sigma env params
 
-let interp_context_evars ?(global_level=false) evdref env params =
+let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) evdref env params =
   interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t)
-    (Default.understand_judgment_tcc evdref) ~global_level !evdref env params
-    
+    (Default.understand_judgment_tcc evdref) ~global_level ~impl_env !evdref env params
+
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index 767ec9ff..be78837f 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -1,39 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrintern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Sign
 open Evd
 open Environ
 open Libnames
-open Rawterm
+open Glob_term
 open Pattern
 open Topconstr
 open Termops
 open Pretyping
-(*i*)
 
-(*s Translation from front abstract syntax of term to untyped terms (rawconstr)
+(** Translation from front abstract syntax of term to untyped terms (glob_constr) *)
 
-   The translation performs:
+(** The translation performs:
 
    - resolution of names :
       - check all variables are bound
       - make absolute the references to global objets
    - resolution of symbolic notations using scopes
    - insertion of implicit arguments
-*)
 
-(* To interpret implicit arguments and arg scopes of recursive variables
+   To interpret implicit arguments and arg scopes of recursive variables
    while internalizing inductive types and recursive definitions, and also
    projection while typing records.
 
@@ -45,22 +40,21 @@ type var_internalization_type =
   | Inductive of identifier list (* list of params *)
   | Recursive
   | Method
+  | Variable
 
 type var_internalization_data =
     var_internalization_type *
-      (* type of the "free" variable, for coqdoc, e.g. while typing the
-	 constructor of JMeq, "JMeq" behaves as a variable of type Inductive *)
+      (** type of the "free" variable, for coqdoc, e.g. while typing the
+	  constructor of JMeq, "JMeq" behaves as a variable of type Inductive *)
     identifier list *
-      (* impargs to automatically add to the variable, e.g. for "JMeq A a B b"
+      (** impargs to automatically add to the variable, e.g. for "JMeq A a B b"
           in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *)
     Impargs.implicit_status list * (** signature of impargs of the variable *)
-    scope_name option list (* subscopes of the args of the variable *)
+    scope_name option list (** subscopes of the args of the variable *)
 
-(* A map of free variables to their implicit arguments and scopes *)
-type internalization_env =
-    (identifier * var_internalization_data) list
+(** A map of free variables to their implicit arguments and scopes *)
+type internalization_env = var_internalization_data Idmap.t
 
-(* Contains also a list of identifiers to automatically apply to the variables*)
 val empty_internalization_env : internalization_env
 
 val compute_internalization_data : env -> var_internalization_type ->
@@ -70,43 +64,41 @@ val compute_internalization_env : env -> var_internalization_type ->
   identifier list -> types list -> Impargs.manual_explicitation list list ->
   internalization_env
 
-type manual_implicits = (explicitation * (bool * bool * bool)) list
-
 type ltac_sign = identifier list * unbound_ltac_var_map
 
-type raw_binder = (name * binding_kind * rawconstr option * rawconstr)
+type glob_binder = (name * binding_kind * glob_constr option * glob_constr)
 
-(*s Internalisation performs interpretation of global names and notations *)
+(** {6 Internalization performs interpretation of global names and notations } *)
 
-val intern_constr : evar_map -> env -> constr_expr -> rawconstr
+val intern_constr : evar_map -> env -> constr_expr -> glob_constr
 
-val intern_type : evar_map -> env -> constr_expr -> rawconstr
+val intern_type : evar_map -> env -> constr_expr -> glob_constr
 
 val intern_gen : bool -> evar_map -> env ->
   ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
-  constr_expr -> rawconstr
+  constr_expr -> glob_constr
 
 val intern_pattern : env -> cases_pattern_expr ->
   Names.identifier list *
-    ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list
+    ((Names.identifier * Names.identifier) list * Glob_term.cases_pattern) list
 
-val intern_context : bool -> evar_map -> env -> local_binder list -> raw_binder list
+val intern_context : bool -> evar_map -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list
 
-(*s Composing internalization with pretyping *)
+(** {6 Composing internalization with pretyping } *)
 
-(* Main interpretation function *)
+(** Main interpretation function *)
 
 val interp_gen : typing_constraint -> evar_map -> env ->
   ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
   constr_expr -> constr
 
-(* Particular instances *)
+(** Particular instances *)
 
 val interp_constr : evar_map -> env ->
   constr_expr -> constr
 
 val interp_type : evar_map -> env -> ?impls:internalization_env ->
-   constr_expr -> types
+  constr_expr -> types
 
 val interp_open_constr   : evar_map -> env -> constr_expr -> evar_map * constr
 
@@ -115,18 +107,18 @@ val interp_open_constr_patvar   : evar_map -> env -> constr_expr -> evar_map * c
 val interp_casted_constr : evar_map -> env -> ?impls:internalization_env ->
   constr_expr -> types -> constr
 
-(* Accepting evars and giving back the manual implicits in addition. *)
+(** Accepting evars and giving back the manual implicits in addition. *)
 
 val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env ->
-  ?impls:internalization_env -> constr_expr -> types -> constr * manual_implicits
+  ?impls:internalization_env -> constr_expr -> types -> constr * Impargs.manual_implicits
 
 val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
   env -> ?impls:internalization_env ->
-  constr_expr -> types * manual_implicits
+  constr_expr -> types * Impargs.manual_implicits
 
 val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
   env -> ?impls:internalization_env ->
-  constr_expr -> constr * manual_implicits
+  constr_expr -> constr * Impargs.manual_implicits
 
 val interp_casted_constr_evars : evar_map ref -> env ->
   ?impls:internalization_env -> constr_expr -> types -> constr
@@ -134,58 +126,57 @@ val interp_casted_constr_evars : evar_map ref -> env ->
 val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env ->
   constr_expr -> types
 
-(*s Build a judgment  *)
+(** {6 Build a judgment  } *)
 
 val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment
 
-(* Interprets constr patterns *)
+(** Interprets constr patterns *)
 
 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 *)
+(** 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
+(** Expands abbreviations (syndef); raise an error if not existing *)
+val interp_reference : ltac_sign -> reference -> glob_constr
 
-(* Interpret binders *)
+(** Interpret binders *)
 
 val interp_binder  : evar_map -> env -> name -> constr_expr -> types
 
 val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types
 
-(* Interpret contexts: returns extended env and context *)
+(** Interpret contexts: returns extended env and context *)
 
-val interp_context_gen : (env -> rawconstr -> types) ->
-  (env -> rawconstr -> unsafe_judgment) ->
-  ?global_level:bool ->
-  evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
+val interp_context_gen : (env -> glob_constr -> types) ->
+  (env -> glob_constr -> unsafe_judgment) ->
+  ?global_level:bool -> ?impl_env:internalization_env ->
+  evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
   
-val interp_context : ?global_level:bool ->
-  evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
+val interp_context : ?global_level:bool -> ?impl_env:internalization_env ->
+  evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
 
-val interp_context_evars : ?global_level:bool ->
-  evar_map ref -> env -> local_binder list -> (env * rel_context) * manual_implicits
+val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env ->
+  evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
 
-(* Locating references of constructions, possibly via a syntactic definition *)
-(* (these functions do not modify the glob file) *)
+(** Locating references of constructions, possibly via a syntactic definition 
+   (these functions do not modify the glob file) *)
 
 val is_global : identifier -> bool
 val construct_reference : named_context -> identifier -> constr
 val global_reference : identifier -> constr
 val global_reference_in_absolute_module : dir_path -> identifier -> constr
 
-(* Interprets a term as the left-hand side of a notation; the boolean
-   list is a set and this set is [true] for a variable occurring in
-   term position, [false] for a variable occurring in binding
-   position; [true;false] if in both kinds of position *)
-
+(** Interprets a term as the left-hand side of a notation; the boolean
+    list is a set and this set is [true] for a variable occurring in
+    term position, [false] for a variable occurring in binding
+    position; [true;false] if in both kinds of position *)
 val interp_aconstr : ?impls:internalization_env ->
   (identifier * notation_var_internalization_type) list ->
   (identifier * identifier) list -> constr_expr ->
   (identifier * (subscopes * notation_var_internalization_type)) list * aconstr
 
-(* Globalization leak for Grammar *)
+(** Globalization leak for Grammar *)
 val for_grammar : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index c5850abf..eb7828ea 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqlib.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Names
@@ -44,8 +42,8 @@ let global_of_extended q =
 
 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_extended_all (qualid_of_ident id) in
+  let qualid = qualid_of_string s in
+  let all = Nametab.locate_extended_all qualid in
   let all = list_uniquize (list_map_filter global_of_extended all) in
   let these = List.filter (has_suffix_in_dirs dirs) all in
   match these with
@@ -93,10 +91,12 @@ let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s
 let arith_dir = ["Coq";"Arith"]
 let arith_modules = [arith_dir]
 
+let numbers_dir = [ "Coq";"Numbers"]
+let parith_dir = ["Coq";"PArith"]
 let narith_dir = ["Coq";"NArith"]
-
 let zarith_dir = ["Coq";"ZArith"]
-let zarith_base_modules = [narith_dir;zarith_dir]
+
+let zarith_base_modules = [numbers_dir;parith_dir;narith_dir;zarith_dir]
 
 let init_dir = ["Coq";"Init"]
 let init_modules = [
@@ -108,11 +108,6 @@ let init_modules = [
   init_dir@["Wf"]
 ]
 
-let coq_id = id_of_string "Coq"
-let init_id = id_of_string "Init"
-let arith_id = id_of_string "Arith"
-let datatypes_id = id_of_string "Datatypes"
-
 let logic_module_name = ["Coq";"Init";"Logic"]
 let logic_module = make_dir logic_module_name
 
@@ -137,7 +132,7 @@ let make_con dir id = Libnames.encode_con dir id
 let id = make_con datatypes_module (id_of_string "id")
 let type_of_id = make_con datatypes_module (id_of_string "ID")
 
-let _ = Cases.set_impossible_default_clause (mkConst id,mkConst type_of_id)
+let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id)
 
 (** Natural numbers *)
 let nat_kn = make_kn datatypes_module (id_of_string "nat")
@@ -192,10 +187,17 @@ let build_sigma_set () = anomaly "Use build_sigma_type"
 let build_sigma_type () =
   { proj1 = init_constant ["Specif"] "projT1";
     proj2 = init_constant ["Specif"] "projT2";
-    elim = init_constant ["Specif"] "sigT_rec";
+    elim = init_constant ["Specif"] "sigT_rect";
     intro = init_constant ["Specif"] "existT";
     typ = init_constant ["Specif"] "sigT" }
 
+let build_sigma () =
+  { proj1 = init_constant ["Specif"] "proj1_sig";
+    proj2 = init_constant ["Specif"] "proj2_sig";
+    elim = init_constant ["Specif"] "sig_rect";
+    intro = init_constant ["Specif"] "exist";
+    typ = init_constant ["Specif"] "sig" }
+
 let build_prod () =
   { proj1 = init_constant ["Datatypes"] "fst";
     proj2 = init_constant ["Datatypes"] "snd";
@@ -227,8 +229,6 @@ let lazy_logic_constant dir id = lazy (logic_constant dir id)
 let coq_eq_eq = lazy_init_constant ["Logic"] "eq"
 let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl"
 let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind"
-let coq_eq_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"] "eq_sym"
 let coq_eq_trans  = lazy_init_constant ["Logic"] "eq_trans"
@@ -250,8 +250,6 @@ 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;
@@ -263,8 +261,6 @@ let build_coq_inversion_eq_data () =
 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"
@@ -300,8 +296,6 @@ let build_coq_sumbool () = Lazy.force coq_sumbool
 let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity"
 let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl"
 let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind"
-let coq_identity_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"] "identity_congr"
 let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym"
 let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans"
@@ -376,6 +370,7 @@ 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_exist_ref  = lazy (init_reference ["Specif"] "exist")
 let coq_not_ref     = lazy (init_reference ["Logic"] "not")
 let coq_False_ref   = lazy (init_reference ["Logic"] "False")
 let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool")
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index 64a9df6d..5d3580f2 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.mli
@@ -1,26 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqlib.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Libnames
 open Nametab
 open Term
 open Pattern
 open Util
-(*i*)
 
-(*s This module collects the global references, constructions and
+(** This module collects the global references, constructions and
     patterns of the standard library used in ocaml files *)
 
-(*s [find_reference caller_message [dir;subdir;...] s] returns a global
+(** {6 ... } *)
+(** [find_reference caller_message [dir;subdir;...] s] returns a global
    reference to the name dir.subdir.(...).s; the corresponding module
    must have been required or in the process of being compiled so that
    it must be used lazyly; it raises an anomaly with the given message
@@ -30,39 +27,39 @@ type message = string
 
 val find_reference : message -> string list -> string -> global_reference
 
-(* [coq_reference caller_message [dir;subdir;...] s] returns a
+(** [coq_reference caller_message [dir;subdir;...] s] returns a
    global reference to the name Coq.dir.subdir.(...).s *)
 
 val coq_reference : message -> string list -> string -> global_reference
 
-(* idem but return a term *)
+(** idem but return a term *)
 
 val coq_constant : message -> string list -> string -> constr
 
-(* Synonyms of [coq_constant] and [coq_reference] *)
+(** Synonyms of [coq_constant] and [coq_reference] *)
 
 val gen_constant : message -> string list -> string -> constr
 val gen_reference :  message -> string list -> string -> global_reference
 
-(* Search in several modules (not prefixed by "Coq") *)
+(** Search in several modules (not prefixed by "Coq") *)
 val gen_constant_in_modules : string->string list list-> string -> constr
 val arith_modules : string list list
 val zarith_base_modules : string list list
 val init_modules : string list list
 
-(* For tactics/commands requiring vernacular libraries *)
+(** For tactics/commands requiring vernacular libraries *)
 val check_required_library : string list -> unit
 
-(*s Global references *)
+(** {6 Global references } *)
 
-(* Modules *)
+(** Modules *)
 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 *)
+(** Natural numbers *)
 val nat_path : full_path
 val glob_nat : global_reference
 val path_of_O : constructor
@@ -70,7 +67,7 @@ val path_of_S : constructor
 val glob_O : global_reference
 val glob_S : global_reference
 
-(* Booleans *)
+(** Booleans *)
 val glob_bool : global_reference
 val path_of_true : constructor
 val path_of_false : constructor
@@ -78,12 +75,13 @@ val glob_true : global_reference
 val glob_false : global_reference
 
 
-(* Equality *)
+(** 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
+(** {6 ... } *)
+(** Constructions and patterns related to Coq initial state are unknown
    at compile time. Therefore, we can only provide methods to build
    them at runtime. This is the purpose of the [constr delayed] and
    [constr_pattern delayed] types. Objects of this time needs to be
@@ -96,7 +94,7 @@ type coq_bool_data = {
   andb_true_intro : constr}
 val build_bool_type : coq_bool_data delayed
 
-(*s For Equality tactics *)
+(** {6 For Equality tactics } *)
 type coq_sigma_data = {
   proj1 : constr;
   proj2 : constr;
@@ -106,7 +104,9 @@ type coq_sigma_data = {
 
 val build_sigma_set : coq_sigma_data delayed
 val build_sigma_type : coq_sigma_data delayed
-(* Non-dependent pairs in Set from Datatypes *)
+val build_sigma : coq_sigma_data delayed
+
+(** Non-dependent pairs in Set from Datatypes *)
 val build_prod : coq_sigma_data delayed
 
 type coq_eq_data = {
@@ -121,17 +121,19 @@ val build_coq_eq_data : coq_eq_data delayed
 val build_coq_identity_data : coq_eq_data delayed
 val build_coq_jmeq_data : coq_eq_data delayed
 
-val build_coq_eq       : constr delayed (* = [(build_coq_eq_data()).eq] *)
-val build_coq_eq_refl  : constr delayed (* = [(build_coq_eq_data()).refl] *)
-val build_coq_eq_sym   : constr delayed (* = [(build_coq_eq_data()).sym] *)
+val build_coq_eq       : constr delayed (** = [(build_coq_eq_data()).eq] *)
+val build_coq_eq_refl  : constr delayed (** = [(build_coq_eq_data()).refl] *)
+val build_coq_eq_sym   : constr delayed (** = [(build_coq_eq_data()).sym] *)
 val build_coq_f_equal2 : constr delayed
 
-(* Data needed for discriminate and injection *)
+(** Data needed for discriminate and injection *)
 
 type coq_inversion_data = {
-  inv_eq   : constr; (* : forall params, t -> Prop *)
-  inv_ind  : constr; (* : forall params P y, eq params y -> P y *)
-  inv_congr: constr  (* : forall params B (f:t->B) y, eq params y -> f c=f y *)
+  inv_eq   : constr; (** : forall params, args -> Prop *)
+  inv_ind  : constr; (** : forall params P (H : P params) args, eq params args 
+			 ->  P args *)
+  inv_congr: constr  (** : forall params B (f:t->B) args, eq params args -> 
+			 f params = f args *)
 }
 
 val build_coq_inversion_eq_data : coq_inversion_data delayed
@@ -139,21 +141,22 @@ 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 *)
+(** Specif *)
 val build_coq_sumbool : constr delayed
 
-(*s Connectives *)
-(* The False proposition *)
+(** {6 ... } *)
+(** Connectives 
+   The False proposition *)
 val build_coq_False : constr delayed
 
-(* The True proposition and its unique proof *)
+(** The True proposition and its unique proof *)
 val build_coq_True : constr delayed
 val build_coq_I : constr delayed
 
-(* Negation *)
+(** Negation *)
 val build_coq_not : constr delayed
 
-(* Conjunction *)
+(** Conjunction *)
 val build_coq_and : constr delayed
 val build_coq_conj : constr delayed
 val build_coq_iff : constr delayed
@@ -161,10 +164,10 @@ val build_coq_iff : constr delayed
 val build_coq_iff_left_proj : constr delayed
 val build_coq_iff_right_proj : constr delayed
 
-(* Disjunction *)
+(** Disjunction *)
 val build_coq_or : constr delayed
 
-(* Existential quantifier *)
+(** Existential quantifier *)
 val build_coq_ex : constr delayed
 
 val coq_eq_ref : global_reference lazy_t
@@ -173,6 +176,7 @@ 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_exist_ref : global_reference lazy_t
 val coq_not_ref : global_reference lazy_t
 val coq_False_ref : global_reference lazy_t
 val coq_sumbool_ref : global_reference lazy_t
diff --git a/interp/doc.tex b/interp/doc.tex
index 5bd92fbd..4ce5811d 100644
--- a/interp/doc.tex
+++ b/interp/doc.tex
@@ -5,7 +5,7 @@
 \ocwsection \label{interp}
 This chapter describes the translation from \Coq\ context-dependent
 front abstract syntax of terms (\verb=front=) to and from the
-context-free, untyped, raw form of constructions (\verb=rawconstr=).
+context-free, untyped, globalized form of constructions (\verb=glob_constr=).
 
 The modules translating back and forth the front abstract syntax are
 organized as follows.
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index c26133c6..07e813e7 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dumpglob.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 
 (* Dump of globalization (to be used by coqdoc) *)
 
@@ -33,8 +31,6 @@ let noglob () = glob_output := NoGlob
 
 let dump_to_stdout () = glob_output := StdOut; glob_file := Pervasives.stdout
 
-let multi_dump () = !glob_output = MultFiles
-
 let dump_to_dotglob f = glob_output := MultFiles
 
 let dump_into_file f = glob_output := File f; open_glob_file f
@@ -42,6 +38,23 @@ let dump_into_file f = glob_output := File f; open_glob_file f
 let dump_string s =
   if dump () then Pervasives.output_string !glob_file s
 
+let start_dump_glob vfile =
+  match !glob_output with
+  | MultFiles ->
+      open_glob_file (Filename.chop_extension vfile ^ ".glob");
+      output_string !glob_file "DIGEST ";
+      output_string !glob_file (Digest.to_hex (Digest.file vfile));
+      output_char !glob_file '\n'
+  | File f ->
+      open_glob_file f;
+      output_string !glob_file "DIGEST NO\n"
+  | NoGlob | StdOut ->
+      ()
+
+let end_dump_glob () =
+  match !glob_output with
+  | MultFiles | File _ -> close_glob_file ()
+  | NoGlob | StdOut -> ()
 
 let previous_state = ref MultFiles
 let pause () = previous_state := !glob_output; glob_output := NoGlob
@@ -163,11 +176,6 @@ let dump_constraint ((loc, n), _, _) sec ty =
     | Names.Name id -> dump_definition (loc, id) sec ty
     | Names.Anonymous -> ()
 
-let dump_name (loc, n) sec ty =
-  match n with
-    | Names.Name id -> dump_definition (loc, id) sec ty
-    | Names.Anonymous -> ()
-
 let dump_modref loc mp ty =
   if dump () then
     let (dp, l) = Lib.split_modpath mp in
@@ -192,12 +200,13 @@ let dump_libref loc dp ty =
 
 let cook_notation df sc =
   (* We encode notations so that they are space-free and still human-readable *)
-  (* - all spaces are replaced by _ *)
-  (* - all _ denoting a non-terminal symbol are replaced by x *)
-  (* - all terminal tokens are surrounded by single quotes, including '_' *)
-  (*   which already denotes terminal _ *)
-  (* - all single quotes in terminal tokens are doubled *)
-  (* The output is decoded in function Index.prepare_entry of coqdoc *)
+  (* - all spaces are replaced by _                                           *)
+  (* - all _ denoting a non-terminal symbol are replaced by x                 *)
+  (* - all terminal tokens are surrounded by single quotes, including '_'     *)
+  (*   which already denotes terminal _                                       *)
+  (* - all single quotes in terminal tokens are doubled                       *)
+  (* - characters < 32 are represented by '^A, '^B, '^C, etc                  *)
+  (* The output is decoded in function Index.prepare_entry of coqdoc          *)
   let ntn = String.make (String.length df * 3) '_' in
   let j = ref 0 in
   let l = String.length df - 1 in
@@ -211,8 +220,13 @@ let cook_notation df sc =
       (* Next token is a terminal *)
       ntn.[!j] <- '\''; incr j;
       while !i <= l && df.[!i] <> ' ' do
-	if df.[!i] = '\'' then (ntn.[!j] <- '\''; incr j);
-	ntn.[!j] <- df.[!i]; incr j; incr i
+	if df.[!i] < ' ' then
+	  let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in
+	  (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i)
+	else begin
+	  if df.[!i] = '\'' then (ntn.[!j] <- '\''; incr j);
+	  ntn.[!j] <- df.[!i]; incr j; incr i
+	end
       done;
       ntn.[!j] <- '\''; incr j
     end;
diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli
index d3215c7d..b02cc966 100644
--- a/interp/dumpglob.mli
+++ b/interp/dumpglob.mli
@@ -1,19 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dumpglob.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-
 val open_glob_file : string -> unit
 val close_glob_file : unit -> unit
 
+val start_dump_glob : string -> unit
+val end_dump_glob : unit -> unit
+
 val dump : unit -> bool
-val multi_dump : unit -> bool
 
 val noglob : unit -> unit
 val dump_to_stdout : unit -> unit
diff --git a/interp/genarg.ml b/interp/genarg.ml
index dd75bbfc..e564bd11 100644
--- a/interp/genarg.ml
+++ b/interp/genarg.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: genarg.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Nameops
 open Nametab
-open Rawterm
+open Glob_term
 open Topconstr
 open Term
 open Evd
@@ -53,11 +51,11 @@ 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 glob_constr_and_expr = glob_constr * constr_expr option
 type open_constr_expr = unit * constr_expr
-type open_rawconstr = unit * rawconstr_and_expr
+type open_glob_constr = unit * glob_constr_and_expr
 
-type rawconstr_pattern_and_expr = rawconstr_and_expr * Pattern.constr_pattern
+type glob_constr_pattern_and_expr = glob_constr_and_expr * Pattern.constr_pattern
 
 type 'a with_ebindings = 'a * open_constr bindings
 
diff --git a/interp/genarg.mli b/interp/genarg.mli
index 54b415d1..54aadba1 100644
--- a/interp/genarg.mli
+++ b/interp/genarg.mli
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: genarg.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Names
 open Term
 open Libnames
-open Rawterm
+open Glob_term
 open Pattern
 open Topconstr
 open Term
@@ -26,15 +24,15 @@ type 'a or_by_notation =
 
 val loc_of_or_by_notation : ('a -> loc) -> 'a or_by_notation -> loc
 
-(* In globalize tactics, we need to keep the initial [constr_expr] to recompute*)
-(* in the environment by the effective calls to Intro, Inversion, etc *)
-(* The [constr_expr] field is [None] in TacDef though *)
-type rawconstr_and_expr = rawconstr * constr_expr option
+(** In globalize tactics, we need to keep the initial [constr_expr] to recompute
+   in the environment by the effective calls to Intro, Inversion, etc 
+   The [constr_expr] field is [None] in TacDef though *)
+type glob_constr_and_expr = glob_constr * constr_expr option
 
 type open_constr_expr = unit * constr_expr
-type open_rawconstr = unit * rawconstr_and_expr
+type open_glob_constr = unit * glob_constr_and_expr
 
-type rawconstr_pattern_and_expr = rawconstr_and_expr * constr_pattern
+type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern
 
 type 'a with_ebindings = 'a * open_constr bindings
 
@@ -51,40 +49,41 @@ and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list
 val pr_intro_pattern : intro_pattern_expr located -> Pp.std_ppcmds
 val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds
 
-(* The route of a generic argument, from parsing to evaluation
-
-\begin{verbatim}
-             parsing        in_raw                              out_raw
-   char stream ----> rawtype ----> constr_expr generic_argument --------|
-                          encapsulation                         decaps  |
-                                                                        |
-                                                                        V
-                                                                     rawtype
-                                                                        |
-                                                         globalization  |
-                                                                        V
-                                                                    glob_type
-                                                                        |
-                                                                 encaps |
-                                                                in_glob |
-                                                                        V
-                                                     rawconstr generic_argument
-                                                                        |
-        out                          in                        out_glob |
-  type <--- constr generic_argument <---- type <------ rawtype <--------|
-    |  decaps                       encaps      interp           decaps
+(** The route of a generic argument, from parsing to evaluation.
+In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
+
+{% \begin{%}verbatim{% }%}
+             parsing          in_raw                            out_raw
+   char stream ---> raw_object ---> raw_object generic_argument -------+
+                          encapsulation                          decaps|
+                                                                       |
+                                                                       V
+                                                                   raw_object
+                                                                       |
+                                                         globalization |
+                                                                       V
+                                                                   glob_object
+                                                                       |
+                                                                encaps |
+                                                               in_glob |
+                                                                       V
+                                                           glob_object generic_argument
+                                                                       |
+          out                          in                     out_glob |
+  object <--- object generic_argument <--- object <--- glob_object <---+
+    |   decaps                       encaps      interp           decaps
     |
     V
 effective use
-\end{verbatim}
+{% \end{%}verbatim{% }%}
 
 To distinguish between the uninterpreted (raw), globalized and
 interpreted worlds, we annotate the type [generic_argument] by a
-phantom argument which is either [constr_expr], [rawconstr] or
+phantom argument which is either [constr_expr], [glob_constr] or
 [constr].
 
 Transformation for each type :
-\begin{verbatim}
+{% \begin{%}verbatim{% }%}
 tag                            raw open type            cooked closed type
 
 BoolArgType                    bool                      bool
@@ -107,10 +106,10 @@ List0ArgType of argument_type
 List1ArgType of argument_type
 OptArgType of argument_type
 ExtraArgType of string         '_a                      '_b
-\end{verbatim}
+{% \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
@@ -172,40 +171,40 @@ val rawwit_quant_hyp : (quantified_hypothesis,rlevel) abstract_argument_type
 val globwit_quant_hyp : (quantified_hypothesis,glevel) abstract_argument_type
 val wit_quant_hyp : (quantified_hypothesis,tlevel) abstract_argument_type
 
-val rawwit_sort : (rawsort,rlevel) abstract_argument_type
-val globwit_sort : (rawsort,glevel) abstract_argument_type
+val rawwit_sort : (glob_sort,rlevel) abstract_argument_type
+val globwit_sort : (glob_sort,glevel) abstract_argument_type
 val wit_sort : (sorts,tlevel) abstract_argument_type
 
 val rawwit_constr : (constr_expr,rlevel) abstract_argument_type
-val globwit_constr : (rawconstr_and_expr,glevel) abstract_argument_type
+val globwit_constr : (glob_constr_and_expr,glevel) abstract_argument_type
 val wit_constr : (constr,tlevel) abstract_argument_type
 
 val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation,constr_expr) may_eval,rlevel) abstract_argument_type
-val globwit_constr_may_eval : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var,rawconstr_pattern_and_expr) may_eval,glevel) abstract_argument_type
+val globwit_constr_may_eval : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval,glevel) abstract_argument_type
 val wit_constr_may_eval : (constr,tlevel) abstract_argument_type
 
 val rawwit_open_constr_gen : bool -> (open_constr_expr,rlevel) abstract_argument_type
-val globwit_open_constr_gen : bool -> (open_rawconstr,glevel) abstract_argument_type
+val globwit_open_constr_gen : bool -> (open_glob_constr,glevel) abstract_argument_type
 val wit_open_constr_gen : bool -> (open_constr,tlevel) abstract_argument_type
 
 val rawwit_open_constr : (open_constr_expr,rlevel) abstract_argument_type
-val globwit_open_constr : (open_rawconstr,glevel) abstract_argument_type
+val globwit_open_constr : (open_glob_constr,glevel) abstract_argument_type
 val wit_open_constr : (open_constr,tlevel) abstract_argument_type
 
 val rawwit_casted_open_constr : (open_constr_expr,rlevel) abstract_argument_type
-val globwit_casted_open_constr : (open_rawconstr,glevel) abstract_argument_type
+val globwit_casted_open_constr : (open_glob_constr,glevel) abstract_argument_type
 val wit_casted_open_constr : (open_constr,tlevel) abstract_argument_type
 
 val rawwit_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 globwit_constr_with_bindings : (glob_constr_and_expr with_bindings,glevel) abstract_argument_type
 val wit_constr_with_bindings : (constr with_bindings sigma,tlevel) abstract_argument_type
 
 val rawwit_bindings : (constr_expr bindings,rlevel) abstract_argument_type
-val globwit_bindings : (rawconstr_and_expr bindings,glevel) abstract_argument_type
+val globwit_bindings : (glob_constr_and_expr bindings,glevel) abstract_argument_type
 val wit_bindings : (constr bindings sigma,tlevel) abstract_argument_type
 
 val rawwit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,rlevel) abstract_argument_type
-val globwit_red_expr : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var,rawconstr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type
+val globwit_red_expr : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type
 val wit_red_expr : ((constr,evaluable_global_reference,constr_pattern) red_expr_gen,tlevel) abstract_argument_type
 
 val wit_list0 :
@@ -222,7 +221,7 @@ val wit_pair :
   ('b,'co) abstract_argument_type ->
       ('a * 'b,'co) abstract_argument_type
 
-(* ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *)
+(** ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *)
 type 'a generic_argument
 
 val fold_list0 :
@@ -238,7 +237,7 @@ val fold_pair :
  ('a generic_argument -> 'a generic_argument -> 'c) ->
       'a generic_argument -> 'c
 
-(* [app_list0] fails if applied to an argument not of tag [List0 t]
+(** [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) ->
@@ -255,7 +254,7 @@ val app_pair :
       ('a generic_argument -> 'b generic_argument)
    -> 'a generic_argument -> 'b generic_argument
 
-(* create a new generic type of argument: force to associate
+(** create a new generic type of argument: force to associate
    unique ML types at each of the three levels *)
 val create_arg : string ->
       ('a,tlevel) abstract_argument_type
@@ -265,7 +264,7 @@ val create_arg : string ->
 val exists_argtype : string -> bool
 
 type argument_type =
-  (* Basic types *)
+  (** Basic types *)
   | BoolArgType
   | IntArgType
   | IntOrVarArgType
@@ -275,7 +274,7 @@ type argument_type =
   | IdentArgType of bool
   | VarArgType
   | RefArgType
-  (* Specific types *)
+  (** Specific types *)
   | SortArgType
   | ConstrArgType
   | ConstrMayEvalArgType
@@ -300,7 +299,7 @@ val out_gen :
   ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a
 
 
-(* [in_generic] is used in combination with camlp4 [Gramext.action] magic
+(** [in_generic] is used in combination with camlp4 [Gramext.action] magic
 
    [in_generic: !l:type, !a:argument_type -> |a|_l -> 'l generic_argument]
 
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 88ed0873..f2739043 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: implicit_quantifiers.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Decl_kinds
@@ -18,7 +16,7 @@ open Environ
 open Nametab
 open Mod_subst
 open Util
-open Rawterm
+open Glob_term
 open Topconstr
 open Libnames
 open Typeclasses
@@ -58,14 +56,14 @@ let cache_generalizable_type (_,(local,cmd)) =
 
 let load_generalizable_type _ (_,(local,cmd)) =
   generalizable_table := add_generalizable cmd !generalizable_table
-    
-let (in_generalizable, _) =
+
+let in_generalizable : bool * identifier located list option -> obj =
   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))
 
@@ -138,33 +136,33 @@ let add_name_to_ids set na =
   | Anonymous -> set
   | Name id -> Idset.add id set
 
-let generalizable_vars_of_rawconstr ?(bound=Idset.empty) ?(allowed=Idset.empty) =
+let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty) =
   let rec vars bound vs = function
-    | RVar (loc,id) ->
+    | GVar (loc,id) ->
 	if is_freevar bound (Global.env ()) id then
 	  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) ->
+    | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args)
+    | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (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) ->
+    | GCases (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
 	List.fold_left (vars_pattern bound) vs2 pl
-    | RLetTuple (loc,nal,rtntyp,b,c) ->
+    | GLetTuple (loc,nal,rtntyp,b,c) ->
 	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) ->
+    | GIf (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) ->
+    | GRec (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 =
@@ -182,9 +180,9 @@ let generalizable_vars_of_rawconstr ?(bound=Idset.empty) ?(allowed=Idset.empty)
 	  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
+    | GCast (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
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs
 
   and vars_pattern bound vs (loc,idl,p,c) =
     let bound' = List.fold_right Idset.add idl bound  in
@@ -205,8 +203,6 @@ let generalizable_vars_of_rawconstr ?(bound=Idset.empty) ?(allowed=Idset.empty)
 let rec make_fresh ids env x =
   if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_subscript x)
 
-let next_ident_away_from id avoid = make_fresh avoid (Global.env ()) id
-
 let next_name_away_from na avoid =
   match na with
   | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon")
@@ -297,28 +293,32 @@ let implicit_application env ?(allow_partial=true) f ty =
 	    CAppExpl (loc, (None, id), args), avoid
 	in c, avoid
 
-let implicits_of_rawterm ?(with_products=true) l =
-  let rec aux i c =
-    let abs loc na bk t b =
-      let rest = aux (succ i) b in
-	if bk = Implicit then
+let implicits_of_glob_constr ?(with_products=true) l =
+  let add_impl i na bk l =
+ 	if bk = Implicit then
 	  let name =
 	    match na with
 	    | Name id -> Some id
 	    | Anonymous -> None
 	  in
-	    (ExplByPos (i, name), (true, true, true)) :: rest
-	else rest
+	    (ExplByPos (i, name), (true, true, true)) :: l
+	else l in
+  let rec aux i c =
+    let abs na bk b =
+      add_impl i na bk (aux (succ i) b)
     in
       match c with
-      | RProd (loc, na, bk, t, b) ->
-	  if with_products then abs loc na bk t b
+      | GProd (loc, na, bk, t, b) ->
+	  if with_products then abs na bk b
 	  else 
 	    (if bk = Implicit then
 	       msg_warning (str "Ignoring implicit status of product binder " ++ 
 			      pr_name na ++ str " and following binders");
 	     [])
-      | RLambda (loc, na, bk, t, b) -> abs loc na bk t b
-      | RLetIn (loc, na, t, b) -> aux i b
+      | GLambda (loc, na, bk, t, b) -> abs na bk b
+      | GLetIn (loc, na, t, b) -> aux i b
+      | GRec (_, fix_kind, nas, args, tys, bds) ->
+       let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in
+       list_fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb)
       | _ -> []
   in aux 1 l
diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli
index 4442e09d..ce518a9c 100644
--- a/interp/implicit_quantifiers.mli
+++ b/interp/implicit_quantifiers.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: implicit_quantifiers.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Decl_kinds
 open Term
@@ -17,12 +14,11 @@ open Evd
 open Environ
 open Nametab
 open Mod_subst
-open Rawterm
+open Glob_term
 open Topconstr
 open Util
 open Libnames
 open Typeclasses
-(*i*)
 
 val declare_generalizable : Vernacexpr.locality_flag -> (identifier located) list option -> unit
 
@@ -30,7 +26,7 @@ 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
 
-(* Fragile, should be used only for construction a set of identifiers to avoid *)
+(** Fragile, should be used only for construction a set of identifiers to avoid *)
 
 val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t ->
   identifier list -> identifier list
@@ -38,15 +34,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 generalizable free ids in left-to-right
+(** Returns the generalizable free ids in left-to-right
    order with the location of their first occurence *)
 
-val generalizable_vars_of_rawconstr : ?bound:Idset.t -> ?allowed:Idset.t ->
-  rawconstr -> (Names.identifier * loc) list
+val generalizable_vars_of_glob_constr : ?bound:Idset.t -> ?allowed:Idset.t ->
+  glob_constr -> (Names.identifier * loc) list
 
 val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier
 
-val implicits_of_rawterm : ?with_products:bool -> Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list
+val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits
 
 val combine_params_freevar :
   Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
diff --git a/interp/interp.mllib b/interp/interp.mllib
index 3825f3d8..546f277e 100644
--- a/interp/interp.mllib
+++ b/interp/interp.mllib
@@ -1,3 +1,4 @@
+Tok
 Lexer
 Topconstr
 Ppextend
@@ -15,4 +16,3 @@ Constrextern
 Coqlib
 Discharge
 Declare
-
diff --git a/interp/modintern.ml b/interp/modintern.ml
index f53d1796..a13560c0 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: modintern.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -16,6 +14,54 @@ open Libnames
 open Topconstr
 open Constrintern
 
+type module_internalization_error =
+  | NotAModuleNorModtype of string
+  | IncorrectWithInModule
+  | IncorrectModuleApplication
+
+exception ModuleInternalizationError of module_internalization_error
+
+(*
+val error_declaration_not_path : module_struct_entry -> 'a
+
+val error_not_a_functor :  module_struct_entry -> 'a
+
+val error_not_equal : module_path -> module_path -> 'a
+
+val error_result_must_be_signature : unit -> 'a
+
+oval error_not_a_modtype_loc : loc -> string -> 'a
+
+val error_not_a_module_loc : loc -> string -> 'a
+
+val error_not_a_module_or_modtype_loc : loc -> string -> 'a
+
+val error_with_in_module : unit -> 'a
+
+val error_application_to_module_type : unit -> 'a
+*)
+
+let error_result_must_be_signature () =
+  error "The result module type must be a signature."
+
+let error_not_a_modtype_loc loc s =
+  Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModuleType s))
+
+let error_not_a_module_loc loc s =
+  Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModule s))
+
+let error_not_a_module_nor_modtype_loc loc s =
+  Compat.Loc.raise loc (ModuleInternalizationError (NotAModuleNorModtype s))
+
+let error_incorrect_with_in_module loc =
+  Compat.Loc.raise loc (ModuleInternalizationError IncorrectWithInModule)
+
+let error_application_to_module_type loc =
+  Compat.Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication)
+
+
+
+
 let rec make_mp mp = function
     [] -> mp
   | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
@@ -70,7 +116,7 @@ let lookup_module (loc,qid) =
     let mp = Nametab.locate_module qid in
       Dumpglob.dump_modref loc mp "modtype"; mp
   with
-    | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid)
+    | Not_found -> error_not_a_module_loc loc (string_of_qualid qid)
 
 let lookup_modtype (loc,qid) =
   try
@@ -78,7 +124,7 @@ let lookup_modtype (loc,qid) =
       Dumpglob.dump_modref loc mp "mod"; mp
   with
     | Not_found ->
-	Modops.error_not_a_modtype_loc loc (string_of_qualid qid)
+	error_not_a_modtype_loc loc (string_of_qualid qid)
 
 let lookup_module_or_modtype (loc,qid) =
   try
@@ -88,7 +134,7 @@ let lookup_module_or_modtype (loc,qid) =
     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)
+    error_not_a_module_nor_modtype_loc loc (string_of_qualid qid)
 
 let transl_with_decl env = function
   | CWith_Module ((_,fqid),qid) ->
@@ -96,24 +142,35 @@ let transl_with_decl env = function
   | CWith_Definition ((_,fqid),c) ->
       With_Definition (fqid,interp_constr Evd.empty env c)
 
+let loc_of_module = function
+  | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc
+
+let check_module_argument_is_path me' = function
+  | CMident _ -> ()
+  | (CMapply (loc,_,_) | CMwith (loc,_,_)) ->
+      Compat.Loc.raise loc
+        (Modops.ModuleTypingError (Modops.ApplicationToNotPath me'))
+
 let rec interp_modexpr env = function
   | CMident qid ->
       MSEident (lookup_module qid)
-  | 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 ()
+  | CMapply (_,me1,me2) ->
+      let me1' = interp_modexpr env me1 in
+      let me2' = interp_modexpr env me2 in
+      check_module_argument_is_path me2' me2;
+      MSEapply(me1',me2')
+  | CMwith (loc,_,_) -> error_incorrect_with_in_module loc
 
 
 let rec interp_modtype env = function
   | CMident qid ->
       MSEident (lookup_modtype qid)
-  | CMapply (mty1,me) ->
+  | CMapply (_,mty1,me) ->
       let mty' = interp_modtype env mty1 in
       let me' = interp_modexpr env me in
-	MSEapply(mty',me')
-  | CMwith (mty,decl) ->
+      check_module_argument_is_path me' me;
+      MSEapply(mty',me')
+  | CMwith (_,mty,decl) ->
       let mty = interp_modtype env mty in
       let decl = transl_with_decl env decl in
 	MSEwith(mty,decl)
@@ -122,13 +179,14 @@ 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) ->
+  | CMapply (_,me1,me2) ->
+      let me1',ismod1 = interp_modexpr_or_modtype env me1 in
+      let me2',ismod2 = interp_modexpr_or_modtype env me2 in
+      check_module_argument_is_path me2' me2;
+      if not ismod2 then error_application_to_module_type (loc_of_module me2);
+      (MSEapply (me1',me2'), ismod1)
+  | CMwith (loc,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 ();
+      if ismod then error_incorrect_with_in_module loc;
       (MSEwith(me,decl), ismod)
diff --git a/interp/modintern.mli b/interp/modintern.mli
index e3a7cc6a..71a00c2f 100644
--- a/interp/modintern.mli
+++ b/interp/modintern.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modintern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Declarations
 open Environ
 open Entries
@@ -16,16 +13,24 @@ open Util
 open Libnames
 open Names
 open Topconstr
-(*i*)
 
-(* Module expressions and module types are interpreted relatively to
-   eventual functor or funsig arguments. *)
+(** Module internalization errors *)
+
+type module_internalization_error =
+  | NotAModuleNorModtype of string
+  | IncorrectWithInModule
+  | IncorrectModuleApplication
+
+exception ModuleInternalizationError of module_internalization_error
+
+(** Module expressions and module types are interpreted relatively to
+   possible functor or functor signature arguments. *)
 
 val interp_modtype : env -> module_ast -> module_struct_entry
 
 val interp_modexpr : env -> module_ast -> module_struct_entry
 
-(* The following function tries to interprete an ast as a module,
+(** 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 *)
 
diff --git a/interp/notation.ml b/interp/notation.ml
index 6e02c40b..8f19ab85 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: notation.ml 14820 2011-12-18 22:11:32Z herbelin $ *)
-
 (*i*)
 open Util
 open Pp
@@ -17,7 +15,7 @@ open Term
 open Nametab
 open Libnames
 open Summary
-open Rawterm
+open Glob_term
 open Topconstr
 open Ppextend
 (*i*)
@@ -73,7 +71,7 @@ let init_scope_map () =
 let declare_scope scope =
   try let _ = Gmap.find scope !scope_map in ()
   with Not_found ->
-(*    Flags.if_verbose message ("Creating scope "^scope);*)
+(*    Flags.if_warn message ("Creating scope "^scope);*)
     scope_map := Gmap.add scope empty_scope !scope_map
 
 let find_scope scope =
@@ -119,7 +117,7 @@ let discharge_scope (_,(local,_,_ as o)) =
 let classify_scope (local,_,_ as o) =
   if local then Dispose else Substitute o
 
-let (inScope,outScope) =
+let inScope : bool * bool * scope_elem -> obj =
   declare_object {(default_object "SCOPE") with
       cache_function = cache_scope;
       open_function = open_scope;
@@ -153,15 +151,15 @@ let declare_delimiters scope key =
     | 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);
+	Flags.if_warn msg_warning
+	  (str ("Overwriting previous delimiting key "^oldkey^" in scope "^scope));
 	scope_map := Gmap.add scope newsc !scope_map
   end;
   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);
+      Flags.if_warn msg_warning (str ("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
@@ -178,7 +176,7 @@ type interp_rule =
   | NotationRule of scope_name option * notation
   | SynDefRule of kernel_name
 
-(* We define keys for rawterm and aconstr to split the syntax entries
+(* We define keys for glob_constr and aconstr to split the syntax entries
    according to the key of the pattern (adapted from Chet Murthy by HH) *)
 
 type key =
@@ -189,30 +187,25 @@ 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 (make_gr ref)
-  | RRef (_,ref) -> RefKey (make_gr ref)
+let glob_prim_constr_key = function
+  | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref)
   | _ -> Oth
 
+let glob_constr_keys = function
+  | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth]
+  | GRef (_,ref) -> [RefKey (canonical_gr ref)]
+  | _ -> [Oth]
+
 let cases_pattern_key = function
-  | PatCstr (_,ref,_,_) -> RefKey (make_gr (ConstructRef ref))
+  | PatCstr (_,ref,_,_) -> RefKey (canonical_gr (ConstructRef ref))
   | _ -> Oth
 
 let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
-  | AApp (ARef ref,args) -> RefKey(make_gr ref), Some (List.length args)
+  | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
   | AList (_,_,AApp (ARef ref,args),_,_)
-  | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (make_gr ref), Some (List.length args)
-  | ARef ref -> RefKey(make_gr ref), None
+  | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args)
+  | ARef ref -> RefKey(canonical_gr ref), None
+  | AApp (_,args) -> Oth, Some (List.length args)
   | _ -> Oth, None
 
 (**********************************************************************)
@@ -221,15 +214,15 @@ let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
 type required_module = full_path * string list
 
 type 'a prim_token_interpreter =
-    loc -> 'a -> rawconstr
+    loc -> 'a -> glob_constr
 
 type cases_pattern_status = bool (* true = use prim token in patterns *)
 
 type 'a prim_token_uninterpreter =
-    rawconstr list * (rawconstr -> 'a option) * cases_pattern_status
+    glob_constr list * (glob_constr -> 'a option) * cases_pattern_status
 
 type internal_prim_token_interpreter =
-    loc -> prim_token -> required_module * (unit -> rawconstr)
+    loc -> prim_token -> required_module * (unit -> glob_constr)
 
 let prim_token_interpreter_tab =
   (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t)
@@ -246,7 +239,8 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) =
   declare_scope sc;
   add_prim_token_interpreter sc interp;
   List.iter (fun pat ->
-      Hashtbl.add prim_token_key_table (rawconstr_key pat) (sc,uninterp,b))
+      Hashtbl.add prim_token_key_table
+        (glob_prim_constr_key pat) (sc,uninterp,b))
     patl
 
 let mkNumeral n = Numeral n
@@ -353,7 +347,7 @@ let find_prim_token g loc p sc =
   (* Try for a user-defined numerical notation *)
   try
     let (_,c),df = find_notation (notation_of_prim_token p) sc in
-    g (rawconstr_of_aconstr loc c),df
+    g (glob_constr_of_aconstr loc c),df
   with Not_found ->
   (* Try for a primitive numerical notation *)
   let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in
@@ -374,7 +368,7 @@ let interp_prim_token =
   interp_prim_token_gen (fun x -> x)
 
 let interp_prim_token_cases_pattern loc p name =
-  interp_prim_token_gen (cases_pattern_of_rawconstr name) loc p
+  interp_prim_token_gen (cases_pattern_of_glob_constr name) loc p
 
 let rec interp_notation loc ntn local_scopes =
   let scopes = make_current_scopes local_scopes in
@@ -383,8 +377,11 @@ let rec interp_notation loc ntn local_scopes =
     user_err_loc
     (loc,"",str ("Unknown interpretation for notation \""^ntn^"\"."))
 
+let isGApp = function GApp _ -> true | _ -> false
+
 let uninterp_notations c =
-  Gmapl.find (rawconstr_key c) !notations_key_table
+  list_map_append (fun key -> Gmapl.find key !notations_key_table)
+    (glob_constr_keys c)
 
 let uninterp_cases_pattern_notations c =
   Gmapl.find (cases_pattern_key c) !notations_key_table
@@ -396,7 +393,8 @@ let availability_of_notation (ntn_scope,ntn) scopes =
 
 let uninterp_prim_token c =
   try
-    let (sc,numpr,_) = Hashtbl.find prim_token_key_table (rawconstr_key c) in
+    let (sc,numpr,_) =
+      Hashtbl.find prim_token_key_table (glob_prim_constr_key c) in
     match numpr c with
       | None -> raise No_match
       | Some n -> (sc,n)
@@ -407,7 +405,7 @@ let uninterp_prim_token_cases_pattern c =
     let k = cases_pattern_key c in
     let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in
     if not b then raise No_match;
-    let na,c = rawconstr_of_closed_cases_pattern c in
+    let na,c = glob_constr_of_closed_cases_pattern c in
     match numpr c with
       | None -> raise No_match
       | Some n -> (na,sc,n)
@@ -439,7 +437,8 @@ open Classops
 
 let class_scope_map = ref (Gmap.empty : (cl_typ,scope_name) Gmap.t)
 
-let _ = Gmap.add CL_SORT "type_scope" Gmap.empty
+let _ =
+  class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
 
 let declare_class_scope sc cl =
   class_scope_map := Gmap.add cl sc !class_scope_map
@@ -447,27 +446,39 @@ let declare_class_scope sc cl =
 let find_class_scope cl =
   Gmap.find cl !class_scope_map
 
-let find_class t =
-  let t, _ = decompose_app (Reductionops.whd_betaiotazeta Evd.empty t) in
-  match kind_of_term t with
-    | Var id -> CL_SECVAR id
-    | Const sp -> CL_CONST sp
-    | Ind ind_sp -> CL_IND ind_sp
-    | Prod (_,_,_) -> CL_FUN
-    | Sort _ -> CL_SORT
-    |  _ -> raise Not_found
+let find_class_scope_opt = function
+  | None -> None
+  | Some cl -> try Some (find_class_scope cl) with Not_found -> None
+
+let find_class t = fst (find_class_type Evd.empty t)
 
 (**********************************************************************)
 (* Special scopes associated to arguments of a global reference *)
 
-let rec compute_arguments_scope t =
+let rec compute_arguments_classes t =
   match kind_of_term (Reductionops.whd_betaiotazeta Evd.empty t) with
     | Prod (_,t,u) ->
-	let sc =
-	  try Some (find_class_scope (find_class t)) with Not_found -> None in
-	sc :: compute_arguments_scope u
+	let cl = try Some (find_class t) with Not_found -> None in
+	cl :: compute_arguments_classes u
     | _ -> []
 
+let compute_arguments_scope_full t =
+  let cls = compute_arguments_classes t in
+  let scs = List.map find_class_scope_opt cls in
+  scs, cls
+
+let compute_arguments_scope t = fst (compute_arguments_scope_full t)
+
+(** When merging scope list, we give priority to the first one (computed
+    by substitution), using the second one (user given or earlier automatic)
+    as fallback *)
+
+let rec merge_scope sc1 sc2 = match sc1, sc2 with
+  | [], _ -> sc2
+  | _, [] -> sc1
+  | Some sc :: sc1, _ :: sc2 -> Some sc :: merge_scope sc1 sc2
+  | None :: sc1, sco :: sc2 -> sco :: merge_scope sc1 sc2
+
 let arguments_scope = ref Refmap.empty
 
 type arguments_scope_discharge_request =
@@ -475,36 +486,47 @@ type arguments_scope_discharge_request =
   | ArgsScopeManual
   | ArgsScopeNoDischarge
 
-let load_arguments_scope _ (_,(_,r,scl)) =
+let load_arguments_scope _ (_,(_,r,scl,cls)) =
   List.iter (Option.iter check_scope) scl;
-  arguments_scope := Refmap.add r scl !arguments_scope
+  arguments_scope := Refmap.add r (scl,cls) !arguments_scope
 
 let cache_arguments_scope o =
   load_arguments_scope 1 o
 
-let subst_arguments_scope (subst,(req,r,scl)) =
-  (ArgsScopeNoDischarge,fst (subst_global subst r),scl)
+let subst_arguments_scope (subst,(req,r,scl,cls)) =
+  let r' = fst (subst_global subst r) in
+  let subst_cl cl =
+    try Option.smartmap (subst_cl_typ subst) cl with Not_found -> None in
+  let cls' = list_smartmap subst_cl cls in
+  let scl' = merge_scope (List.map find_class_scope_opt cls') scl in
+  let scl'' = List.map (Option.map Declaremods.subst_scope) scl' in
+  (ArgsScopeNoDischarge,r',scl'',cls')
 
-let discharge_arguments_scope (_,(req,r,l)) =
+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)
+  else Some (req,Lib.discharge_global r,l,[])
 
-let classify_arguments_scope (req,_,_ as obj) =
+let classify_arguments_scope (req,_,_,_ as obj) =
   if req = ArgsScopeNoDischarge then Dispose else Substitute obj
 
-let rebuild_arguments_scope (req,r,l) =
+let rebuild_arguments_scope (req,r,l,_) =
   match req with
     | ArgsScopeNoDischarge -> assert false
     | ArgsScopeAuto ->
-	(req,r,compute_arguments_scope (Global.type_of_global r))
+        let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in
+	(req,r,scs,cls)
     | ArgsScopeManual ->
 	(* Add to the manually given scopes the one found automatically
            for the extra parameters of the section *)
-	let l' = compute_arguments_scope (Global.type_of_global r) in
+	let l',cls = compute_arguments_scope_full (Global.type_of_global r) in
 	let l1,_ = list_chop (List.length l' - List.length l) l' in
-	(req,r,l1@l)
+	(req,r,l1@l,cls)
+
+type arguments_scope_obj =
+    arguments_scope_discharge_request * global_reference *
+      scope_name option list * Classops.cl_typ option list
 
-let (inArgumentsScope,outArgumentsScope) =
+let inArgumentsScope : arguments_scope_obj -> obj =
   declare_object {(default_object "ARGUMENTS-SCOPE") with
       cache_function = cache_arguments_scope;
       load_function = load_arguments_scope;
@@ -515,21 +537,22 @@ let (inArgumentsScope,outArgumentsScope) =
 
 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_gen req r (scl,cls) =
+  Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl,cls))
 
 let declare_arguments_scope local ref scl =
   let req =
     if is_local local ref then ArgsScopeNoDischarge else ArgsScopeManual in
-  declare_arguments_scope_gen req ref scl
+  declare_arguments_scope_gen req ref (scl,[])
 
 let find_arguments_scope r =
-  try Refmap.find r !arguments_scope
+  try fst (Refmap.find r !arguments_scope)
   with Not_found -> []
 
 let declare_ref_arguments_scope ref =
   let t = Global.type_of_global ref in
-  declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope t)
+  declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t)
+
 
 (********************************)
 (* Encoding notations as string *)
@@ -585,11 +608,11 @@ let pr_scope_classes sc =
     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 =
+let pr_notation_info prglob ntn c =
   str "\"" ++ str ntn ++ str "\" := " ++
-  prraw (rawconstr_of_aconstr dummy_loc c)
+  prglob (glob_constr_of_aconstr dummy_loc c)
 
-let pr_named_scope prraw scope sc =
+let pr_named_scope prglob scope sc =
  (if scope = default_scope then
    match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with
      | 0 -> str "No lonely notation"
@@ -600,14 +623,14 @@ let pr_named_scope prraw scope sc =
   ++ pr_scope_classes scope
   ++ Gmap.fold
        (fun ntn ((_,r),(_,df)) strm ->
-	 pr_notation_info prraw df r ++ fnl () ++ strm)
+	 pr_notation_info prglob df r ++ fnl () ++ strm)
        sc.notations (mt ())
 
-let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope)
+let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope)
 
-let pr_scopes prraw =
+let pr_scopes prglob =
  Gmap.fold
-   (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm)
+   (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm)
    !scope_map (mt ())
 
 let rec find_default ntn = function
@@ -627,9 +650,6 @@ let factorize_entries = function
 	  (ntn,[c],[]) l in
       (ntn,l_of_ntn)::rest
 
-let is_ident s = (* Poor analysis *)
-  String.length s <> 0 & is_letter s.[0]
-
 let browse_notation strict ntn map =
   let find =
     if String.contains ntn ' ' then (=) ntn
@@ -677,7 +697,7 @@ let interp_notation_as_global_reference loc test ntn sc =
       | [] -> error_notation_not_reference loc ntn
       | _ -> error_ambiguous_notation loc ntn
 
-let locate_notation prraw ntn scope =
+let locate_notation prglob ntn scope =
   let ntns = factorize_entries (browse_notation false ntn !scope_map) in
   let scopes = Option.fold_right push_scope scope !scope_stack in
   if ntns = [] then
@@ -690,7 +710,7 @@ let locate_notation prraw ntn scope =
       prlist
 	(fun (sc,r,(_,df)) ->
 	  hov 0 (
-	    pr_notation_info prraw df r ++ tbrk (1,2) ++
+	    pr_notation_info prglob df r ++ tbrk (1,2) ++
 	    (if sc = default_scope then mt () else (str ": " ++ str sc)) ++
 	    tbrk (1,2) ++
 	    (if Some sc = scope then str "(default interpretation)" else mt ())
@@ -726,10 +746,10 @@ let collect_notations stack =
 	    (all',ntn::knownntn))
     ([],[]) stack)
 
-let pr_visible_in_scope prraw (scope,ntns) =
+let pr_visible_in_scope prglob (scope,ntns) =
   let strm =
     List.fold_right
-      (fun (df,r) strm -> pr_notation_info prraw df r ++ fnl () ++ strm)
+      (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm)
       ntns (mt ()) in
   (if scope = default_scope then
      str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt())
@@ -737,14 +757,14 @@ let pr_visible_in_scope prraw (scope,ntns) =
      str "Visible in scope " ++ str scope)
   ++ fnl () ++ strm
 
-let pr_scope_stack prraw stack =
+let pr_scope_stack prglob stack =
   List.fold_left
-    (fun strm scntns -> strm ++ pr_visible_in_scope prraw scntns ++ fnl ())
+    (fun strm scntns -> strm ++ pr_visible_in_scope prglob scntns ++ fnl ())
     (mt ()) (collect_notations stack)
 
-let pr_visibility prraw = function
-  | Some scope -> pr_scope_stack prraw (push_scope scope !scope_stack)
-  | None -> pr_scope_stack prraw !scope_stack
+let pr_visibility prglob = function
+  | Some scope -> pr_scope_stack prglob (push_scope scope !scope_stack)
+  | None -> pr_scope_stack prglob !scope_stack
 
 (**********************************************************************)
 (* Mapping notations to concrete syntax *)
diff --git a/interp/notation.mli b/interp/notation.mli
index 33ffe7b4..f92ef94e 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -1,36 +1,31 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: notation.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Pp
 open Bigint
 open Names
 open Nametab
 open Libnames
-open Rawterm
+open Glob_term
 open Topconstr
 open Ppextend
 
-(*i*)
-
-(**********************************************************************)
-(* Scopes *)
+(** Notations *)
 
-(*s A scope is a set of interpreters for symbols + optional
+(** {6 Scopes } *)
+(** A scope is a set of interpreters for symbols + optional
    interpreter and printers for integers + optional delimiters *)
 
 type level = precedence * tolerability list
 type delimiters = string
 type scope
-type scopes (* = [scope_name list] *)
+type scopes (** = [scope_name list] *)
 
 type local_scopes = tmp_scope_name option * scope_name list
 
@@ -39,41 +34,43 @@ 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
+(** 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 *)
+(** Open scope *)
 
 val open_close_scope :
-  (* locality *) bool * (* open *) bool * scope_name -> unit
+  (** locality *) bool * (* open *) bool * scope_name -> unit
 
-(* Extend a list of scopes *)
+(** Extend a list of scopes *)
 val empty_scope_stack : scopes
 val push_scope : scope_name -> scopes -> scopes
 
-(* Declare delimiters for printing *)
+val find_scope : scope_name -> scope
+
+(** Declare delimiters for printing *)
 
 val declare_delimiters : scope_name -> delimiters -> unit
 val find_delimiters_scope : loc -> delimiters -> scope_name
 
-(*s Declare and uses back and forth an interpretation of primitive token *)
+(** {6 Declare and uses back and forth an interpretation of primitive token } *)
 
-(* A numeral interpreter is the pair of an interpreter for **integer**
+(** A numeral interpreter is the pair of an interpreter for **integer**
    numbers in terms and an optional interpreter in pattern, if
    negative numbers are not supported, the interpreter must fail with
    an appropriate error message *)
 
 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 cases_pattern_status = bool (** true = use prim token in patterns *)
 
 type 'a prim_token_interpreter =
-    loc -> 'a -> rawconstr
+    loc -> 'a -> glob_constr
 
 type 'a prim_token_uninterpreter =
-    rawconstr list * (rawconstr -> 'a option) * cases_pattern_status
+    glob_constr list * (glob_constr -> 'a option) * cases_pattern_status
 
 val declare_numeral_interpreter : scope_name -> required_module ->
   bigint prim_token_interpreter -> bigint prim_token_uninterpreter -> unit
@@ -81,28 +78,28 @@ val declare_numeral_interpreter : scope_name -> required_module ->
 val declare_string_interpreter : scope_name -> required_module ->
   string prim_token_interpreter -> string prim_token_uninterpreter -> unit
 
-(* Return the [term]/[cases_pattern] bound to a primitive token in a
+(** Return the [term]/[cases_pattern] bound to a primitive token in a
    given scope context*)
 
 val interp_prim_token : loc -> prim_token -> local_scopes ->
-  rawconstr * (notation_location * scope_name option)
+  glob_constr * (notation_location * scope_name option)
 val interp_prim_token_cases_pattern : loc -> prim_token -> name ->
   local_scopes -> cases_pattern * (notation_location * scope_name option)
 
-(* Return the primitive token associated to a [term]/[cases_pattern];
+(** Return the primitive token associated to a [term]/[cases_pattern];
    raise [No_match] if no such token *)
 
 val uninterp_prim_token :
-  rawconstr -> scope_name * prim_token
+  glob_constr -> scope_name * prim_token
 val uninterp_prim_token_cases_pattern :
   cases_pattern -> name * scope_name * prim_token
 
 val availability_of_prim_token :
   prim_token -> scope_name -> local_scopes -> delimiters option option
 
-(*s Declare and interpret back and forth a notation *)
+(** {6 Declare and interpret back and forth a notation } *)
 
-(* Binds a notation in a given scope to an interpretation *)
+(** Binds a notation in a given scope to an interpretation *)
 type interp_rule =
   | NotationRule of scope_name option * notation
   | SynDefRule of kernel_name
@@ -112,39 +109,39 @@ val declare_notation_interpretation : notation -> scope_name option ->
 
 val declare_uninterpretation : interp_rule -> interpretation -> unit
 
-(* Return the interpretation bound to a notation *)
+(** Return the interpretation bound to a notation *)
 val interp_notation : loc -> notation -> local_scopes ->
       interpretation * (notation_location * scope_name option)
 
-(* Return the possible notations for a given term *)
-val uninterp_notations : rawconstr ->
+(** Return the possible notations for a given term *)
+val uninterp_notations : glob_constr ->
       (interp_rule * interpretation * int option) list
 val uninterp_cases_pattern_notations : cases_pattern ->
       (interp_rule * interpretation * int option) list
 
-(* 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 *)
+(** 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 ->
   (scope_name option * delimiters option) option
 
-(*s Declare and test the level of a (possibly uninterpreted) notation *)
+(** {6 Declare and test the level of a (possibly uninterpreted) notation } *)
 
 val declare_notation_level : notation -> level -> unit
-val level_of_notation : notation -> level (* raise [Not_found] if no level *)
+val level_of_notation : notation -> level (** raise [Not_found] if no level *)
 
-(*s** Miscellaneous *)
+(** {6 Miscellaneous} *)
 
 val interp_notation_as_global_reference : loc -> (global_reference -> bool) ->
       notation -> delimiters option -> global_reference
 
-(* Checks for already existing notations *)
+(** Checks for already existing notations *)
 val exists_notation_in_scope : scope_name option -> notation ->
       interpretation -> bool
 
-(* Declares and looks for scopes associated to arguments of a global ref *)
+(** Declares and looks for scopes associated to arguments of a global ref *)
 val declare_arguments_scope :
-  bool (* true=local *) -> global_reference -> scope_name option list -> unit
+  bool (** true=local *) -> global_reference -> scope_name option list -> unit
 
 val find_arguments_scope : global_reference -> scope_name option list
 
@@ -153,7 +150,7 @@ val declare_ref_arguments_scope : global_reference -> unit
 
 val compute_arguments_scope : Term.types -> scope_name option list
 
-(* Building notation key *)
+(** Building notation key *)
 
 type symbol =
   | Terminal of string
@@ -164,21 +161,19 @@ type symbol =
 val make_notation_key : symbol list -> notation
 val decompose_notation_key : notation -> symbol list
 
-(* 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 ->
+(** Prints scopes (expects a pure aconstr printer) *)
+val pr_scope : (glob_constr -> std_ppcmds) -> scope_name -> std_ppcmds
+val pr_scopes : (glob_constr -> std_ppcmds) -> std_ppcmds
+val locate_notation : (glob_constr -> std_ppcmds) -> notation ->
       scope_name option -> std_ppcmds
 
-val pr_visibility: (rawconstr -> std_ppcmds) -> scope_name option -> std_ppcmds
+val pr_visibility: (glob_constr -> std_ppcmds) -> scope_name option -> std_ppcmds
 
-(**********************************************************************)
-(*s Printing rules for notations *)
+(** {6 Printing rules for notations} *)
 
-(* Declare and look for the printing rule for symbolic notations *)
+(** Declare and look for the printing rule for symbolic notations *)
 type unparsing_rule = unparsing list * precedence
 val declare_notation_printing_rule : notation -> unparsing_rule -> unit
 val find_notation_printing_rule : notation -> unparsing_rule
 
-(**********************************************************************)
-(* Rem: printing rules for primitive token are canonical *)
+(** Rem: printing rules for primitive token are canonical *)
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 71029f3f..ebf94bd8 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Pp
 open Util
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index e2c4ca98..d3be8c49 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Names
-(*i*)
 
-(*s Pretty-print. *)
+(** {6 Pretty-print. } *)
 
-(* Dealing with precedences *)
+(** Dealing with precedences *)
 
 type precedence = int
 
diff --git a/interp/reserve.ml b/interp/reserve.ml
index b0303a30..a07f5c84 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Reserved names *)
 
 open Util
@@ -17,23 +15,44 @@ open Nameops
 open Summary
 open Libobject
 open Lib
+open Topconstr
+open Libnames
+
+type key =
+  | RefKey of global_reference
+  | Oth
 
 let reserve_table = ref Idmap.empty
+let reserve_revtable = ref Gmapl.empty
+
+let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
+  | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
+  | AList (_,_,AApp (ARef ref,args),_,_)
+  | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args)
+  | ARef ref -> RefKey(canonical_gr ref), None
+  | _ -> Oth, None
 
 let cache_reserved_type (_,(id,t)) =
-  reserve_table := Idmap.add id t !reserve_table
+  let key = fst (aconstr_key t) in
+  reserve_table := Idmap.add id t !reserve_table;
+  reserve_revtable := Gmapl.add key (t,id) !reserve_revtable
 
-let (in_reserved, _) =
+let in_reserved : identifier * aconstr -> obj =
   declare_object {(default_object "RESERVED-TYPE") with
     cache_function = cache_reserved_type }
 
+let freeze_reserved () = (!reserve_table,!reserve_revtable)
+let unfreeze_reserved (r,rr) = reserve_table := r; reserve_revtable := rr
+let init_reserved () =
+  reserve_table := Idmap.empty; reserve_revtable := Gmapl.empty
+
 let _ =
   Summary.declare_summary "reserved-type"
-    { Summary.freeze_function = (fun () -> !reserve_table);
-      Summary.unfreeze_function = (fun r -> reserve_table := r);
-      Summary.init_function = (fun () -> reserve_table := Idmap.empty) }
+    { Summary.freeze_function = freeze_reserved;
+      Summary.unfreeze_function = unfreeze_reserved;
+      Summary.init_function = init_reserved }
 
-let declare_reserved_type (loc,id) t =
+let declare_reserved_type_binding (loc,id) t =
   if id <> root_of_id id then
     user_err_loc(loc,"declare_reserved_type",
     (pr_id id ++ str
@@ -45,46 +64,36 @@ let declare_reserved_type (loc,id) t =
   with Not_found -> () end;
   add_anonymous_leaf (in_reserved (id,t))
 
+let declare_reserved_type idl t =
+  List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl)
+
 let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table
 
-open Rawterm
-
-let rec unloc = function
-  | RVar (_,id) -> RVar (dummy_loc,id)
-  | RApp (_,g,args) -> RApp (dummy_loc,unloc g, List.map unloc args)
-  | RLambda (_,na,bk,ty,c) -> RLambda (dummy_loc,na,bk,unloc ty,unloc c)
-  | RProd (_,na,bk,ty,c) -> RProd (dummy_loc,na,bk,unloc ty,unloc c)
-  | RLetIn (_,na,b,c) -> RLetIn (dummy_loc,na,unloc b,unloc c)
-  | RCases (_,sty,rtntypopt,tml,pl) ->
-      RCases (dummy_loc,sty,
-        (Option.map unloc rtntypopt),
-	List.map (fun (tm,x) -> (unloc tm,x)) tml,
-        List.map (fun (_,idl,p,c) -> (dummy_loc,idl,p,unloc c)) pl)
-  | RLetTuple (_,nal,(na,po),b,c) ->
-      RLetTuple (dummy_loc,nal,(na,Option.map unloc po),unloc b,unloc c)
-  | RIf (_,c,(na,po),b1,b2) ->
-      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
-              (fun (na,k,obd,ty) -> (na,k,Option.map unloc obd, unloc ty)))
-              bl,
-            Array.map unloc tyl,
-            Array.map unloc bv)
-  | RCast (_,c, CastConv (k,t)) -> RCast (dummy_loc,unloc c, CastConv (k,unloc t))
-  | RCast (_,c, CastCoerce) -> RCast (dummy_loc,unloc c, CastCoerce)
-  | RSort (_,x) -> RSort (dummy_loc,x)
-  | RHole (_,x)  -> RHole (dummy_loc,x)
-  | RRef (_,x) -> RRef (dummy_loc,x)
-  | REvar (_,x,l) -> REvar (dummy_loc,x,l)
-  | RPatVar (_,x) -> RPatVar (dummy_loc,x)
-  | RDynamic (_,x) -> RDynamic (dummy_loc,x)
+let constr_key c =
+  try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c))))
+  with Not_found -> Oth
+
+let revert_reserved_type t =
+  try
+    let l = Gmapl.find (constr_key t) !reserve_revtable in
+    let t = Detyping.detype false [] [] t in
+    list_try_find
+      (fun (pat,id) ->
+	try let _ = match_aconstr false t ([],pat) in Name id
+	with No_match -> failwith "") l
+  with Not_found | Failure _ -> Anonymous
+
+let _ = Namegen.set_reserved_typed_name revert_reserved_type
+
+open Glob_term
 
 let anonymize_if_reserved na t = match na with
   | Name id as na ->
       (try
-	if not !Flags.raw_print & unloc t = find_reserved_type id
-	then RHole (dummy_loc,Evd.BinderType na)
+	if not !Flags.raw_print &
+	   (try aconstr_of_glob_constr [] [] t = find_reserved_type id
+            with UserError _ -> false)
+	then GHole (dummy_loc,Evd.BinderType na)
 	else t
       with Not_found -> t)
   | Anonymous -> t
diff --git a/interp/reserve.mli b/interp/reserve.mli
index fb60c038..97b22d2b 100644
--- a/interp/reserve.mli
+++ b/interp/reserve.mli
@@ -1,17 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Names
-open Rawterm
+open Glob_term
+open Topconstr
 
-val declare_reserved_type : identifier located -> rawconstr -> unit
-val find_reserved_type : identifier -> rawconstr
-val anonymize_if_reserved : name -> rawconstr -> rawconstr
+val declare_reserved_type : identifier located list -> aconstr -> unit
+val find_reserved_type : identifier -> aconstr
+val anonymize_if_reserved : name -> glob_constr -> glob_constr
diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml
index 3eb7c248..4e472b7a 100644
--- a/interp/smartlocate.ml
+++ b/interp/smartlocate.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,8 +11,6 @@
 
 (* This file provides high-level name globalization functions *)
 
-(* $Id:$ *)
-
 (* *)
 open Pp
 open Util
diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli
index 720c88bb..474058cc 100644
--- a/interp/smartlocate.mli
+++ b/interp/smartlocate.mli
@@ -1,37 +1,35 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
 open Util
 open Names
 open Libnames
 open Genarg
 
-(* [locate_global_with_alias] locates global reference possibly following
+(** [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" *)
+(** 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 *)
+(** Locate a reference taking into account possible "alias" notations *)
 val global_with_alias : reference -> global_reference
 
-(* The same for inductive types *)
+(** The same for inductive types *)
 val global_inductive_with_alias : reference -> inductive
 
-(* Locate a reference taking into account notations and "aliases" *)
+(** Locate a reference taking into account notations and "aliases" *)
 val smart_global : reference or_by_notation -> global_reference
 
-(* The same for inductive types *)
+(** 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 44bb02ad..8863bbbd 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: syntax_def.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Names
@@ -64,7 +62,7 @@ let subst_syntax_constant (subst,(local,pat,onlyparse)) =
 let classify_syntax_constant (local,_,_ as o) =
   if local then Dispose else Substitute o
 
-let (in_syntax_constant, out_syntax_constant) =
+let in_syntax_constant : bool * interpretation * bool -> obj =
   declare_object {(default_object "SYNTAXCONSTANT") with
     cache_function = cache_syntax_constant;
     load_function = load_syntax_constant;
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index a3f846bb..e4da52a3 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: syntax_def.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Topconstr
-open Rawterm
+open Glob_term
 open Nametab
 open Libnames
-(*i*)
 
-(* Syntactic definitions. *)
+(** Syntactic definitions. *)
 
 type syndef_interpretation = (identifier * subscopes) list * aconstr
 
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 2d4e41ec..b484d175 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -1,26 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: topconstr.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Pp
 open Util
 open Names
 open Nameops
 open Libnames
-open Rawterm
+open Glob_term
 open Term
 open Mod_subst
 (*i*)
 
 (**********************************************************************)
-(* This is the subtype of rawconstr allowed in syntactic extensions *)
+(* This is the subtype of glob_constr allowed in syntactic extensions *)
 
 (* For AList: first constr is iterator, second is terminator;
    first id is where each argument of the list has to be substituted
@@ -28,12 +26,12 @@ open Mod_subst
    boolean is associativity *)
 
 type aconstr =
-  (* Part common to rawconstr and cases_pattern *)
+  (* Part common to glob_constr and cases_pattern *)
   | ARef of global_reference
   | AVar of identifier
   | AApp of aconstr * aconstr list
   | AList of identifier * identifier * aconstr * aconstr * bool
-  (* Part only in rawconstr *)
+  (* Part only in glob_constr *)
   | ALambda of name * aconstr * aconstr
   | AProd of name * aconstr * aconstr
   | ABinderList of identifier * identifier * aconstr * aconstr
@@ -46,7 +44,7 @@ type aconstr =
   | ARec of fix_kind * identifier array *
       (name * aconstr option * aconstr) list array * aconstr array *
       aconstr array
-  | ASort of rawsort
+  | ASort of glob_sort
   | AHole of Evd.hole_kind
   | APatVar of patvar
   | ACast of aconstr * aconstr cast_type
@@ -67,7 +65,7 @@ type interpretation =
     (identifier * (subscopes * notation_var_instance_type)) list * aconstr
 
 (**********************************************************************)
-(* Re-interpret a notation as a rawconstr, taking care of binders     *)
+(* Re-interpret a notation as a glob_constr, taking care of binders     *)
 
 let name_to_ident = function
   | Anonymous -> error "This expression should be a simple identifier."
@@ -83,43 +81,43 @@ let rec cases_pattern_fold_map loc g e = function
       let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in
       e', PatCstr (loc,cstr,patl',na')
 
-let rec subst_rawvars l = function
-  | RVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
-  | RProd (loc,Name id,bk,t,c) ->
+let rec subst_glob_vars l = function
+  | GVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
+  | GProd (loc,Name id,bk,t,c) ->
       let id =
-	try match List.assoc id l with RVar(_,id') -> id' | _ -> id
+	try match List.assoc id l with GVar(_,id') -> id' | _ -> id
 	with Not_found -> id in
-      RProd (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c)
-  | RLambda (loc,Name id,bk,t,c) ->
+      GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
+  | GLambda (loc,Name id,bk,t,c) ->
       let id =
-	try match List.assoc id l with RVar(_,id') -> id' | _ -> id
+	try match List.assoc id l with GVar(_,id') -> id' | _ -> id
 	with Not_found -> id in
-      RLambda (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c)
-  | r -> map_rawconstr (subst_rawvars l) r (* assume: id is not binding *)
+      GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
+  | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *)
 
 let ldots_var = id_of_string ".."
 
-let rawconstr_of_aconstr_with_binders loc g f e = function
-  | AVar id -> RVar (loc,id)
-  | AApp (a,args) -> RApp (loc,f e a, List.map (f e) args)
+let glob_constr_of_aconstr_with_binders loc g f e = function
+  | AVar id -> GVar (loc,id)
+  | AApp (a,args) -> GApp (loc,f e a, List.map (f e) args)
   | AList (x,y,iter,tail,swap) ->
       let t = f e tail in let it = f e iter in
-      let innerl = (ldots_var,t)::(if swap then [] else [x,RVar(loc,y)]) in
-      let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in
-      let outerl = (ldots_var,inner)::(if swap then [x,RVar(loc,y)] else []) in
-      subst_rawvars outerl it
+      let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in
+      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
+      let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in
+      subst_glob_vars outerl it
   | ABinderList (x,y,iter,tail) ->
       let t = f e tail in let it = f e iter in
-      let innerl = [(ldots_var,t);(x,RVar(loc,y))] in
-      let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in
+      let innerl = [(ldots_var,t);(x,GVar(loc,y))] in
+      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
       let outerl = [(ldots_var,inner)] in
-      subst_rawvars outerl it
+      subst_glob_vars outerl it
   | ALambda (na,ty,c) ->
-      let e',na = g e na in RLambda (loc,na,Explicit,f e ty,f e' c)
+      let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c)
   | AProd (na,ty,c) ->
-      let e',na = g e na in RProd (loc,na,Explicit,f e ty,f e' c)
+      let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c)
   | ALetIn (na,b,c) ->
-      let e',na = g e na in RLetIn (loc,na,f e b,f e' c)
+      let e',na = g e na in GLetIn (loc,na,f e b,f e' c)
   | ACases (sty,rtntypopt,tml,eqnl) ->
       let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') ->
 	let e',t' = match t with
@@ -135,36 +133,36 @@ let rawconstr_of_aconstr_with_binders loc g f e = function
 	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')
+      GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl')
   | ALetTuple (nal,(na,po),b,c) ->
       let e',nal = list_fold_map g e nal in
       let e'',na = g e na in
-      RLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c)
+      GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c)
   | AIf (c,(na,po),b1,b2) ->
       let e',na = g e na in
-      RIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2)
+      GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2)
   | ARec (fk,idl,dll,tl,bl) ->
       let e,dll = array_fold_map (list_fold_map (fun e (na,oc,b) ->
 	  let e,na = g e na in
 	  (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in
       let e',idl = array_fold_map (to_id g) e idl in
-      RRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl)
-  | ACast (c,k) -> RCast (loc,f e c,
+      GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl)
+  | ACast (c,k) -> GCast (loc,f e c,
 			  match k with
 			    | CastConv (k,t) -> CastConv (k,f e t)
 			    | CastCoerce -> CastCoerce)
-  | ASort x -> RSort (loc,x)
-  | AHole x  -> RHole (loc,x)
-  | APatVar n -> RPatVar (loc,(false,n))
-  | ARef x -> RRef (loc,x)
+  | ASort x -> GSort (loc,x)
+  | AHole x  -> GHole (loc,x)
+  | APatVar n -> GPatVar (loc,(false,n))
+  | ARef x -> GRef (loc,x)
 
-let rec rawconstr_of_aconstr loc x =
+let rec glob_constr_of_aconstr loc x =
   let rec aux () x =
-    rawconstr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x
+    glob_constr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x
   in aux () x
 
 (****************************************************************************)
-(* Translating a rawconstr into a notation, interpreting recursive patterns *)
+(* Translating a glob_constr into a notation, interpreting recursive patterns *)
 
 let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r)
 let add_name r = function Anonymous -> () | Name id -> add_id r id
@@ -172,51 +170,51 @@ let add_name r = function Anonymous -> () | Name id -> add_id r id
 let split_at_recursive_part c =
   let sub = ref None in
   let rec aux = function
-  | RApp (loc0,RVar(loc,v),c::l) when v = ldots_var ->
+  | GApp (loc0,GVar(loc,v),c::l) when v = ldots_var ->
       if !sub <> None then
 	(* Not narrowed enough to find only one recursive part *)
 	raise Not_found
       else
 	(sub := Some c;
-	 if l = [] then RVar (loc,ldots_var)
-	 else RApp (loc0,RVar (loc,ldots_var),l))
-  | c -> map_rawconstr aux c in
+	 if l = [] then GVar (loc,ldots_var)
+	 else GApp (loc0,GVar (loc,ldots_var),l))
+  | c -> map_glob_constr aux c in
   let outer_iterator = aux c in
   match !sub with
   | None -> (* No recursive pattern found *) raise Not_found
   | Some c ->
   match outer_iterator with
-  | RVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found
+  | GVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found
   | _ -> outer_iterator, c
 
 let on_true_do b f c = if b then (f c; b) else b
 
-let compare_rawconstr f add t1 t2 = match t1,t2 with
-  | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2
-  | RVar (_,v1), RVar (_,v2) -> on_true_do (v1 = v2) add (Name v1)
-  | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2
-  | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1
-  | RProd (_,na1,bk1,ty1,c1), RProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
+let compare_glob_constr f add t1 t2 = match t1,t2 with
+  | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2
+  | GVar (_,v1), GVar (_,v2) -> on_true_do (v1 = v2) add (Name v1)
+  | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2
+  | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1
+  | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
       on_true_do (f ty1 ty2 & f c1 c2) add na1
-  | RHole _, RHole _ -> true
-  | RSort (_,s1), RSort (_,s2) -> s1 = s2
-  | RLetIn (_,na1,b1,c1), RLetIn (_,na2,b2,c2) when na1 = na2 ->
+  | GHole _, GHole _ -> true
+  | GSort (_,s1), GSort (_,s2) -> s1 = s2
+  | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when na1 = na2 ->
       on_true_do (f b1 b2 & f c1 c2) add na1
-  | (RCases _ | RRec _ | RDynamic _
-    | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_
-  | _,(RCases _ | RRec _ | RDynamic _
-      | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _)
+  | (GCases _ | GRec _
+    | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_
+  | _,(GCases _ | GRec _
+      | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _)
       -> error "Unsupported construction in recursive notations."
-  | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _
-    | RHole _ | RSort _ | RLetIn _), _
+  | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _
+    | GHole _ | GSort _ | GLetIn _), _
       -> false
 
-let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr (fun _ -> ()) t1 t2
+let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2
 
 let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1)
 
-let check_is_hole id = function RHole _ -> () | t ->
-  user_err_loc (loc_of_rawconstr t,"",
+let check_is_hole id = function GHole _ -> () | t ->
+  user_err_loc (loc_of_glob_constr t,"",
     strbrk "In recursive notation with binders, " ++ pr_id id ++
     strbrk " is expected to come without type.")
 
@@ -224,40 +222,40 @@ let compare_recursive_parts found f (iterator,subc) =
   let diff = ref None in
   let terminator = ref None in
   let rec aux c1 c2 = match c1,c2 with
-  | RVar(_,v), term when v = ldots_var ->
+  | GVar(_,v), term when v = ldots_var ->
       (* We found the pattern *)
       assert (!terminator = None); terminator := Some term;
       true
-  | RApp (_,RVar(_,v),l1), RApp (_,term,l2) when v = ldots_var ->
+  | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when v = ldots_var ->
       (* We found the pattern, but there are extra arguments *)
       (* (this allows e.g. alternative (recursive) notation of application) *)
       assert (!terminator = None); terminator := Some term;
       list_for_all2eq aux l1 l2
-  | RVar (_,x), RVar (_,y) when x<>y ->
+  | GVar (_,x), GVar (_,y) when x<>y ->
       (* We found the position where it differs *)
       let lassoc = (!terminator <> None) in
       let x,y = if lassoc then y,x else x,y in
       !diff = None && (diff := Some (x,y,Some lassoc); true)
-  | RLambda (_,Name x,_,t_x,c), RLambda (_,Name y,_,t_y,term)
-  | RProd (_,Name x,_,t_x,c), RProd (_,Name y,_,t_y,term) ->
+  | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term)
+  | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) ->
       (* We found a binding position where it differs *)
       check_is_hole y t_x;
       check_is_hole y t_y;
       !diff = None && (diff := Some (x,y,None); aux c term)
   | _ ->
-      compare_rawconstr aux (add_name found) c1 c2 in
+      compare_glob_constr aux (add_name found) c1 c2 in
   if aux iterator subc then
     match !diff with
     | None ->
-	let loc1 = loc_of_rawconstr iterator in
-	let loc2 = loc_of_rawconstr (Option.get !terminator) in
+	let loc1 = loc_of_glob_constr iterator in
+	let loc2 = loc_of_glob_constr (Option.get !terminator) in
 	(* Here, we would need a loc made of several parts ... *)
 	user_err_loc (subtract_loc loc1 loc2,"",
           str "Both ends of the recursive pattern are the same.")
     | Some (x,y,Some lassoc) ->
 	let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in
 	let iterator =
-	  f (if lassoc then subst_rawvars [y,RVar(dummy_loc,x)] iterator
+	  f (if lassoc then subst_glob_vars [y,GVar(dummy_loc,x)] iterator
 	  else iterator) in
 	(* found have been collected by compare_constr *)
 	found := newfound;
@@ -271,7 +269,7 @@ let compare_recursive_parts found f (iterator,subc) =
   else
     raise Not_found
 
-let aconstr_and_vars_of_rawconstr a =
+let aconstr_and_vars_of_glob_constr a =
   let found = ref ([],[],[]) in
   let rec aux c =
     let keepfound = !found in
@@ -280,7 +278,7 @@ let aconstr_and_vars_of_rawconstr a =
     with Not_found ->
     found := keepfound;
     match c with
-    | RApp (_,RVar (loc,f),[c]) when f = ldots_var ->
+    | GApp (_,GVar (loc,f),[c]) when f = ldots_var ->
 	(* Fall on the second part of the recursive pattern w/o having
 	   found the first part *)
 	user_err_loc (loc,"",
@@ -288,12 +286,12 @@ let aconstr_and_vars_of_rawconstr a =
     | c ->
 	aux' c
   and aux' = function
-  | RVar (_,id) -> add_id found id; AVar id
-  | RApp (_,g,args) -> AApp (aux g, List.map aux args)
-  | RLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c)
-  | RProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c)
-  | RLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c)
-  | RCases (_,sty,rtntypopt,tml,eqnl) ->
+  | GVar (_,id) -> add_id found id; AVar id
+  | GApp (_,g,args) -> AApp (aux g, List.map aux args)
+  | GLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c)
+  | GProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c)
+  | GLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c)
+  | GCases (_,sty,rtntypopt,tml,eqnl) ->
       let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in
       ACases (sty,Option.map aux rtntypopt,
         List.map (fun (tm,(na,x)) ->
@@ -302,28 +300,28 @@ let aconstr_and_vars_of_rawconstr a =
 	    (fun (_,_,_,nl) -> List.iter (add_name found) nl) x;
           (aux tm,(na,Option.map (fun (_,ind,n,nal) -> (ind,n,nal)) x))) tml,
         List.map f eqnl)
-  | RLetTuple (loc,nal,(na,po),b,c) ->
+  | GLetTuple (loc,nal,(na,po),b,c) ->
       add_name found na;
       List.iter (add_name found) nal;
       ALetTuple (nal,(na,Option.map aux po),aux b,aux c)
-  | RIf (loc,c,(na,po),b1,b2) ->
+  | GIf (loc,c,(na,po),b1,b2) ->
       add_name found na;
       AIf (aux c,(na,Option.map aux po),aux b1,aux b2)
-  | RRec (_,fk,idl,dll,tl,bl) ->
+  | GRec (_,fk,idl,dll,tl,bl) ->
       Array.iter (add_id found) idl;
       let dll = Array.map (List.map (fun (na,bk,oc,b) ->
 	 if bk <> Explicit then
 	   error "Binders marked as implicit not allowed in notations.";
 	 add_name found na; (na,Option.map aux oc,aux b))) dll in
       ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl)
-  | RCast (_,c,k) -> ACast (aux c,
+  | GCast (_,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
-  | RRef (_,r) -> ARef r
-  | RPatVar (_,(_,n)) -> APatVar n
-  | RDynamic _ | REvar _ ->
+  | GSort (_,s) -> ASort s
+  | GHole (_,w) -> AHole w
+  | GRef (_,r) -> ARef r
+  | GPatVar (_,(_,n)) -> APatVar n
+  | GEvar _ ->
       error "Existential variables not allowed in notations."
 
   in
@@ -372,15 +370,15 @@ let check_variables vars recvars (found,foundrec,foundrecbinding) =
     | NtnInternTypeIdent -> check_bound x in
   List.iter check_type vars
 
-let aconstr_of_rawconstr vars recvars a =
-  let a,found = aconstr_and_vars_of_rawconstr a in
+let aconstr_of_glob_constr vars recvars a =
+  let a,found = aconstr_and_vars_of_glob_constr a in
   check_variables vars recvars found;
   a
 
 (* Substitution of kernel names, avoiding a list of bound identifiers *)
 
 let aconstr_of_constr avoiding t =
- aconstr_of_rawconstr [] [] (Detyping.detype false avoiding [] t)
+ aconstr_of_glob_constr [] [] (Detyping.detype false avoiding [] t)
 
 let rec subst_pat subst pat =
   match pat with
@@ -510,9 +508,7 @@ let subst_interpretation subst (metas,pat) =
   let bound = List.map fst metas in
   (metas,subst_aconstr subst bound pat)
 
-let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l)
-
-(* Pattern-matching rawconstr and aconstr *)
+(* Pattern-matching glob_constr and aconstr *)
 
 let abstract_return_type_context pi mklam tml rtno =
   Option.map (fun rtn ->
@@ -522,19 +518,14 @@ let abstract_return_type_context pi mklam tml rtno =
     List.fold_right mklam nal rtn)
     rtno
 
-let abstract_return_type_context_rawconstr =
+let abstract_return_type_context_glob_constr =
   abstract_return_type_context (fun (_,_,_,nal) -> nal)
-    (fun na c -> RLambda(dummy_loc,na,Explicit,RHole(dummy_loc,Evd.InternalHole),c))
+    (fun na c -> GLambda(dummy_loc,na,Explicit,GHole(dummy_loc,Evd.InternalHole),c))
 
 let abstract_return_type_context_aconstr =
   abstract_return_type_context pi3
     (fun na c -> ALambda(na,AHole Evd.InternalHole,c))
 
-let rec adjust_scopes = function
-  | _,[] -> []
-  | [],a::args -> (None,a) :: adjust_scopes ([],args)
-  | sc::scopes,a::args -> (sc,a) :: adjust_scopes (scopes,args)
-
 exception No_match
 
 let rec alpha_var id1 id2 = function
@@ -552,7 +543,7 @@ let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v =
     else raise No_match
   with Not_found ->
     (* Check that no capture of binding variables occur *)
-    if List.exists (fun (id,_) ->occur_rawconstr id v) alp then raise No_match;
+    if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match;
     (* TODO: handle the case of multiple occs in different scopes *)
     ((var,v)::sigma,sigmalist,sigmabinders)
 
@@ -561,8 +552,8 @@ let bind_binder (sigma,sigmalist,sigmabinders) x bl =
 
 let match_fix_kind fk1 fk2 =
   match (fk1,fk2) with
-  | RCoFix n1, RCoFix n2 -> n1 = n2
-  | RFix (nl1,n1), RFix (nl2,n2) ->
+  | GCoFix n1, GCoFix n2 -> n1 = n2
+  | GFix (nl1,n1), GFix (nl2,n2) ->
       n1 = n2 &&
       array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2
   | _ -> false
@@ -574,7 +565,7 @@ let match_opt f sigma t1 t2 = match (t1,t2) with
 
 let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
   | (Name id1,Name id2) when List.mem id2 (fst metas) ->
-      alp, bind_env alp sigma id2 (RVar (dummy_loc,id1))
+      alp, bind_env alp sigma id2 (GVar (dummy_loc,id1))
   | (Name id1,Name id2) -> (id1,id2)::alp,sigma
   | (Anonymous,Anonymous) -> alp,sigma
   | _ -> raise No_match
@@ -588,20 +579,16 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 =
 	(match_names metas acc na1 na2) patl1 patl2
   | _ -> raise No_match
 
-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 glue_letin_with_decls = true
 
 let rec match_iterated_binders islambda decls = function
-  | RLambda (_,na,bk,t,b) when islambda ->
+  | GLambda (_,na,bk,t,b) when islambda ->
       match_iterated_binders islambda ((na,bk,None,t)::decls) b
-  | RProd (_,(Name _ as na),bk,t,b) when not islambda ->
+  | GProd (_,(Name _ as na),bk,t,b) when not islambda ->
       match_iterated_binders islambda ((na,bk,None,t)::decls) b
-  | RLetIn (loc,na,c,b) when glue_letin_with_decls ->
+  | GLetIn (loc,na,c,b) when glue_letin_with_decls ->
       match_iterated_binders islambda
-	((na,Explicit (*?*), Some c,RHole(loc,Evd.BinderType na))::decls) b
+	((na,Explicit (*?*), Some c,GHole(loc,Evd.BinderType na))::decls) b
   | b -> (decls,b)
 
 let remove_sigma x (sigmavar,sigmalist,sigmabinders) =
@@ -633,125 +620,157 @@ let match_alist match_fun metas sigma rest x iter termin lassoc =
   let l,sigma = aux sigma [] rest in
   (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma)
 
-let rec match_ alp (tmetas,blmetas as metas) sigma a1 a2 = match (a1,a2) with
+let does_not_come_from_already_eta_expanded_var =
+  (* This is hack to avoid looping on a rule with rhs of the form *)
+  (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *)
+  (* "F (fun x => H x)" and "H x" is recursively matched against the same *)
+  (* rule, giving "H (fun x' => x x')" and so on. *)
+  (* Ideally, we would need the type of the expression to know which of *)
+  (* the arguments applied to it can be eta-expanded without looping. *)
+  (* The following test is then an approximation of what can be done *)
+  (* optimally (whether other looping situations can occur remains to be *)
+  (* checked). *)
+  function GVar _ -> false | _ -> true
+
+let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 =
+  match (a1,a2) with
 
   (* Matching notation variable *)
   | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1
 
   (* Matching recursive notations for terms *)
   | r1, AList (x,_,iter,termin,lassoc) ->
-      match_alist (match_ alp) metas sigma r1 x iter termin lassoc
+      match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc
 
   (* Matching recursive notations for binders: ad hoc cases supporting let-in *)
-  | RLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)->
+  | GLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)->
       let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in
       (* TODO: address the possibility that termin is a Lambda itself *)
-      match_ alp metas (bind_binder sigma x decls) b termin
-  | RProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin)
+      match_in u alp metas (bind_binder sigma x decls) b termin
+  | GProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin)
       when na1 <> Anonymous ->
       let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in
       (* TODO: address the possibility that termin is a Prod itself *)
-      match_ alp metas (bind_binder sigma x decls) b termin
+      match_in u alp metas (bind_binder sigma x decls) b termin
   (* Matching recursive notations for binders: general case *)
   | r, ABinderList (x,_,iter,termin) ->
-      match_abinderlist_with_app (match_ alp) metas sigma r x iter termin
+      match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin
 
   (* Matching individual binders as part of a recursive pattern *)
-  | RLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas ->
-      match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
-  | RProd (_,na,bk,t,b1), AProd (Name id,_,b2)
+  | GLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas ->
+      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+  | GProd (_,na,bk,t,b1), AProd (Name id,_,b2)
       when List.mem id blmetas & na <> Anonymous ->
-      match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
 
   (* Matching compositionally *)
-  | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> 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) ->
+  | GVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
+  | GRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma
+  | GPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma
+  | GApp (loc,f1,l1), AApp (f2,l2) ->
       let n1 = List.length l1 and n2 = List.length l2 in
       let f1,l1,f2,l2 =
 	if n1 < n2 then
 	  let l21,l22 = list_chop (n2-n1) l2 in f1,l1, AApp (f2,l21), l22
 	else if n1 > n2 then
-	  let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2
+	  let l11,l12 = list_chop (n1-n2) l1 in GApp (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
-  | 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)
+      let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in
+      List.fold_left2 (match_ may_use_eta u alp metas)
+        (match_in u alp metas sigma f1 f2) l1 l2
+  | GLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GProd (_,na1,_,t1,b1), AProd (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2)
       when sty1 = sty2
 	 & List.length tml1 = List.length tml2
 	 & List.length eqnl1 = List.length eqnl2 ->
-      let rtno1' = abstract_return_type_context_rawconstr tml1 rtno1 in
+      let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in
       let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in
       let sigma =
-	try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2'
+	try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2'
 	with Option.Heterogeneous -> raise No_match
       in
       let sigma = List.fold_left2
-      (fun s (tm1,_) (tm2,_) -> match_ 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)
+      (fun s (tm1,_) (tm2,_) ->
+        match_in u alp metas s tm1 tm2) sigma tml1 tml2 in
+      List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2
+  | GLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2)
       when List.length nal1 = List.length nal2 ->
-      let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in
-      let sigma = match_ alp metas sigma b1 b2 in
+      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
+      let sigma = match_in u alp metas sigma b1 b2 in
       let (alp,sigma) =
 	List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in
-      match_ alp metas sigma c1 c2
-  | 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)
+      match_in u alp metas sigma c1 c2
+  | GIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) ->
+      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
+      List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2]
+  | GRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2)
       when match_fix_kind fk1 fk2 & Array.length idl1 =  Array.length idl2 &
 	array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2
 	->
       let alp,sigma = array_fold_left2
 	(List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) ->
 	  let sigma =
-	    match_ alp metas (match_opt (match_ alp metas) sigma oc1 oc2) b1 b2
+	    match_in u alp metas
+              (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2
 	  in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in
-      let sigma = array_fold_left2 (match_ alp metas) sigma tl1 tl2 in
+      let sigma = array_fold_left2 (match_in u alp metas) sigma tl1 tl2 in
       let alp,sigma = array_fold_right2 (fun id1 id2 alsig ->
 	match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in
-      array_fold_left2 (match_ alp metas) sigma bl1 bl2
-  | RCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) ->
-      match_ alp metas (match_ alp metas sigma c1 c2) t1 t2
-  | RCast(_,c1, CastCoerce), ACast(c2, CastCoerce) ->
-      match_ alp metas sigma c1 c2
-  | RSort (_,RType _), ASort (RType None) -> sigma
-  | RSort (_,s1), ASort s2 when s1 = s2 -> sigma
-  | RPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
+      array_fold_left2 (match_in u alp metas) sigma bl1 bl2
+  | GCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) ->
+      match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2
+  | GCast(_,c1, CastCoerce), ACast(c2, CastCoerce) ->
+      match_in u alp metas sigma c1 c2
+  | GSort (_,GType _), ASort (GType None) when not u -> sigma
+  | GSort (_,s1), ASort s2 when s1 = s2 -> sigma
+  | GPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
   | a, AHole _ -> sigma
-  | (RDynamic _ | RRec _ | REvar _), _
+
+  (* On the fly eta-expansion so as to use notations of the form
+     "exists x, P x" for "ex P"; expects type not given because don't know
+     otherwise how to ensure it corresponds to a well-typed eta-expansion;
+     ensure at least one constructor is consumed to avoid looping *)
+  | b1, ALambda (Name id,AHole _,b2) when inner ->
+      let id' = Namegen.next_ident_away id (free_glob_vars b1) in
+      match_in u alp metas (bind_binder sigma id
+       [(Name id',Explicit,None,GHole(dummy_loc,Evd.BinderType (Name id')))])
+       (mkGApp dummy_loc b1 (GVar (dummy_loc,id'))) b2
+
+  | (GRec _ | GEvar _), _
   | _,_ -> raise No_match
 
-and match_binders alp metas na1 na2 sigma b1 b2 =
+and match_in u = match_ true u
+
+and match_hd u = match_ false u
+
+and match_binders u alp metas na1 na2 sigma b1 b2 =
   let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in
-  match_ alp metas sigma b1 b2
+  match_in u alp metas sigma b1 b2
 
-and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
+and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
   (* patl1 and patl2 have the same length because they respectively
      correspond to some tml1 and tml2 that have the same length *)
   let (alp,sigma) =
     List.fold_left2 (match_cases_pattern_binders metas)
       (alp,sigma) patl1 patl2 in
-  match_ alp metas sigma rhs1 rhs2
+  match_in u alp metas sigma rhs1 rhs2
 
-let match_aconstr c (metas,pat) =
+let match_aconstr u c (metas,pat) =
   let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in
   let vars = (List.map fst (fst vars), List.map fst (snd vars)) in
-  let terms,termlists,binders = match_ [] vars ([],[],[]) c pat in
+  let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in
   (* Reorder canonically the substitution *)
   let find x =
     try List.assoc x terms
     with Not_found ->
       (* Happens for binders bound to Anonymous *)
       (* Find a better way to propagate Anonymous... *)
-      RVar (dummy_loc,x) in
+      GVar (dummy_loc,x) in
   List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') ->
     match typ with
     | NtnTypeConstr ->
@@ -824,6 +843,7 @@ type prim_token = Numeral of Bigint.bigint | String of string
 type cases_pattern_expr =
   | CPatAlias of loc * cases_pattern_expr * identifier
   | CPatCstr of loc * reference * cases_pattern_expr list
+  | CPatCstrExpl of loc * reference * cases_pattern_expr list
   | CPatAtom of loc * reference option
   | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_notation_substitution
@@ -857,13 +877,12 @@ type constr_expr =
   | CHole of loc * Evd.hole_kind option
   | CPatVar of loc * (bool * patvar)
   | CEvar of loc * existential_key * constr_expr list option
-  | CSort of loc * rawsort
+  | CSort of loc * glob_sort
   | CCast of loc * constr_expr * constr_expr cast_type
   | CNotation of loc * notation * constr_notation_substitution
   | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
   | CPrim of loc * prim_token
   | CDelimiters of loc * string * constr_expr
-  | CDynamic of loc * Dyn.t
 
 and fix_expr =
     identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
@@ -929,11 +948,11 @@ let constr_loc = function
   | CGeneralization (loc,_,_,_) -> loc
   | CPrim (loc,_) -> loc
   | CDelimiters (loc,_,_) -> loc
-  | CDynamic _ -> dummy_loc
 
 let cases_pattern_expr_loc = function
   | CPatAlias (loc,_,_) -> loc
   | CPatCstr (loc,_,_) -> loc
+  | CPatCstrExpl (loc,_,_) -> loc
   | CPatAtom (loc,_) -> loc
   | CPatOr (loc,_) -> loc
   | CPatNotation (loc,_,_) -> loc
@@ -950,10 +969,6 @@ let local_binders_loc bll =
   if bll = [] then dummy_loc else
   join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll))
 
-let occur_var_constr_ref id = function
-  | Ident (loc,id') -> id = id'
-  | Qualid _ -> false
-
 let ids_of_cases_indtype =
   let add_var ids = function CRef (Ident (_,id)) -> id::ids | _ -> ids in
   let rec vars_of = function
@@ -981,7 +996,7 @@ 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) ->
+  | CPatCstr (_,_,patl) | CPatCstrExpl (_,_,patl) | CPatOr (_,patl) ->
       List.fold_left (cases_pattern_fold_names f) a patl
   | CPatNotation (_,_,(patl,patll)) ->
       List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)
@@ -1028,7 +1043,7 @@ let fold_constr_expr_with_binders g f n acc = function
       List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll
   | CGeneralization (_,_,_,c) -> f n acc c
   | CDelimiters (loc,_,a) -> f n acc a
-  | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _  | CRef _ ->
+  | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ ->
       acc
   | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l
   | CCases (loc,sty,rtnpo,al,bl) ->
@@ -1137,9 +1152,9 @@ let split_at_annot bl na =
       let rec aux acc = function
 	| LocalRawAssum (bls, k, t) as x :: rest ->
 	    let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in
-	      if r = [] then aux (x :: acc) rest 
-	      else 
-		(List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc), 
+	      if r = [] then aux (x :: acc) rest
+	      else
+		(List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc),
 		 LocalRawAssum (r, k, t) :: rest)
 	| LocalRawDef _ as x :: rest -> aux (x :: acc) rest
 	| [] ->
@@ -1186,7 +1201,7 @@ let map_constr_expr_with_binders g f e = function
   | 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 _
-  | CPrim _ | CDynamic _ | CRef _ as x -> x
+  | CPrim _ | 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) ->
       (* TODO: apply g on the binding variables in pat... *)
@@ -1233,14 +1248,8 @@ type with_declaration_ast =
 
 type module_ast =
   | CMident of qualid located
-  | CMapply of module_ast * module_ast
-  | CMwith of module_ast * with_declaration_ast
-
-type module_ast_inl = module_ast * bool (* honor the inline annotations or not *)
-
-type 'a module_signature =
-  | Enforce of 'a (* ... : T *)
-  | Check of 'a list (* ... <: T1 <: T2, possibly empty *)
+  | CMapply of loc * module_ast * module_ast
+  | CMwith of loc * module_ast * with_declaration_ast
 
 (* Returns the ranges of locs of the notation that are not occupied by args  *)
 (* and which are then occupied by proper symbols of the notation (or spaces) *)
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index ce9de27b..4527dc48 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -1,35 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: topconstr.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
 open Libnames
-open Rawterm
+open Glob_term
 open Term
 open Mod_subst
-(*i*)
 
-(*s This is the subtype of rawconstr allowed in syntactic extensions *)
-(* No location since intended to be substituted at any place of a text *)
-(* Complex expressions such as fixpoints and cofixpoints are excluded, *)
-(* non global expressions such as existential variables also *)
+(** Topconstr: definitions of [aconstr] et [constr_expr] *)
+
+(** {6 aconstr } *)
+(** This is the subtype of glob_constr allowed in syntactic extensions 
+   No location since intended to be substituted at any place of a text 
+   Complex expressions such as fixpoints and cofixpoints are excluded, 
+   non global expressions such as existential variables also *)
 
 type aconstr =
-  (* Part common to [rawconstr] and [cases_pattern] *)
+  (** Part common to [glob_constr] and [cases_pattern] *)
   | ARef of global_reference
   | AVar of identifier
   | AApp of aconstr * aconstr list
   | AList of identifier * identifier * aconstr * aconstr * bool
-  (* Part only in [rawconstr] *)
+  (** Part only in [glob_constr] *)
   | ALambda of name * aconstr * aconstr
   | AProd of name * aconstr * aconstr
   | ABinderList of identifier * identifier * aconstr * aconstr
@@ -42,7 +41,7 @@ type aconstr =
   | ARec of fix_kind * identifier array *
       (name * aconstr option * aconstr) list array * aconstr array *
       aconstr array
-  | ASort of rawsort
+  | ASort of glob_sort
   | AHole of Evd.hole_kind
   | APatVar of patvar
   | ACast of aconstr * aconstr cast_type
@@ -68,49 +67,44 @@ type notation_var_internalization_type =
 type interpretation =
     (identifier * (subscopes * notation_var_instance_type)) list * aconstr
 
-(**********************************************************************)
-(* Translate a rawconstr into a notation given the list of variables  *)
-(* bound by the notation; also interpret recursive patterns           *)
+(** Translate a glob_constr into a notation given the list of variables
+    bound by the notation; also interpret recursive patterns           *)
 
-val aconstr_of_rawconstr :
+val aconstr_of_glob_constr :
   (identifier * notation_var_internalization_type) list ->
-  (identifier * identifier) list -> rawconstr -> aconstr
+  (identifier * identifier) list -> glob_constr -> aconstr
 
-(* Name of the special identifier used to encode recursive notations  *)
+(** Name of the special identifier used to encode recursive notations  *)
 val ldots_var : identifier
 
-(* Equality of rawconstr (warning: only partially implemented) *)
-val eq_rawconstr : rawconstr -> rawconstr -> bool
+(** Equality of glob_constr (warning: only partially implemented) *)
+val eq_glob_constr : glob_constr -> glob_constr -> bool
 
-(**********************************************************************)
-(* Re-interpret a notation as a rawconstr, taking care of binders     *)
+(** Re-interpret a notation as a glob_constr, taking care of binders     *)
 
-val rawconstr_of_aconstr_with_binders : loc ->
+val glob_constr_of_aconstr_with_binders : loc ->
   ('a -> name -> 'a * name) ->
-  ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr
+  ('a -> aconstr -> glob_constr) -> 'a -> aconstr -> glob_constr
 
-val rawconstr_of_aconstr : loc -> aconstr -> rawconstr
+val glob_constr_of_aconstr : loc -> aconstr -> glob_constr
 
-(**********************************************************************)
-(* [match_aconstr] matches a rawconstr against a notation             *)
-(* interpretation raise [No_match] if the matching fails              *)
+(** [match_aconstr] matches a glob_constr against a notation interpretation;
+    raise [No_match] if the matching fails   *)
 
 exception No_match
 
-val match_aconstr : rawconstr -> interpretation ->
-      (rawconstr * subscopes) list * (rawconstr list * subscopes) list *
-      (rawdecl list * subscopes) list
+val match_aconstr : bool -> glob_constr -> interpretation ->
+      (glob_constr * subscopes) list * (glob_constr list * subscopes) list *
+      (glob_decl list * subscopes) list
 
 val match_aconstr_cases_pattern :  cases_pattern -> interpretation ->
       (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list
 
-(**********************************************************************)
-(* Substitution of kernel names in interpretation data                *)
+(** Substitution of kernel names in interpretation data                *)
 
 val subst_interpretation : substitution -> interpretation -> interpretation
 
-(**********************************************************************)
-(*s Concrete syntax for terms                                         *)
+(** {6 Concrete syntax for terms }                                        *)
 
 type notation = string
 
@@ -119,18 +113,19 @@ type explicitation = ExplByPos of int * identifier option | ExplByName of identi
 type binder_kind =
   | Default of binding_kind
   | Generalized of binding_kind * binding_kind * bool
-      (* Inner binding, outer bindings, typeclass-specific flag
+      (** Inner binding, outer bindings, typeclass-specific flag
 	 for implicit generalization of superclasses *)
 
 type abstraction_kind = AbsLambda | AbsPi
 
-type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
+type proj_flag = int option (** [Some n] = proj of the n-th visible argument *)
 
 type prim_token = Numeral of Bigint.bigint | String of string
 
 type cases_pattern_expr =
   | CPatAlias of loc * cases_pattern_expr * identifier
   | CPatCstr of loc * reference * cases_pattern_expr list
+  | CPatCstrExpl of loc * reference * cases_pattern_expr list
   | CPatAtom of loc * reference option
   | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_notation_substitution
@@ -164,13 +159,12 @@ type constr_expr =
   | CHole of loc * Evd.hole_kind option
   | CPatVar of loc * (bool * patvar)
   | CEvar of loc * existential_key * constr_expr list option
-  | CSort of loc * rawsort
+  | CSort of loc * glob_sort
   | CCast of loc * constr_expr * constr_expr cast_type
   | CNotation of loc * notation * constr_notation_substitution
   | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
   | CPrim of loc * prim_token
   | CDelimiters of loc * string * constr_expr
-  | CDynamic of loc * Dyn.t
 
 and fix_expr =
     identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
@@ -181,7 +175,7 @@ and cofix_expr =
 and recursion_order_expr =
   | CStructRec
   | CWfRec of constr_expr
-  | CMeasureRec of constr_expr * constr_expr option (* measure, relation *)
+  | CMeasureRec of constr_expr * constr_expr option (** measure, relation *)
 
 (** Anonymous defs allowed ?? *)
 and local_binder =
@@ -199,8 +193,7 @@ and typeclass_context = typeclass_constraint list
 
 type constr_pattern_expr = constr_expr
 
-(**********************************************************************)
-(* Utilities on constr_expr                                           *)
+(** Utilities on constr_expr                                           *)
 
 val constr_loc : constr_expr -> loc
 
@@ -216,7 +209,7 @@ val occur_var_constr_expr : identifier -> constr_expr -> bool
 
 val default_binder_kind : binder_kind
 
-(* Specific function for interning "in indtype" syntax of "match" *)
+(** Specific function for interning "in indtype" syntax of "match" *)
 val ids_of_cases_indtype : constr_expr -> identifier list
 
 val mkIdentC : identifier -> constr_expr
@@ -236,32 +229,31 @@ val split_at_annot : local_binder list -> identifier located option -> local_bin
 val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
 val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
 
-(* Same as [abstract_constr_expr] and [prod_constr_expr], with location *)
+(** Same as [abstract_constr_expr] and [prod_constr_expr], with location *)
 val mkCLambdaN : loc -> local_binder list -> constr_expr -> constr_expr
 val mkCProdN : loc -> local_binder list -> constr_expr -> constr_expr
 
-(* For binders parsing *)
+(** For binders parsing *)
 
-(* With let binders *)
+(** With let binders *)
 val names_of_local_binders : local_binder list -> name located list
 
-(* Does not take let binders into account *)
+(** Does not take let binders into account *)
 val names_of_local_assums : local_binder list -> name located list
 
-(* Used in typeclasses *)
+(** Used in typeclasses *)
 
 val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) ->
    ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b
 
-(* Used in correctness and interface; absence of var capture not guaranteed *)
-(* in pattern-matching clauses and in binders of the form [x,y:T(x)] *)
+(** Used in correctness and interface; absence of var capture not guaranteed 
+   in pattern-matching clauses and in binders of the form [x,y:T(x)] *)
 
 val map_constr_expr_with_binders :
   (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) ->
       'a -> constr_expr -> constr_expr
 
-(**********************************************************************)
-(* Concrete syntax for modules and module types                       *)
+(** Concrete syntax for modules and module types                       *)
 
 type with_declaration_ast =
   | CWith_Module of identifier list located * qualid located
@@ -269,14 +261,8 @@ type with_declaration_ast =
 
 type module_ast =
   | CMident of qualid located
-  | CMapply of module_ast * module_ast
-  | CMwith of module_ast * with_declaration_ast
-
-type module_ast_inl = module_ast * bool (* honor the inline annotations or not *)
-
-type 'a module_signature =
-  | Enforce of 'a (* ... : T *)
-  | Check of 'a list (* ... <: T1 <: T2, possibly empty *)
+  | CMapply of loc * module_ast * module_ast
+  | CMwith of loc * module_ast * with_declaration_ast
 
 val ntn_loc :
   Util.loc -> constr_notation_substitution -> string -> (int * int) list
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index a0cb4f1a..aab08d89 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -81,13 +81,6 @@ sp is a local copy of the global variable extern_sp. */
 #   define print_int(i) 
 #endif
 
-/* Wrapper pour caml_modify */ 	 
-#ifdef OCAML_307 	 
-#define CAML_MODIFY(a,b) modify(a,b) 	 
-#else 	 
-#define CAML_MODIFY(a,b) caml_modify(a,b) 	 
-#endif
-
 /* GC interface */
 #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
 #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
@@ -158,7 +151,7 @@ sp is a local copy of the global variable extern_sp. */
 #endif
 #endif
 
-/* For signal handling, we highjack some code from the caml runtime */
+/* For signal handling, we hijack some code from the caml runtime */
 
 extern intnat caml_signals_are_pending;
 extern intnat caml_pending_signals[];
@@ -671,7 +664,7 @@ value coq_interprete
 	  Field(accu, 0) = sp[0];
 	  *sp = accu;
 	  /* mise a jour du block accumulate */
-	  CAML_MODIFY(&Field(p[i], 1),*sp);
+	  caml_modify(&Field(p[i], 1),*sp);
 	  sp++;
 	}
 	pc += nfunc;
@@ -842,7 +835,7 @@ value coq_interprete
       
       Instruct(SETFIELD0){
 	print_instr("SETFIELD0");
-	CAML_MODIFY(&Field(accu, 0),*sp);
+	caml_modify(&Field(accu, 0),*sp);
 	sp++;
 	Next;
       }
@@ -850,7 +843,7 @@ value coq_interprete
       Instruct(SETFIELD1){
         int i, j, size, size_aux;
 	print_instr("SETFIELD1");
-	CAML_MODIFY(&Field(accu, 1),*sp);
+	caml_modify(&Field(accu, 1),*sp);
        	sp++;
 	Next; 
       }
@@ -868,9 +861,9 @@ value coq_interprete
 	    *sp = accu;
 	    Alloc_small(accu, 1, ATOM_COFIX_TAG);
 	    Field(accu, 0) = Field(Field(*sp, 1), 0);
-	    CAML_MODIFY(&Field(*sp, 1), accu);
+	    caml_modify(&Field(*sp, 1), accu);
 	    accu = *sp; sp++;
-            CAML_MODIFY(&Field(*sp, i), accu);
+            caml_modify(&Field(*sp, i), accu);
 	  }
 	}
 	sp++;
@@ -879,7 +872,7 @@ value coq_interprete
       
       Instruct(SETFIELD){
 	print_instr("SETFIELD");
-	CAML_MODIFY(&Field(accu, *pc),*sp);
+	caml_modify(&Field(accu, *pc),*sp);
 	sp++; pc++;
 	Next;
       }	
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 91342108..00f5eb3b 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -50,12 +50,6 @@ value coq_static_alloc(value size) /* ML */
   return (value) coq_stat_alloc((asize_t) Long_val(size));
 }
 
-value coq_static_free(value blk)  /* ML */
-{
-  coq_stat_free((void *) blk);
-  return Val_unit;
-}
-
 value accumulate_code(value unit) /* ML */
 {
   return (value) accumulate;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index c0093a49..79e4d0fe 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -49,7 +49,6 @@ extern code_t accumulate;
 /* functions over global environment */
 
 value coq_static_alloc(value size);  /* ML */
-value coq_static_free(value string); /* ML */
 
 value init_coq_vm(value unit); /* ML */
 value re_init_coq_vm(value unit); /* ML */
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
index 0a61ad79..86bee72e 100644
--- a/kernel/byterun/int64_emul.h
+++ b/kernel/byterun/int64_emul.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
 /* 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..8a6a2664 100644
--- a/kernel/byterun/int64_native.h
+++ b/kernel/byterun/int64_native.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
 /* Wrapper macros around native 64-bit integer arithmetic,
    so that it has the same interface as the software emulation
    provided in int64_emul.h */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index f4d0bb2b..8854f854 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+   bytecode-based reduction machine, Oct 2004 *)
+(* Support for native arithmetics by Arnaud Spiwack, May 2007 *)
+
+(* This file defines the type of bytecode instructions *)
+
 open Names
 open Term
 
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index f4dc0b14..c5d483ac 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: cbytecodes.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
 open Names
 open Term
 
@@ -38,42 +48,43 @@ type instruction =
   | Kpush
   | Kpop of int
   | Kpush_retaddr of Label.t
-  | Kapply of int                       (*  number of arguments *)
-  | Kappterm of int * int               (* number of arguments, slot size *)
-  | Kreturn of int                      (* slot size *)
+  | Kapply of int                       (**  number of arguments *)
+  | Kappterm of int * int               (** number of arguments, slot size *)
+  | Kreturn of int                      (** slot size *)
   | Kjump
   | Krestart
-  | Kgrab of int                        (* number of arguments *)
-  | Kgrabrec of int                     (* rec arg *)
-  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | 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
-                   (* nb fv, init, lbl types, lbl bodies *)
+                   (** nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
-                   (* nb fv, init, lbl types, lbl bodies *)
+                   (** nb fv, init, lbl types, lbl bodies *)
   | Kgetglobal of constant
   | Kconst of structured_constant
-  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeblock of int * tag             (** size, tag *)
   | Kmakeprod
   | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
-  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kswitch of Label.t array * Label.t array (** consts,blocks *)
   | 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
+
+(** spiwack: instructions concerning integers *)
+  | Kbranch of Label.t                  (** jump to label, is it needed ? *)
+  | 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 *)
-  | Ksubint31                           (* subtraction modulo *)
-  | Ksubcint31                          (* subtraction, keeps the carry *)
-  | Ksubcarrycint31                     (* subtraction -1, keeps the carry *)
-  | Kmulint31                           (* multiplication modulo *)
-  | Kmulcint31                          (* multiplication, result in two
+  | Kaddcint31                          (** makes the sum and keeps the carry *)
+  | Kaddcarrycint31                     (** sum +1, keeps the carry *)
+  | Ksubint31                           (** subtraction modulo *)
+  | Ksubcint31                          (** subtraction, keeps the carry *)
+  | Ksubcarrycint31                     (** subtraction -1, keeps the carry *)
+  | Kmulint31                           (** multiplication modulo *)
+  | Kmulcint31                          (** multiplication, result in two
 					   int31, for exact computation *)
-  | Kdiv21int31                         (* divides a double size integer
+  | Kdiv21int31                         (** divides a double size integer
                                            (represented by an int31 in the
 					   accumulator and one on the top of
 					   the stack) by an int31. The result
@@ -81,23 +92,23 @@ type instruction =
 					   rest.
 					   If the divisor is 0, it returns
 					   0. *)
-  | Kdivint31                           (* euclidian division (returns a pair
+  | Kdivint31                           (** euclidian division (returns a pair
 					   quotient,rest) *)
-  | Kaddmuldivint31                     (* generic operation for shifting and
+  | Kaddmuldivint31                     (** generic operation for shifting and
 					   cycling. Takes 3 int31 i j and s,
 					   and returns x*2^s+y/(2^(31-s) *)
-  | Kcompareint31                        (* unsigned comparison of int31
+  | Kcompareint31                        (** unsigned comparison of int31
 					   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
+  | Khead0int31                         (** Give the numbers of 0 in head 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 *)
-  | Kcompint31                          (* dynamic compilation of int31 *)
-  | Kdecompint31                        (* dynamix decompilation of int31 *)
-(* /spiwack *)
+  | Kisconst of Label.t                 (** conditional jump *)
+  | Kareconst of int*Label.t            (** conditional jump *)
+  | Kcompint31                          (** dynamic compilation of int31 *)
+  | Kdecompint31                        (** dynamix decompilation of int31 
+   /spiwack *)
 
 
 and bytecodes = instruction list
@@ -107,25 +118,25 @@ type fv_elem = FVnamed of identifier | FVrel of int
 type fv = fv_elem array
 
 
-(* spiwack: this exception is expected to be raised by function expecting
+(** spiwack: this exception is expected to be raised by function expecting
             closed terms. *)
 exception NotClosed
 
 (*spiwack: both type have been moved from Cbytegen because I needed then
   for the retroknowledge *)
 type vm_env = {
-    size : int;              (* longueur de la liste [n] *)
-    fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
+    size : int;              (** longueur de la liste [n] *)
+    fv_rev : fv_elem list    (** [fvn; ... ;fv1] *)
   }
 
 
 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              *)
+    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
   }
@@ -140,7 +151,7 @@ type block =
   | Bstrconst of structured_constant
   | Bmakeblock of int * block array
   | Bconstruct_app of int * int * int * block array
-                  (* tag , nparams, arity *)
+                  (** 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 0578c7b4..8da06f43 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+   machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
 open Util
 open Names
 open Cbytecodes
@@ -339,7 +351,7 @@ let rec str_const c =
   | App(f,args) ->
       begin
 	match kind_of_term f with
-	| Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *)
+	| Construct((kn,j),i) -> 
             begin
 	    let oib = lookup_mind kn !global_env in
 	    let oip = oib.mind_packets.(j) in
@@ -409,7 +421,7 @@ let rec str_const c =
 	| _ -> Bconstr c
       end
   | Ind ind -> Bstrconst (Const_ind ind)
-  | Construct ((kn,j),i) ->  (*arnaud: Construct ((kn,j),i as cstr) ->  *)
+  | Construct ((kn,j),i) ->  
       begin
       (* spiwack: tries first to apply the run-time compilation
            behavior of the constructor, as in 2/ above *)
@@ -668,19 +680,6 @@ and compile_str_cst reloc sc sz cont =
 (* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
 and compile_const =
-(*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
-     fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
-     Kclosure(lbl, 0)::cont
-  in *)
   fun reloc-> fun  kn -> fun args -> fun sz -> fun cont ->
   let nargs = Array.length args in
   (* spiwack: checks if there is a specific way to compile the constant
@@ -715,18 +714,11 @@ let compile env c =
   Format.print_flush();  *)
   init_code,!fun_code, Array.of_list fv
 
-let compile_constant_body env body opaque boxed =
-  if opaque then BCconstant
-  else match body with
-  | None -> BCconstant
-  | Some sb ->
+let compile_constant_body env = function
+  | Undef _ | OpaqueDef _ -> BCconstant
+  | Def sb ->
       let body = Declarations.force sb in
-      if boxed then
-	let res = compile env body in
-	let to_patch = to_memory res in
-	BCdefined(true, to_patch)
-      else
-	match kind_of_term body with
+      match kind_of_term body with
 	| Const kn' ->
 	    (* we use the canonical name of the constant*)
 	    let con= constant_of_kn (canonical_con kn') in
@@ -734,8 +726,11 @@ let compile_constant_body env body opaque boxed =
 	| _ ->
 	    let res = compile env body in
 	    let to_patch = to_memory res in
-	    BCdefined (false, to_patch)
+	    BCdefined to_patch
+
+(* Shortcut of the previous function used during module strengthening *)
 
+let compile_alias kn = BCallias (constant_of_kn (canonical_con kn))
 
 (* spiwack: additional function which allow different part of compilation of the
       31-bit integers *)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index f33fd6cb..d0bfd46c 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -7,20 +7,21 @@ open Pre_env
 
 
 val compile : env -> constr -> bytecodes * bytecodes * fv
-                              (* init, fun, fv *)
+                              (** init, fun, fv *)
 
-val compile_constant_body :
-    env -> constr_substituted option -> bool -> bool -> body_code
-                                 (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> body_code
 
+(** Shortcut of the previous function used during module strengthening *)
 
-(* spiwack: this function contains the information needed to perform
+val compile_alias : constant -> body_code
+
+(** 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 ->
                                structured_constant
 
-(* this function contains the information needed to perform
+(** 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 *)
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 0b4df194..1f00a70e 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+   machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
 open Names
 open Term
 open Cbytecodes
@@ -321,12 +333,12 @@ let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
 type body_code =
-  | BCdefined of bool * to_patch
+  | BCdefined of to_patch
   | BCallias of constant
   | BCconstant
 
 let subst_body_code s = function
-  | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp)
+  | BCdefined tp -> BCdefined (subst_to_patch s tp)
   | BCallias kn -> BCallias (fst (subst_con s kn))
   | BCconstant -> BCconstant
 
@@ -338,11 +350,6 @@ let force = force subst_body_code
 
 let subst_to_patch_subst = subst_substituted
 
-let is_boxed tps =
-  match force tps with
-  | BCdefined(b,_) -> b
-  | _ -> false
-
 let repr_body_code = repr_substituted
 
 let to_memory (init_code, fun_code, fv) =
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 384146d2..287c3930 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -7,6 +7,7 @@ type reloc_info =
   | Reloc_getglobal of constant
 
 type patch = reloc_info * int
+
 (* A virer *)
 val subst_patch : Mod_subst.substitution -> patch -> patch
 
@@ -23,7 +24,7 @@ type to_patch = emitcodes * (patch list) * fv
 val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
 
 type body_code =
-  | BCdefined of bool*to_patch
+  | BCdefined of to_patch
   | BCallias of constant
   | BCconstant
 
@@ -34,12 +35,10 @@ val from_val : body_code -> to_patch_substituted
 
 val force : to_patch_substituted -> body_code
 
-val is_boxed : to_patch_substituted -> bool
-
 val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
 
 val repr_body_code :
   to_patch_substituted -> Mod_subst.substitution list option * body_code
 
 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 bb68835e..143d6eb4 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -1,12 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras with Benjamin Werner's account to implement
+   a call-by-value conversion algorithm and a lazy reduction machine
+   with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Call-by-value machine moved to cbv.ml, Mar 01 *)
+(* Additional tools for module subtyping by Jacek Chrzaszcz, Aug 2002 *)
+(* Extension with closure optimization by Bruno Barras, Aug 2003 *)
+(* Support for evar reduction by Bruno Barras, Feb 2009 *)
+(* Miscellaneous other improvements by Bruno Barras, 1997-2009 *)
+
+(* This file implements a lazy reduction for the Calculus of Inductive
+   Constructions *)
 
 open Util
 open Pp
@@ -55,6 +66,9 @@ let with_stats c =
 let all_opaque = (Idpred.empty, Cpred.empty)
 let all_transparent = (Idpred.full, Cpred.full)
 
+let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
+
 module type RedFlagsSig = sig
   type reds
   type red_kind
@@ -70,7 +84,6 @@ module type RedFlagsSig = sig
   val red_add_transparent : reds -> transparent_state -> reds
   val mkflags : red_kind list -> reds
   val red_set : reds -> red_kind -> bool
-  val red_get_const : reds -> bool * evaluable_global_reference list
 end
 
 module RedFlags = (struct
@@ -145,16 +158,6 @@ module RedFlags = (struct
     | DELTA -> (* Used for Rel/Var defined in context *)
 	incr_cnt red.r_delta delta
 
-  let red_get_const red =
-    let p1,p2 = red.r_const in
-    let (b1,l1) = Idpred.elements p1 in
-    let (b2,l2) = Cpred.elements p2 in
-    if b1=b2 then
-      let l1' = List.map (fun x -> EvalVarRef x) l1 in
-      let l2' = List.map (fun x -> EvalConstRef x) l2 in
-      (b1, l1' @ l2')
-    else error "unrepresentable pair of predicate"
-
 end : RedFlagsSig)
 
 open RedFlags
@@ -511,7 +514,7 @@ let optimise_closure env c =
     let (c',(_,s)) = compact_constr (0,[]) c 1 in
     let env' =
       Array.map (fun i -> clos_rel env i) (Array.of_list s) in
-    (subs_cons (env', ESID 0),c')
+    (subs_cons (env', subs_id 0),c')
 
 let mk_lambda env t =
   let (env,t) = optimise_closure env t in
@@ -644,7 +647,7 @@ let term_of_fconstr =
       | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx
       | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
       | _ -> to_constr term_of_fconstr_lift lfts v in
-  term_of_fconstr_lift ELID
+  term_of_fconstr_lift el_id
 
 
 
@@ -679,16 +682,6 @@ let fapp_stack (m,stk) = zip m stk
    (strip_update_shift, through get_arg). *)
 
 (* optimised for the case where there are no shifts... *)
-let strip_update_shift head stk =
-  assert (head.norm <> Red);
-  let rec strip_rec h depth = function
-    | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
-    | Zupdate(m)::s ->
-        strip_rec (update m (h.norm,h.term)) depth s
-    | stk -> (depth,stk) in
-  strip_rec head 0 stk
-
-(* optimised for the case where there are no shifts... *)
 let strip_update_shift_app head stk =
   assert (head.norm <> Red);
   let rec strip_rec rstk h depth = function
@@ -705,15 +698,14 @@ let strip_update_shift_app head stk =
 
 let get_nth_arg head n stk =
   assert (head.norm <> Red);
-  let rec strip_rec rstk h depth n = function
+  let rec strip_rec rstk h n = function
     | Zshift(k) as e :: s ->
-        strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+        strip_rec (e::rstk) (lift_fconstr k h) n s
     | Zapp args::s' ->
         let q = Array.length args in
         if n >= q
         then
-          strip_rec (Zapp args::rstk)
-            {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
+          strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s'
         else
           let bef = Array.sub args 0 n in
           let aft = Array.sub args (n+1) (q-n-1) in
@@ -721,9 +713,9 @@ let get_nth_arg head n stk =
             List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
           (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) depth n s
+        strip_rec rstk (update m (h.norm,h.term)) n s
     | s -> (None, List.rev rstk @ s) in
-  strip_rec [] head 0 n stk
+  strip_rec [] 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 *)
@@ -746,6 +738,12 @@ let rec get_args n tys f e stk =
           get_args (n-na) etys f (subs_cons(l,e)) s
     | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
 
+(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
+let rec eta_expand_stack = function
+  | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+      e :: eta_expand_stack s
+  | [] ->
+      [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
 
 (* Iota reduction: extract the arguments to be passed to the Case
    branches *)
@@ -965,7 +963,7 @@ let whd_val info v =
 let norm_val info v =
   with_stats (lazy (kl info v))
 
-let inject = mk_clos (ESID 0)
+let inject = mk_clos (subs_id 0)
 
 let whd_stack infos m stk =
   let k = kni infos m stk in
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 9cfd9797..f4dc5db3 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -1,28 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Names
 open Term
 open Environ
 open Esubst
-(*i*)
 
-(* Flags for profiling reductions. *)
+(** Flags for profiling reductions. *)
 val stats : bool ref
 val share : bool ref
 
 val with_stats: 'a Lazy.t -> 'a
 
-(*s Delta implies all consts (both global (= by
+(** {6 ... } *)
+(** Delta implies all consts (both global (= by
   [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
   a LetIn expression is Letin reduction *)
@@ -32,12 +29,15 @@ val with_stats: 'a Lazy.t -> 'a
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
 
-(* Sets of reduction kinds. *)
+val is_transparent_variable : transparent_state -> variable -> bool
+val is_transparent_constant : transparent_state -> constant -> bool
+
+(** Sets of reduction kinds. *)
 module type RedFlagsSig = sig
   type reds
   type red_kind
 
-  (* The different kinds of reduction *)
+  (** The different kinds of reduction *)
   val fBETA : red_kind
   val fDELTA : red_kind
   val fIOTA : red_kind
@@ -45,26 +45,24 @@ module type RedFlagsSig = sig
   val fCONST : constant -> red_kind
   val fVAR : identifier -> red_kind
 
-  (* No reduction at all *)
+  (** No reduction at all *)
   val no_red : reds
 
-  (* Adds a reduction kind to a set *)
+  (** Adds a reduction kind to a set *)
   val red_add : reds -> red_kind -> reds
 
-  (* Removes a reduction kind to a set *)
+  (** Removes a reduction kind to a set *)
   val red_sub : reds -> red_kind -> reds
 
-  (* Adds a reduction kind to a set *)
+  (** Adds a reduction kind to a set *)
   val red_add_transparent : reds -> transparent_state -> reds
 
-  (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
+  (** Build a reduction set from scratch = iter [red_add] on [no_red] *)
   val mkflags : red_kind list -> reds
 
-  (* Tests if a reduction kind is set *)
+  (** Tests if a reduction kind is set *)
   val red_set : reds -> red_kind -> bool
 
-  (* Gives the constant list *)
-  val red_get_const : reds -> bool * evaluable_global_reference list
 end
 
 module RedFlags : RedFlagsSig
@@ -89,19 +87,19 @@ val create: ('a infos -> constr -> 'a) -> reds -> env ->
   (existential -> constr option) -> 'a infos
 val evar_value : 'a infos -> existential -> constr option
 
-(************************************************************************)
-(*s Lazy reduction. *)
+(***********************************************************************
+  s Lazy reduction. *)
 
-(* [fconstr] is the type of frozen constr *)
+(** [fconstr] is the type of frozen constr *)
 
 type fconstr
 
-(* [fconstr] can be accessed by using the function [fterm_of] and by
+(** [fconstr] can be accessed by using the function [fterm_of] and by
    matching on type [fterm] *)
 
 type fterm =
   | FRel of int
-  | FAtom of constr (* Metas and Sorts *)
+  | FAtom of constr (** Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
@@ -118,8 +116,8 @@ type fterm =
   | FCLOS of constr * fconstr subs
   | FLOCKED
 
-(************************************************************************)
-(*s A [stack] is a context of arguments, arguments are pushed by
+(***********************************************************************
+  s A [stack] is a context of arguments, arguments are pushed by
    [append_stack] one array at a time but popped with [decomp_stack]
    one by one *)
 
@@ -142,13 +140,15 @@ val stack_args_size : stack -> int
 val stack_tail : int -> stack -> stack
 val stack_nth : stack -> int -> fconstr
 val zip_term : (fconstr -> constr) -> constr -> stack -> constr
+val eta_expand_stack : stack -> stack
 
-(* To lazy reduce a constr, create a [clos_infos] with
+(** To lazy reduce a constr, create a [clos_infos] with
    [create_clos_infos], inject the term to reduce with [inject]; then use
    a reduction function *)
 
 val inject : constr -> fconstr
-(* mk_atom: prevents a term from being evaluated *)
+
+(** mk_atom: prevents a term from being evaluated *)
 val mk_atom : constr -> fconstr
 
 val fterm_of : fconstr -> fterm
@@ -156,33 +156,33 @@ val term_of_fconstr : fconstr -> constr
 val destFLambda :
   (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
 
-(* Global and local constant cache *)
+(** Global and local constant cache *)
 type clos_infos
 val create_clos_infos :
   ?evars:(existential->constr option) -> reds -> env -> clos_infos
 
-(* Reduction function *)
+(** Reduction function *)
 
-(* [norm_val] is for strong normalization *)
+(** [norm_val] is for strong normalization *)
 val norm_val : clos_infos -> fconstr -> constr
 
-(* [whd_val] is for weak head normalization *)
+(** [whd_val] is for weak head normalization *)
 val whd_val : clos_infos -> fconstr -> constr
 
-(* [whd_stack] performs weak head normalization in a given stack. It
+(** [whd_stack] performs weak head normalization in a given stack. It
    stops whenever a reduction is blocked. *)
 val whd_stack :
   clos_infos -> fconstr -> stack -> fconstr * stack
 
-(* Conversion auxiliary functions to do step by step normalisation *)
+(** Conversion auxiliary functions to do step by step normalisation *)
 
-(* [unfold_reference] unfolds references in a [fconstr] *)
+(** [unfold_reference] unfolds references in a [fconstr] *)
 val unfold_reference : clos_infos -> table_key -> fconstr option
 
 val eq_table_key : table_key -> table_key -> bool
 
-(************************************************************************)
-(*i This is for lazy debug *)
+(***********************************************************************
+  i This is for lazy debug *)
 
 val lift_fconstr      : int -> fconstr -> fconstr
 val lift_fconstr_vect : int -> fconstr array -> fconstr array
@@ -200,4 +200,4 @@ val kl : clos_infos -> fconstr -> constr
 val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
 val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
 
-(* End of cbn debug section i*)
+(** End of cbn debug section i*)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 3f6b77b0..92109258 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras as part of the rewriting of the conversion
+   algorithm, Nov 2001 *)
 
 open Names
 
@@ -55,12 +56,12 @@ let get_transp_state () =
 
 (* Unfold the first constant only if it is "more transparent" than the
    second one. In case of tie, expand the second one. *)
-let oracle_order k1 k2 =
+let oracle_order l2r k1 k2 =
   match get_strategy k1, get_strategy k2 with
     | Expand, _ -> true
     | Level n1, Opaque -> true
     | Level n1, Level n2 -> n1 < n2
-    | _ -> false (* expand k2 *)
+    | _ -> l2r (* use recommended default *)
 
 (* summary operations *)
 let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 9272dfe5..09ca4b92 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -1,22 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 
-(* Order on section paths for unfolding.
+(** Order on section paths for unfolding.
    If [oracle_order kn1 kn2] is true, then unfold kn1 first.
    Note: the oracle does not introduce incompleteness, it only
    tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : 'a tableKey -> 'a tableKey -> bool
+val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
 
-(* Priority for the expansion of constant in the conversion test.
+(** Priority for the expansion of constant in the conversion test.
  * Higher levels means that the expansion is less prioritary.
  * (And Expand stands for -oo, and Opaque +oo.)
  * The default value (transparent constants) is [Level 0].
@@ -26,14 +24,14 @@ val transparent : level
 
 val get_strategy : 'a tableKey -> level
 
-(* Sets the level of a constant.
+(** Sets the level of a constant.
  * Level of RelKey constant cannot be set. *)
 val set_strategy : 'a tableKey -> level -> unit
 
 val get_transp_state : unit -> transparent_state
 
-(*****************************)
-(* Summary operations *)
+(****************************
+   Summary operations *)
 type oracle
 val init     : unit -> unit
 val freeze   : unit -> oracle
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index d35c011a..02330339 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jean-Christophe Filliâtre out of V6.3 file constants.ml
+   as part of the rebuilding of Coq around a purely functional
+   abstract type-checker, Nov 1999 *)
+
+(* This module implements kernel-level discharching of local
+   declarations over global constants and inductive types *)
 
 open Pp
 open Util
@@ -99,7 +104,7 @@ let expmod_constr modlist c =
 
   in
   if modlist = empty_modlist then c
-  else under_outer_cast nf_betaiota (substrec c)
+  else substrec c
 
 let abstract_constant_type =
    List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
@@ -112,16 +117,24 @@ type recipe = {
   d_abstract : named_context;
   d_modlist : work_list }
 
-let on_body f =
-  Option.map (fun c -> Declarations.from_val (f (Declarations.force c)))
+let on_body f = function
+  | Undef inl -> Undef inl
+  | Def cs -> Def (Declarations.from_val (f (Declarations.force cs)))
+  | OpaqueDef lc ->
+    OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc)))
+
+let constr_of_def = function
+  | Undef _ -> assert false
+  | Def cs -> Declarations.force cs
+  | OpaqueDef lc -> Declarations.force_opaque lc
 
 let cook_constant env r =
   let cb = r.d_from in
   let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
-  let body =
-    on_body (fun c ->
-      abstract_constant_body (expmod_constr r.d_modlist c) hyps)
-      cb.const_body in
+  let body = on_body
+    (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps)
+    cb.const_body
+  in
   let typ = match cb.const_type with
     | NonPolymorphicType t ->
 	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
@@ -129,8 +142,7 @@ let cook_constant env r =
     | PolymorphicArity (ctx,s) ->
 	let t = mkArity (ctx,Type s.poly_level) in
 	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	let j = make_judge (force (Option.get body)) typ in
+	let j = make_judge (constr_of_def body) typ in
 	Typeops.make_polymorphic_if_constant_for_ind env j
   in
-  let boxed = Cemitcodes.is_boxed cb.const_body_code in
-  (body, typ, cb.const_constraints, cb.const_opaque, boxed,false)
+  (body, typ, cb.const_constraints)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index df7e51f2..5f31ff8c 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Declarations
 open Environ
 open Univ
 
-(*s Cooking the constants. *)
+(** {6 Cooking the constants. } *)
 
 type work_list = identifier array Cmap.t * identifier array Mindmap.t
 
@@ -24,11 +22,10 @@ type recipe = {
   d_modlist : work_list }
 
 val cook_constant :
-  env -> recipe ->
-    constr_substituted option * constant_type * constraints * bool * bool
-  * bool
+  env -> recipe -> constant_def * constant_type * constraints
+
 
-(*s Utility functions used in module [Discharge]. *)
+(** {6 Utility functions used in module [Discharge]. } *)
 
 val expmod_constr : work_list -> constr -> constr
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2b3d3fac..e8b66d09 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+   bytecode-based reduction machine, Oct 2004 *)
+(* Bug fix #1419 by Jean-Marc Notin, Mar 2007 *)
+
+(* This file manages the table of global symbols for the bytecode machine *)
+
 open Names
 open Term
 open Vm
@@ -9,7 +23,6 @@ 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"
 
 (*******************)
@@ -114,10 +127,9 @@ let rec slot_for_getglobal env kn =
 (*    Pp.msgnl(str"not yet evaluated");*)
     let pos =
       match Cemitcodes.force cb.const_body_code with
-      | BCdefined(boxed,(code,pl,fv)) ->
+      | BCdefined(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
+	set_global v
     | BCallias kn' -> slot_for_getglobal env kn'
     | BCconstant -> set_global (val_of_constant kn) in
 (*Pp.msgnl(str"value stored at: "++int pos);*)
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 894a33ef..8c1ad98b 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: csymtable.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
 open Names
 open Term
 open Pre_env
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index c18e6bb0..1a84b987 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -1,28 +1,35 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is a late renaming in May 2000 of constant.ml which
+   itself was made for V7.0 in Aug 1999 out of a dispatch by
+   Jean-Christophe Filliâtre of Chet Murthy's constants.ml in V5.10.5
+   into cooking.ml, declare.ml and constant.ml, ...; renaming done
+   because the new contents exceeded in extent what the name
+   suggested *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Declarations for the module systems added by Jacek Chrzaszcz, Aug 2002 *)
+(* Miscellaneous extensions, cleaning or restructurations by Bruno
+   Barras, Hugo Herbelin, Jean-Christophe Filliâtre, Pierre Letouzey *)
+
+(* This module defines the types of global declarations. This includes
+   global constants/axioms, mutual inductive definitions and the
+   module system *)
 
-(*i*)
 open Util
 open Names
 open Univ
 open Term
 open Sign
 open Mod_subst
-(*i*)
-
-(* This module defines the types of global declarations. This includes
-   global constants/axioms and mutual inductive definitions *)
 
 type engagement = ImpredicativeSet
 
-
 (*s Constants (internal representation) (Definition/Axiom) *)
 
 type polymorphic_arity = {
@@ -42,18 +49,61 @@ let force = force subst_mps
 
 let subst_constr_subst = subst_substituted
 
+(** Opaque proof terms are not loaded immediately, but are there
+    in a lazy form. Forcing this lazy may trigger some unmarshal of
+    the necessary structure. The ['a substituted] type isn't really great
+    here, so we store "manually" a substitution list, the younger one at top.
+*)
+
+type lazy_constr = constr_substituted Lazy.t * substitution list
+
+let force_lazy_constr (c,l) =
+  List.fold_right subst_constr_subst l (Lazy.force c)
+
+let lazy_constr_is_val (c,_) = Lazy.lazy_is_val c
+
+let make_lazy_constr c = (c, [])
+
+let force_opaque lc = force (force_lazy_constr lc)
+
+let opaque_from_val c = (Lazy.lazy_from_val (from_val c), [])
+
+let subst_lazy_constr sub (c,l) = (c,sub::l)
+
+(** Inlining level of parameters at functor applications.
+    None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
 type constant_body = {
     const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : Cemitcodes.to_patch_substituted;
-   (* const_type_code : Cemitcodes.to_patch; *)
-    const_constraints : constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : constraints }
 
-(*s Inductive types (internal representation with redundant
-    information). *)
+let body_of_constant cb = match cb.const_body with
+  | Undef _ -> None
+  | Def c -> Some c
+  | OpaqueDef lc -> Some (force_lazy_constr lc)
+
+let constant_has_body cb = match cb.const_body with
+  | Undef _ -> false
+  | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+  | OpaqueDef _ -> true
+  | Undef _ | Def _ -> false
+
+(* Substitutions of [constant_body] *)
 
 let subst_rel_declaration sub (id,copt,t as x) =
   let copt' = Option.smartmap (subst_mps sub) copt in
@@ -62,13 +112,78 @@ let subst_rel_declaration sub (id,copt,t as x) =
 
 let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
 
+(* TODO: these substitution functions could avoid duplicating things
+   when the substitution have preserved all the fields *)
+
+let subst_const_type sub arity =
+  if is_empty_subst sub then arity
+  else match arity with
+    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+
+let subst_const_def sub = function
+  | Undef inl -> Undef inl
+  | Def c -> Def (subst_constr_subst sub c)
+  | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
+
+let subst_const_body sub cb = {
+  const_hyps = (assert (cb.const_hyps=[]); []);
+  const_body = subst_const_def sub cb.const_body;
+  const_type = subst_const_type sub cb.const_type;
+  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+  const_constraints = cb.const_constraints}
+
+(* Hash-consing of [constant_body] *)
+
+let hcons_rel_decl ((n,oc,t) as d) =
+  let n' = hcons_name n
+  and oc' = Option.smartmap hcons_constr oc
+  and t' = hcons_types t
+  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
+
+let hcons_rel_context l = list_smartmap hcons_rel_decl l
+
+let hcons_polyarity ar =
+  { poly_param_levels =
+      list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels;
+    poly_level = hcons_univ ar.poly_level }
+
+let hcons_const_type = function
+  | NonPolymorphicType t ->
+    NonPolymorphicType (hcons_constr t)
+  | PolymorphicArity (ctx,s) ->
+    PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s)
+
+let hcons_const_def = function
+  | Undef inl -> Undef inl
+  | Def l_constr ->
+    let constr = force l_constr in
+    Def (from_val (hcons_constr constr))
+  | OpaqueDef lc ->
+    if lazy_constr_is_val lc then
+      let constr = force_opaque lc in
+      OpaqueDef (opaque_from_val (hcons_constr constr))
+    else OpaqueDef lc
+
+let hcons_const_body cb =
+  { cb with
+    const_body = hcons_const_def cb.const_body;
+    const_type = hcons_const_type cb.const_type;
+    const_constraints = hcons_constraints cb.const_constraints }
+
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 
 let subst_recarg sub r = match r with
-  | Norec | Mrec _  -> r
+  | Norec -> r
+  | Mrec (kn,i) -> let kn' = subst_ind sub kn in
+      if kn==kn' then r else Mrec (kn',i)
   | Imbr (kn,i) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
@@ -82,8 +197,14 @@ let mk_paths r recargs =
 
 let dest_recarg p = fst (Rtree.dest_node p)
 
+(* dest_subterms returns the sizes of each argument of each constructor of
+   an inductive object of size [p]. This should never be done for Norec,
+   because the number of sons does not correspond to the number of
+   constructors.
+ *)
 let dest_subterms p =
-  let (_,cstrs) = Rtree.dest_node p in
+  let (ra,cstrs) = Rtree.dest_node p in
+  assert (ra<>Norec);
   Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
 
 let recarg_length p j =
@@ -192,24 +313,7 @@ type mutual_inductive_body = {
 
   }
 
-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} 
-  
-let subst_arity sub = function
+let subst_indarity sub = function
 | Monomorphic s ->
     Monomorphic {
       mind_user_arity = subst_mps sub s.mind_user_arity;
@@ -223,7 +327,7 @@ let subst_mind_packet sub mbp =
     mind_typename = mbp.mind_typename;
     mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
     mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
-    mind_arity = subst_arity sub mbp.mind_arity;
+    mind_arity = subst_indarity sub mbp.mind_arity;
     mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
     mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
@@ -233,7 +337,6 @@ let subst_mind_packet sub mbp =
     mind_nb_args = mbp.mind_nb_args;
     mind_reloc_tbl = mbp.mind_reloc_tbl }
 
-
 let subst_mind sub mib =
   { mind_record = mib.mind_record ;
     mind_finite = mib.mind_finite ;
@@ -246,6 +349,26 @@ let subst_mind sub mib =
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
     mind_constraints = mib.mind_constraints  }
 
+let hcons_indarity = function
+  | Monomorphic a ->
+    Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity;
+		  mind_sort = hcons_sorts a.mind_sort }
+  | Polymorphic a -> Polymorphic (hcons_polyarity a)
+
+let hcons_mind_packet oib =
+ { oib with
+   mind_typename = hcons_ident oib.mind_typename;
+   mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
+   mind_arity = hcons_indarity oib.mind_arity;
+   mind_consnames = array_smartmap hcons_ident oib.mind_consnames;
+   mind_user_lc = array_smartmap hcons_types oib.mind_user_lc;
+   mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc }
+
+let hcons_mind mib =
+  { mib with
+    mind_packets = array_smartmap hcons_mind_packet mib.mind_packets;
+    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
+    mind_constraints = hcons_constraints mib.mind_constraints }
 
 (*s Modules: signature component specifications, module types, and
   module declarations *)
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index db706a0c..5b800ede 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -1,30 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Cemitcodes
 open Sign
 open Mod_subst
-(*i*)
 
-(* This module defines the internal representation of global
+(** This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
    inductive definitions, modules and module types *)
 
 type engagement = ImpredicativeSet
 
-(**********************************************************************)
-(*s Representation of constants (Definition/Axiom)                    *)
+(** {6 Representation of constants (Definition/Axiom) } *)
 
 type polymorphic_arity = {
   poly_param_levels : universe option list;
@@ -40,24 +35,58 @@ type constr_substituted
 val from_val : constr -> constr_substituted
 val force : constr_substituted -> constr
 
+(** Opaque proof terms are not loaded immediately, but are there
+    in a lazy form. Forcing this lazy may trigger some unmarshal of
+    the necessary structure. *)
+
+type lazy_constr
+
+val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr
+val force_lazy_constr : lazy_constr -> constr_substituted
+val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr
+val lazy_constr_is_val : lazy_constr -> bool
+
+val force_opaque : lazy_constr -> constr
+val opaque_from_val : constr -> lazy_constr
+
+(** Inlining level of parameters at functor applications.
+    None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+    transparent body, or an opaque one *)
+
+type constant_def =
+  | Undef of inline
+  | Def of constr_substituted
+  | OpaqueDef of lazy_constr
+
 type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constr_substituted option;
+    const_hyps : section_context; (** New: younger hyp at top *)
+    const_body : constant_def;
     const_type : constant_type;
     const_body_code : to_patch_substituted;
-   (*i const_type_code : to_patch;i*)
-    const_constraints : constraints;
-    const_opaque : bool;
-    const_inline : bool}
+    const_constraints : constraints }
 
+val subst_const_def : substitution -> constant_def -> constant_def
 val subst_const_body : substitution -> constant_body -> constant_body
 
-(**********************************************************************)
-(*s Representation of mutual inductive types in the kernel            *)
+(** Is there a actual body in const_body or const_body_opaque ? *)
+
+val constant_has_body : constant_body -> bool
+
+(** Accessing const_body_opaque or const_body *)
+
+val body_of_constant : constant_body -> constr_substituted option
+
+val is_opaque : constant_body -> bool
+
+(** {6 Representation of mutual inductive types in the kernel } *)
 
 type recarg =
   | Norec
-  | Mrec of int
+  | Mrec of inductive
   | Imbr of inductive
 
 val subst_recarg : substitution -> recarg -> recarg
@@ -72,12 +101,12 @@ val recarg_length : wf_paths -> int -> int
 
 val subst_wf_paths : substitution -> wf_paths -> wf_paths
 
-(*
-\begin{verbatim}
+(**
+{v
    Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
    ...
    with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
-\end{verbatim}
+v}
 *)
 
 type monomorphic_inductive_arity = {
@@ -90,94 +119,72 @@ type inductive_arity =
 | Polymorphic of polymorphic_arity
 
 type one_inductive_body = {
+(** {8 Primitive datas } *)
 
-(* Primitive datas *)
+    mind_typename : identifier; (** Name of the type: [Ii] *)
 
- (* Name of the type: [Ii] *)
-    mind_typename : identifier;
+    mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
 
- (* Arity context of [Ii] with parameters: [forall params, Ui] *)
-    mind_arity_ctxt : rel_context;
+    mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *)
 
- (* Arity sort and original user arity if monomorphic *)
-    mind_arity : inductive_arity;
+    mind_consnames : identifier array; (** Names of the constructors: [cij] *)
 
- (* Names of the constructors: [cij] *)
-    mind_consnames : identifier array;
-
- (* Types of the constructors with parameters: [forall params, Tij],
-    where the Ik are replaced by de Bruijn index in the context
-    I1:forall params, U1 ..  In:forall params, Un *)
     mind_user_lc : types array;
+ (** Types of the constructors with parameters:  [forall params, Tij],
+     where the Ik are replaced by de Bruijn index in the
+     context I1:forall params, U1 ..  In:forall params, Un *)
 
-(* Derived datas *)
+(** {8 Derived datas } *)
 
- (* Number of expected real arguments of the type (no let, no params) *)
-    mind_nrealargs : int;
+    mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
 
- (* Length of realargs context (with let, no params) *)
-    mind_nrealargs_ctxt : int;
+    mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *)
 
- (* List of allowed elimination sorts *)
-    mind_kelim : sorts_family list;
+    mind_kelim : sorts_family list; (** List of allowed elimination sorts *)
 
- (* Head normalized constructor types so that their conclusion is atomic *)
-    mind_nf_lc : types array;
+    mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *)
 
- (* Length of the signature of the constructors (with let, w/o params)
-    (not used in the kernel) *)
     mind_consnrealdecls : int array;
+ (** Length of the signature of the constructors (with let, w/o params)
+    (not used in the kernel) *)
 
- (* Signature of recursive arguments in the constructors *)
-    mind_recargs : wf_paths;
+    mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *)
 
-(* Datas for bytecode compilation *)
+(** {8 Datas for bytecode compilation } *)
 
- (* number of constant constructor *)
-    mind_nb_constant : int;
+    mind_nb_constant : int; (** number of constant constructor *)
 
- (* number of no constant constructor *)
-    mind_nb_args : int;
+    mind_nb_args : int; (** number of no constant constructor *)
 
     mind_reloc_tbl :  Cbytecodes.reloc_table;
   }
 
 type mutual_inductive_body = {
 
-  (* The component of the mutual inductive block *)
-    mind_packets : one_inductive_body array;
+    mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
 
-  (* Whether the inductive type has been declared as a record *)
-    mind_record : bool;
+    mind_record : bool;  (** Whether the inductive type has been declared as a record *)
 
-  (* Whether the type is inductive or coinductive *)
-    mind_finite : bool;
+    mind_finite : bool;  (** Whether the type is inductive or coinductive *)
 
-  (* Number of types in the block *)
-    mind_ntypes : int;
+    mind_ntypes : int;  (** Number of types in the block *)
 
-  (* Section hypotheses on which the block depends *)
-    mind_hyps : section_context;
+    mind_hyps : section_context;  (** Section hypotheses on which the block depends *)
 
-  (* Number of expected parameters *)
-    mind_nparams : int;
+    mind_nparams : int;  (** Number of expected parameters *)
 
-  (* Number of recursively uniform (i.e. ordinary) parameters *)
-    mind_nparams_rec : int;
+    mind_nparams_rec : int;  (** Number of recursively uniform (i.e. ordinary) parameters *)
 
-  (* The context of parameters (includes let-in declaration) *)
-    mind_params_ctxt : rel_context;
+    mind_params_ctxt : rel_context;  (** The context of parameters (includes let-in declaration) *)
 
-  (* Universes constraints enforced by the inductive declaration *)
-    mind_constraints : constraints;
+    mind_constraints : constraints;  (** Universes constraints enforced by the inductive declaration *)
 
   }
 
 val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 
-(**********************************************************************)
-(*s Modules: signature component specifications, module types, and
-  module declarations *)
+(** {6 Modules: signature component specifications, module types, and
+  module declarations } *)
 
 type structure_field_body =
   | SFBconst of constant_body
@@ -199,29 +206,39 @@ and with_declaration_body =
   | With_definition_body of  identifier list * constant_body
 
 and module_body =
-    {  (*absolute path of the module*)
+    {  (** absolute path of the module *)
       mod_mp : module_path;
-      (* Implementation *)
+      (** Implementation *)
       mod_expr : struct_expr_body option; 
-      (* Signature *)
+      (** Signature *)
       mod_type : struct_expr_body;
-      (* algebraic structure expression is kept 
+      (** 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  *)
+      (** set of all constraint in the module  *)
       mod_constraints : constraints;
-      (* quotiented set of equivalent constant and inductive name  *)
+      (** quotiented set of equivalent constant and inductive name  *)
       mod_delta : delta_resolver;
       mod_retroknowledge : Retroknowledge.action list}
       
 and module_type_body =
     { 
-      (*Path of the module type*)
+      (** Path of the module type *)
       typ_mp : module_path;
       typ_expr : struct_expr_body;
-      (* algebraic structure expression is kept 
+      (** 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  *)
+      (** quotiented set of equivalent constant and inductive name  *)
       typ_delta :delta_resolver}
+
+
+(** Hash-consing *)
+
+(** Here, strictly speaking, we don't perform true hash-consing
+    of the structure, but simply hash-cons all inner constr
+    and other known elements *)
+
+val hcons_const_body : constant_body -> constant_body
+val hcons_mind : mutual_inductive_body -> mutual_inductive_body
diff --git a/kernel/entries.ml b/kernel/entries.ml
index 4ca21277..a4485fac 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Univ
@@ -58,12 +56,13 @@ type mutual_inductive_entry = {
 
 type definition_entry = {
   const_entry_body   : constr;
+  const_entry_secctx : section_context option;
   const_entry_type   : types option;
-  const_entry_opaque : bool;
-  const_entry_boxed  : bool}
+  const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
 
-(* type and the inlining flag *)
-type parameter_entry = types * bool
+type parameter_entry = section_context option * types * inline 
 
 type constant_entry =
   | DefinitionEntry of definition_entry
@@ -71,14 +70,7 @@ type constant_entry =
 
 (*s Modules *)
 
-
-type specification_entry = 
-    SPEconst of constant_entry
-  | SPEmind of mutual_inductive_entry
-  | SPEmodule of module_entry
-  | SPEmodtype of module_struct_entry
-      
-and module_struct_entry = 
+type module_struct_entry =
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/entries.mli b/kernel/entries.mli
index d71b48f6..b726d0ec 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -1,43 +1,38 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Sign
-(*i*)
 
-(* This module defines the entry types for global declarations. This
+(** This module defines the entry types for global declarations. This
    information is entered in the environments. This includes global
    constants/axioms, mutual inductive definitions, modules and module
    types *)
 
 
-(*s Local entries *)
+(** {6 Local entries } *)
 
 type local_entry =
   | LocalDef of constr
   | LocalAssum of constr
 
 
-(*s Declaration of inductive types. *)
+(** {6 Declaration of inductive types. } *)
 
-(* Assume the following definition in concrete syntax:
-\begin{verbatim}
-Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
+(** Assume the following definition in concrete syntax:
+{v Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
 ...
-with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
-\end{verbatim}
-then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
-[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. v}
+
+then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1];
+[mind_entry_arity] is [Ai], defined in context [x1:X1;...;xn:Xn];
 [mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
 *)
 
@@ -53,30 +48,25 @@ type mutual_inductive_entry = {
   mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
-(*s Constants (Definition/Axiom) *)
+(** {6 Constants (Definition/Axiom) } *)
 
 type definition_entry = {
   const_entry_body   : constr;
+  const_entry_secctx : section_context option;
   const_entry_type   : types option;
-  const_entry_opaque : bool;
-  const_entry_boxed  : bool }
+  const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
 
-type parameter_entry = types * bool  (*inline flag*)
+type parameter_entry = section_context option * types * inline 
 
 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
-  | SPEmodtype of module_struct_entry
+(** {6 Modules } *)
 
-and module_struct_entry =
+type module_struct_entry =
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/environ.ml b/kernel/environ.ml
index e6fafce9..7a41e62c 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -1,12 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Author: Jean-Christophe Filliâtre as part of the rebuilding of Coq
+   around a purely functional abstract type-checker, Aug 1999 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Flag for predicativity of Set by Hugo Herbelin in Oct 2003 *)
+(* Support for virtual machine by Benjamin Grégoire in Oct 2004 *)
+(* Support for retroknowledge by Arnaud Spiwack in May 2007 *)
+(* Support for assumption dependencies by Arnaud Spiwack in May 2007 *)
+
+(* Miscellaneous maintenance by Bruno Barras, Hugo Herbelin, Jean-Marc
+   Notin, Matthieu Sozeau *)
+
+(* This file defines the type of environments on which the
+   type-checker works, together with simple related functions *)
 
 open Util
 open Names
@@ -97,7 +109,7 @@ let lookup_named id env = Sign.lookup_named id env.env_named_context
 let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
 
 let eq_named_context_val c1 c2 =
-   c1 == c2 || named_context_of_val c1 = named_context_of_val c2
+   c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
 
 (* A local const is evaluable if it is defined  *)
 
@@ -158,10 +170,10 @@ exception NotEvaluableConst of const_evaluation_result
 
 let constant_value env kn =
   let cb = lookup_constant kn env in
-  if cb.const_opaque then raise (NotEvaluableConst Opaque);
   match cb.const_body with
-    | Some l_body -> Declarations.force l_body
-    | None -> raise (NotEvaluableConst NoBody)
+    | Def l_body -> Declarations.force l_body
+    | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+    | Undef _ -> raise (NotEvaluableConst NoBody)
 
 let constant_opt_value env cst =
   try Some (constant_value env cst)
@@ -183,14 +195,9 @@ let add_mind kn mib env =
   { env with env_globals = new_globals }
 
 (* Universe constraints *)
-let set_universes g env =
-  if env.env_stratification.env_universes == g then env
-  else
-    { env with env_stratification =
-      { env.env_stratification with env_universes = g } }
 
 let add_constraints c env =
-  if c == Constraint.empty then
+  if is_empty_constraint c then
     env
   else
     let s = env.env_stratification in
diff --git a/kernel/environ.mli b/kernel/environ.mli
index a7795136..42100e4e 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -1,26 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: environ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Declarations
 open Sign
-(*i*)
 
-(*s Unsafe environments. We define here a datatype for environments.
+(** 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. *)
 
-(* Environments have the following components:
+(** Environments have the following components:
    - a context for de Bruijn variables
    - a context for de Bruijn variables vm values
    - a context for section variables and goal assumptions
@@ -50,27 +46,27 @@ val named_context_val : env -> named_context_val
 
 val engagement    : env -> engagement option
 
-(* is the local context empty *)
+(** is the local context empty *)
 val empty_context : env -> bool
 
-(************************************************************************)
-(*s Context of de Bruijn variables ([rel_context]) *)
+(** {5 Context of de Bruijn variables ([rel_context]) } *)
+
 val nb_rel           : env -> int
 val push_rel         : rel_declaration -> env -> env
 val push_rel_context :     rel_context -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
 
-(* Looks up in the context of local vars referred by indice ([rel_context]) *)
-(* raises [Not_found] if the index points out of the context *)
+(** Looks up in the context of local vars referred by indice ([rel_context]) 
+   raises [Not_found] if the index points out of the context *)
 val lookup_rel    : int -> env -> rel_declaration
 val evaluable_rel : int -> env -> bool
 
-(*s Recurrence on [rel_context] *)
+(** {6 Recurrence on [rel_context] } *)
+
 val fold_rel_context :
   (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
 
-(************************************************************************)
-(* Context of variables (section variables and goal assumptions) *)
+(** {5 Context of variables (section variables and goal assumptions) } *)
 
 val named_context_of_val : named_context_val -> named_context
 val named_vals_of_val : named_context_val -> Pre_env.named_vals
@@ -78,7 +74,7 @@ val val_of_named_context : named_context -> named_context_val
 val empty_named_context_val : named_context_val
 
 
-(* [map_named_val f ctxt] apply [f] to the body and the type of
+(** [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 :
@@ -90,8 +86,8 @@ val push_named_context_val  :
 
 
 
-(* Looks up in the context of local vars referred by names ([named_context]) *)
-(* raises [Not_found] if the identifier is not found *)
+(** Looks up in the context of local vars referred by names ([named_context]) 
+   raises [Not_found] if the identifier is not found *)
 
 val lookup_named     : variable -> env -> named_declaration
 val lookup_named_val : variable -> named_context_val -> named_declaration
@@ -99,34 +95,36 @@ 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 *)
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
 
 val fold_named_context :
   (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
 
-(* Recurrence on [named_context] starting from younger decl *)
+(** Recurrence on [named_context] starting from younger decl *)
 val fold_named_context_reverse :
   ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a
 
-(* This forgets named and rel contexts *)
+(** This forgets named and rel contexts *)
 val reset_context : env -> env
-(* This forgets rel context and sets a new named context *)
+
+(** This forgets rel context and sets a new named context *)
 val reset_with_named_context : named_context_val -> env -> env
 
-(************************************************************************)
-(*s Global constants *)
-(*s Add entries to global environment *)
-val add_constant : constant -> constant_body -> env -> env
+(** {5 Global constants }
+  {6 Add entries to global environment } *)
 
-(* Looks up in the context of global constant names *)
-(* raises [Not_found] if the required path is not found *)
+val add_constant : constant -> constant_body -> env -> env
 
+(** Looks up in the context of global constant names 
+   raises [Not_found] if the required path is not found *)
 val lookup_constant    : constant -> env -> constant_body
 val evaluable_constant : constant -> env -> bool
 
-(*s [constant_value env c] raises [NotEvaluableConst Opaque] if
+(** {6 ... } *)
+(** [constant_value env c] raises [NotEvaluableConst Opaque] if
    [c] is opaque and [NotEvaluableConst NoBody] if it has no
    body and [Not_found] if it does not exist in [env] *)
+
 type const_evaluation_result = NoBody | Opaque
 exception NotEvaluableConst of const_evaluation_result
 
@@ -134,44 +132,44 @@ val constant_value     : env -> constant -> constr
 val constant_type      : env -> constant -> constant_type
 val constant_opt_value : env -> constant -> constr option
 
-(************************************************************************)
-(*s Inductive types *)
+(** {5 Inductive types } *)
+
 val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
 
-(* Looks up in the context of global inductive names *)
-(* raises [Not_found] if the required path is not found *)
+(** Looks up in the context of global inductive names 
+   raises [Not_found] if the required path is not found *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
-(************************************************************************)
-(*s Modules *)
+(** {5 Modules } *)
+
 val add_modtype : module_path -> module_type_body -> env -> env
 
-(* [shallow_add_module] does not add module components *)
+(** [shallow_add_module] does not add module components *)
 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
 
-(************************************************************************)
-(*s Universe constraints *)
-val set_universes   :   Univ.universes -> env -> env
+(** {5 Universe constraints } *)
+
 val add_constraints : Univ.constraints -> env -> env
 
 val set_engagement : engagement -> env -> env
 
-(************************************************************************)
-(* Sets of referred section variables *)
-(* [global_vars_set env c] returns the list of [id]'s occurring either
+(** {6 Sets of referred section variables }
+   [global_vars_set env c] returns the list of [id]'s occurring either
    directly as [Var id] in [c] or indirectly as a section variable
    dependent in a global reference occurring in [c] *)
+
 val global_vars_set : env -> constr -> Idset.t
-(* the constr must be a global reference *)
+
+(** the constr must be a global reference *)
 val vars_of_global : env -> constr -> identifier list
 
 val keep_hyps : env -> Idset.t -> section_context
 
-(************************************************************************)
-(*s Unsafe judgments. We introduce here the pre-type of judgments, which is
+(** {5 Unsafe judgments. }
+    We introduce here the pre-type of judgments, which is
   actually only a datatype to store a term with its type and the type of its
   type. *)
 
@@ -188,23 +186,20 @@ type unsafe_type_judgment = {
   utj_type : sorts }
 
 
-(*s Compilation of global declaration *)
+(** {6 Compilation of global declaration } *)
 
-val compile_constant_body :
-    env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
-                                 (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> Cemitcodes.body_code
 
 exception Hyp_not_found
 
-(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
+(** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
    return [tail::(f head (id,_,_) (rev tail))::head].
    the value associated to id should not change *)
-
 val apply_to_hyp : named_context_val -> variable ->
   (named_context -> named_declaration -> named_context -> named_declaration) ->
     named_context_val
 
-(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
+(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
    [tail::(id,_,_)::head] and
    return [(g tail)::(f (id,_,_))::head]. *)
 val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
@@ -219,9 +214,10 @@ val insert_after_hyp : named_context_val -> variable ->
 val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
 
 
-(* spiwack: functions manipulating the retroknowledge *)
-open Retroknowledge
 
+open Retroknowledge
+(** functions manipulating the retroknowledge 
+    @author spiwack *)
 val retroknowledge : (retroknowledge->'a) -> env -> 'a
 
 val registered : env -> field -> bool
@@ -230,3 +226,4 @@ val unregister : env -> field -> env
 
 val register : env -> field -> Retroknowledge.entry -> env
 
+
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 82d19ec4..cbce04d6 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -1,12 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: esubst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras for Coq V7.0, Mar 2001 *)
+
+(* Support for explicit substitutions *)
 
 open Util
 
@@ -21,6 +23,8 @@ type lift =
   | ELLFT of int * lift  (* ELLFT(n,l)  == apply l to de Bruijn > n *)
                          (*                 i.e under n binders *)
 
+let el_id = ELID
+
 (* compose a relocation of magnitude n *)
 let rec el_shft_rec n = function
   | ELSHFT(el,k) -> el_shft_rec (k+n) el
@@ -67,6 +71,8 @@ type 'a subs =
  * Needn't be recursive if we always use these functions
  *)
 
+let subs_id i = ESID i
+
 let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
 
 let subs_liftn n = function
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 76c0d481..fe978261 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -1,61 +1,66 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: esubst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Explicit substitutions *)
 
-(*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)
+(** {6 Explicit substitutions } *)
+(** 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 =
+type 'a subs = private
   | ESID of int
   | CONS of 'a array * 'a subs
   | SHIFT of int * 'a subs
   | LIFT of int * 'a subs
 
-(* Derived constructors granting basic invariants *)
+(** Derived constructors granting basic invariants *)
+val subs_id : int -> 'a subs
 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 *)
+
+(** [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).
- *)
+(** [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 *)
+(** 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.
- *)
+(** 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].
-   [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
-type lift =
+(** {6 Compact representation } *)
+(** Compact representation of explicit relocations
+    - [ELSHFT(l,n)] == lift of [n], then apply [lift l].
+    - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
+type lift = private
   | ELID
   | ELSHFT of lift * int
   | ELLFT of int * lift
 
+val el_id : lift
 val el_shft : int -> lift -> lift
 val el_liftn : int -> lift -> lift
 val el_lift : lift -> lift
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 9b1ddc31..46e866a0 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -87,15 +85,6 @@ let mind_check_names mie =
   vue since inductive and constructors are not referred to by their
   name, but only by the name of the inductive packet and an index. *)
 
-let mind_check_arities env mie =
-  let check_arity id c =
-    if not (is_arity env c) then
-      raise (InductiveError (NotAnArity id))
-  in
-  List.iter
-    (fun {mind_entry_typename=id; mind_entry_arity=ar} -> check_arity id ar)
-    mie.mind_entry_inds
-
 (************************************************************************)
 (************************************************************************)
 
@@ -171,7 +160,7 @@ let inductive_levels arities inds =
    arity or type constructor; we do not to recompute universes constraints *)
 
 let constraint_list_union =
-  List.fold_left Constraint.union Constraint.empty
+  List.fold_left union_constraints empty_constraint
 
 let infer_constructor_packet env_ar_par params lc =
   (* type-check the constructors *)
@@ -208,7 +197,7 @@ let typecheck_inductive env mie =
 	    full_arity is used as argument or subject to cast, an
 	    upper universe will be generated *)
 	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
-	 let cst = Constraint.union cst cst2 in
+	 let cst = union_constraints cst cst2 in
 	 let id = ind.mind_entry_typename in
 	 let env_ar' =
            push_rel (Name id, None, full_arity)
@@ -237,7 +226,7 @@ let typecheck_inductive env mie =
 	   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'))
+	 (ind'::inds, union_constraints cst cst'))
       mie.mind_entry_inds
       arity_list
       ([],cst) in
@@ -246,7 +235,8 @@ let typecheck_inductive env mie =
   let arities = Array.of_list arity_list in
   let param_ccls = List.fold_left (fun l (_,b,p) ->
     if b = None then
-      let _,c = dest_prod_assum env p in
+      (* Parameter contributes to polymorphism only if explicit Type *)
+      let c = strip_prod_assum p in
       (* Add Type levels to the ordered list of parameters contributing to *)
       (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
       match kind_of_term c with
@@ -373,6 +363,11 @@ if nmr = 0 then 0 else
           | _ -> k)
   in find 0 (n-1) (lpar,List.rev hyps)
 
+let lambda_implicit_lift n a =
+  let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in
+  let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
+  iterate lambda_implicit n (lift n a)
+
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
 let abstract_mind_lc env ntyps npars lc =
@@ -421,7 +416,7 @@ let array_min nmr a = if nmr = 0 then 0 else
 
 (* The recursive function that checks positivity and builds the list
    of recursive arguments *)
-let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
+let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
   let lparams = rel_context_length hyps in
   let nmr = rel_context_nhyps hyps in
   (* Checking the (strict) positivity of a constructor argument type [c] *)
@@ -466,8 +461,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
       (* If the inductive appears in the args (non params) then the
 	 definition is not positive. *)
+
       if not (List.for_all (noccur_between n ntypes) auxlargs) then
-        failwith_non_pos_list n ntypes auxlargs;
+	failwith_non_pos_list n ntypes auxlargs;
       (* We do not deal with imbricated mutual inductive types *)
       let auxntyp = mib.mind_ntypes in
 	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
@@ -533,11 +529,11 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
   in
   let irecargs = Array.map snd irecargs_nmr
   and nmr' = array_min nmr irecargs_nmr
-  in (nmr', mk_paths (Mrec i) irecargs)
+  in (nmr', mk_paths (Mrec ind) irecargs)
 
-let check_positivity env_ar params inds =
+let check_positivity kn env_ar params inds =
   let ntypes = Array.length inds in
-  let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in
+  let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
   let lra_ind = List.rev (Array.to_list rc) in
   let lparams = rel_context_length params in
   let nmr = rel_context_nhyps params in
@@ -546,7 +542,7 @@ 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 (kn,i) nargs lcnames lc
   in
   let irecargs_nmr = Array.mapi check_one inds in
   let irecargs = Array.map snd irecargs_nmr
@@ -558,16 +554,6 @@ 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
-                   | Imbr(_,lvec) -> array_exists one_is_rec lvec
-                   | Norec -> false) rvec
-  in
-  array_exists one_is_rec
-*)
-
 (* Allowed eliminations *)
 
 let all_sorts = [InProp;InSet;InType]
@@ -614,7 +600,6 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
     (* Type of constructors in normal form *)
     let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
     let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
-    let nf_lc = if nf_lc = lc then lc else nf_lc in
     let consnrealargs =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
@@ -677,11 +662,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 (************************************************************************)
 (************************************************************************)
 
-let check_inductive env mie =
+let check_inductive env kn mie =
   (* First type-check the inductive definition *)
   let (env_ar, params, inds, cst) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
-  let (nmr,recargs) = check_positivity env_ar params inds in
+  let (nmr,recargs) = check_positivity kn env_ar params inds in
   (* Build the inductive packets *)
     build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
       inds nmr recargs cst
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 71d01568..b37aefe4 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
@@ -16,13 +13,13 @@ open Declarations
 open Environ
 open Entries
 open Typeops
-(*i*)
 
+(** Inductive type checking and errors *)
 
-(*s The different kinds of errors that may result of a malformed inductive
+(** The different kinds of errors that may result of a malformed inductive
   definition. *)
 
-(* Errors related to inductive constructions *)
+(** Errors related to inductive constructions *)
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
@@ -37,7 +34,7 @@ type inductive_error =
 
 exception InductiveError of inductive_error
 
-(*s The following function does checks on inductive declarations. *)
+(** The following function does checks on inductive declarations. *)
 
 val check_inductive :
-  env -> mutual_inductive_entry -> mutual_inductive_body
+  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 62a48f07..21f86233 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -80,8 +78,6 @@ let instantiate_params full t args sign =
   if rem_args <> [] then fail();
   substl subs ty
 
-let instantiate_partial_params = instantiate_params false
-
 let full_inductive_instantiate mib params sign =
   let dummy = prop_sort in
   let t = mkArity (sign,dummy) in
@@ -97,10 +93,6 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
 
 (* Functions to build standard types related to inductive *)
 
-
-let number_of_inductives mib = Array.length mib.mind_packets
-let number_of_constructors mip = Array.length mip.mind_consnames
-
 (*
 Computing the actual sort of an applied or partially applied inductive type:
 
@@ -241,12 +233,6 @@ let type_of_constructors ind (mib,mip) =
 
 (************************************************************************)
 
-let error_elim_expln kp ki =
-  match kp,ki with
-  | (InType | InSet), InProp -> NonInformativeToInformative
-  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
-  | _ -> WrongArity
-
 (* Type of case predicates *)
 
 let local_rels ctxt =
@@ -298,7 +284,7 @@ exception LocalArity of (sorts_family * sorts_family * arity_error) option
 let check_allowed_sort ksort specif =
   if not (List.exists ((=) ksort) (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
-    raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
+    raise (LocalArity (Some(ksort,s,error_elim_explain ksort s)))
 
 let is_correct_arity env c pj ind specif params =
   let arsign,_ = get_instantiated_arity specif params in
@@ -309,7 +295,7 @@ let is_correct_arity env c pj ind specif params =
           let univ =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ)
+          srec (push_rel (na1,None,a1) env) t ar' (union_constraints 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
@@ -319,13 +305,13 @@ let is_correct_arity env c pj ind specif params =
             try conv env a1 dep_ind
             with NotConvertible -> raise (LocalArity None) in
 	  check_allowed_sort ksort specif;
-	  Constraint.union u univ
+	  union_constraints u univ
       | _, (_,Some _,_ as d)::ar' ->
 	  srec (push_rel d env) (lift 1 pt') ar' u
       | _ ->
 	  raise (LocalArity None)
   in
-  try srec env pj.uj_type (List.rev arsign) Constraint.empty
+  try srec env pj.uj_type (List.rev arsign) empty_constraint
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c pj kinds
 
@@ -374,7 +360,7 @@ let check_case_info env indsp ci =
   if
     not (eq_ind indsp ci.ci_ind) or
     (mib.mind_nparams <> ci.ci_npar) or
-    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
+    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -431,10 +417,10 @@ let spec_of_tree t = lazy
    else Subterm(Strict,Lazy.force t))
 
 let subterm_spec_glb =
-  let glb2 s1 s2 =
-    match s1,s2 with
-        _, Dead_code -> s1
-      | Dead_code, _ -> s2
+  let glb2 s1 s2 = 
+    match s1, s2 with
+        s1, Dead_code -> s1
+      | Dead_code, s2 -> s2
       | Not_subterm, _ -> Not_subterm
       | _, Not_subterm -> Not_subterm
       | Subterm (a1,t1), Subterm (a2,t2) ->
@@ -447,27 +433,20 @@ type guard_env =
   { env     : env;
     (* dB of last fixpoint *)
     rel_min : int;
-    (* inductive of recarg of each fixpoint *)
-    inds    : inductive array;
-    (* the recarg information of inductive family *)
-    recvec  : wf_paths array;
     (* dB of variables denoting subterms *)
     genv    : subterm_spec Lazy.t list;
   }
 
-let make_renv env minds recarg (kn,tyi) =
+let make_renv env recarg (kn,tyi) =
   let mib = Environ.lookup_mind kn env in
   let mind_recvec =
     Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
   { env = env;
     rel_min = recarg+2;
-    inds = minds;
-    recvec = mind_recvec;
     genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
 
 let push_var renv (x,ty,spec) =
-  { renv with
-    env = push_rel (x,None,ty) renv.env;
+  { env = push_rel (x,None,ty) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
 
@@ -475,76 +454,66 @@ let assign_var_spec renv (i,spec) =
   { renv with genv = list_assign renv.genv (i-1) spec }
 
 let push_var_renv renv (x,ty) =
-  push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
+  push_var renv (x,ty,lazy Not_subterm)
 
 (* Fetch recursive information about a variable p *)
 let subterm_var p renv =
   try Lazy.force (List.nth renv.genv (p-1))
   with Failure _ | Invalid_argument _ -> Not_subterm
 
-(* Add a variable and mark it as strictly smaller with information [spec]. *)
-let add_subterm renv (x,a,spec) =
-  push_var renv (x,a,spec_of_tree spec)
-
 let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
-  { renv with
-    env = push_rel_context ctxt renv.env;
+  { env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
-    genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+    genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
 
 let push_fix_renv renv (_,v,_ as recdef) =
   let n = Array.length v in
-  { renv with
-    env = push_rec_types recdef renv.env;
+  { env = push_rec_types recdef renv.env;
     rel_min = renv.rel_min+n;
-    genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+    genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
 
+(* Definition and manipulation of the stack *)
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
 
-(******************************)
-(* Computing the recursive subterms of a term (propagation of size
-   information through Cases). *)
+let push_stack_closures renv l stack = 
+  List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack
 
-(*
-   c is a branch of an inductive definition corresponding to the spec
-   lrec.  mind_recvec is the recursive spec of the inductive
-   definition of the decreasing argument n.
-
-   case_branches_specif renv lrec lc will pass the lambdas
-   of c corresponding to pattern variables and collect possibly new
-   subterms variables and returns the bodies of the branches with the
-   correct envs and decreasing args.
-*)
+let push_stack_args l stack = 
+  List.fold_right (fun h b -> (SArg h)::b) l stack
+
+(******************************)
+(* {6 Computing the recursive subterms of a term (propagation of size
+   information through Cases).} *)
 
 let lookup_subterms env ind =
   let (_,mip) = lookup_mind_specif env ind in
   mip.mind_recargs
 
-(*********************************)
 
-let match_trees t1 t2 =
-  let v1 = dest_subterms t1 in
-  let v2 = dest_subterms t2 in
-  array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+let match_inductive ind ra =
+  match ra with
+    | (Mrec i | Imbr i) -> eq_ind ind i
+    | Norec -> false
 
-(* In {match c as z in ind y_s return P with |C_i x_s => t end}
-   [branches_specif renv c_spec ind] returns an array of x_s specs given
-   c_spec the spec of c. *)
-let branches_specif renv c_spec ind =
-  let (_,mip) = lookup_mind_specif renv.env ind in
+(* In {match c as z in ci y_s return P with |C_i x_s => t end}
+   [branches_specif renv c_spec ci] returns an array of x_s specs knowing
+   c_spec. *)
+let branches_specif renv c_spec ci =
   let car = 
     (* We fetch the regular tree associated to the inductive of the match.
        This is just to get the number of constructors (and constructor
        arities) that fit the match branches without forcing c_spec.
        Note that c_spec might be more precise than [v] below, because of
        nested inductive types. *)
+    let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in
     let v = dest_subterms mip.mind_recargs in
       Array.map List.length v in
     Array.mapi
       (fun i nca -> (* i+1-th cstructor has arity nca *)
 	 let lvra = lazy 
 	   (match Lazy.force c_spec with
-		Subterm (_,t) when match_trees mip.mind_recargs t ->
+		Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
 		  let vra = Array.of_list (dest_subterms t).(i) in
 		  assert (nca = Array.length vra);
 		  Array.map
@@ -555,106 +524,92 @@ let branches_specif renv c_spec ind =
 	 list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
       car 
 
-
-(* Propagation of size information through Cases: if the matched
-   object is a recursive subterm then compute the information
-   associated to its own subterms.
-   Rq: if branch is not eta-long, then the recursive information
-   is not propagated to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr =
-  let vlrec = branches_specif renv c_spec ind in
-  let rec push_branch_args renv lrec c =
-    match lrec with
-        ra::lr ->
-          let c' = whd_betadeltaiota renv.env c in
-          (match kind_of_term c' with
-              Lambda(x,a,b) ->
-                let renv' = push_var renv (x,a,ra) in
-                push_branch_args renv' lr b
-            | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
-                (renv,c'))
-      | [] -> (renv, c) in
-  assert (Array.length vlrec = Array.length lbr);
-  array_map2 (push_branch_args renv) vlrec lbr
-
 (* [subterm_specif renv t] computes the recursive structure of [t] and
    compare its size with the size of the initial recursive argument of
    the fixpoint we are checking. [renv] collects such information
    about variables.
 *)
 
-let rec subterm_specif renv t =
+let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
-  match kind_of_term f with
-    | Rel k -> subterm_var k renv
-
-    | Case (ci,_,c,lbr) ->
-        let 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
-   furthermore when f is applied to a term which is strictly less than
-   n, one may assume that x itself is strictly less than n
-*)
-        let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
-        let oind =
-          let env' = push_rel_context ctxt renv.env in
-          try Some(fst(find_inductive env' clfix))
-          with Not_found -> None in
-        (match oind with
-            None -> Not_subterm (* happens if fix is polymorphic *)
-          | Some ind ->
-              let nbfix = Array.length typarray in
-              let recargs = lookup_subterms renv.env ind in
-              (* pushing the fixpoints *)
-              let renv' = push_fix_renv renv recdef in
-              let renv' =
-                (* Why Strict here ? To be general, it could also be
-                   Large... *)
-                assign_var_spec renv'
-		  (nbfix-i, Lazy.lazy_from_val(Subterm(Strict,recargs))) in
-              let decrArg = recindxs.(i) in
-              let theBody = bodies.(i)   in
-              let nbOfAbst = decrArg+1 in
-              let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
-              (* pushing the fix parameters *)
-              let renv'' = push_ctxt_renv renv' sign in
-              let renv'' =
-                if List.length l < nbOfAbst then renv''
-                else
-                  let theDecrArg  = List.nth l decrArg in
-	          let arg_spec    = lazy_subterm_specif renv theDecrArg in
-                  assign_var_spec renv'' (1, arg_spec) in
-	      subterm_specif renv'' strippedBody)
-
-    | Lambda (x,a,b) ->
-        assert (l=[]);
-        subterm_specif (push_var_renv renv (x,a)) b
-
-    (* Metas and evars are considered OK *)
-    | (Meta _|Evar _) -> Dead_code
-
-    (* Other terms are not subterms *)
-    | _ -> Not_subterm
-
-and lazy_subterm_specif renv t =
-  lazy (subterm_specif renv t)
-
-and case_subterm_specif renv ci c lbr =
-  if Array.length lbr = 0 then [||]
-  else
-    let c_spec = lazy_subterm_specif renv c in
-    case_branches_specif renv c_spec ci.ci_ind lbr
- 
+    match kind_of_term f with
+      | Rel k -> subterm_var k renv
+
+      | Case (ci,_,c,lbr) ->
+	  let stack' = push_stack_closures renv l stack in
+          let cases_spec = branches_specif renv 
+	    (lazy_subterm_specif renv [] c) ci in
+          let stl  =
+            Array.mapi (fun i br' ->
+			  let stack_br = push_stack_args (cases_spec.(i)) stack' in
+			    subterm_specif renv stack_br br')
+              lbr in
+            subterm_spec_glb stl
+
+      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+	  (* when proving that the fixpoint f(x)=e is less than n, it is enough
+	     to prove that e is less than n assuming f is less than n
+	     furthermore when f is applied to a term which is strictly less than
+	     n, one may assume that x itself is strictly less than n
+	  *)
+          let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+          let oind =
+            let env' = push_rel_context ctxt renv.env in
+              try Some(fst(find_inductive env' clfix))
+              with Not_found -> None in
+            (match oind with
+		 None -> Not_subterm (* happens if fix is polymorphic *)
+               | Some ind ->
+		   let nbfix = Array.length typarray in
+		   let recargs = lookup_subterms renv.env ind in
+		     (* pushing the fixpoints *)
+		   let renv' = push_fix_renv renv recdef in
+		   let renv' =
+                     (* Why Strict here ? To be general, it could also be
+			Large... *)
+                     assign_var_spec renv'
+		       (nbfix-i, lazy (Subterm(Strict,recargs))) in
+		   let decrArg = recindxs.(i) in
+		   let theBody = bodies.(i)   in
+		   let nbOfAbst = decrArg+1 in
+		   let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+		     (* pushing the fix parameters *)
+		   let stack' = push_stack_closures renv l stack in
+		   let renv'' = push_ctxt_renv renv' sign in
+		   let renv'' =
+                     if List.length stack' < nbOfAbst then renv''
+                     else
+		       let decrArg = List.nth stack' decrArg in
+                       let arg_spec = stack_element_specif decrArg in
+			 assign_var_spec renv'' (1, arg_spec) in
+		     subterm_specif renv'' [] strippedBody)
+
+      | Lambda (x,a,b) ->
+          assert (l=[]);
+	  let spec,stack' = extract_stack renv a stack in
+	    subterm_specif (push_var renv (x,a,spec)) stack' b
+
+      (* Metas and evars are considered OK *)
+      | (Meta _|Evar _) -> Dead_code
+
+      (* Other terms are not subterms *)
+      | _ -> Not_subterm
+
+and lazy_subterm_specif renv stack t =
+  lazy (subterm_specif renv stack t)
+
+and stack_element_specif = function
+  |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h
+  |SArg x -> x
+
+and extract_stack renv a = function
+  | [] -> Lazy.lazy_from_val Not_subterm , []
+  | h::t -> stack_element_specif h, t
+
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c =
-  match subterm_specif renv c with
+let check_is_subterm x =
+  match Lazy.force x with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
 
@@ -662,7 +617,7 @@ let check_is_subterm renv c =
 
 exception FixGuardError of env * guard_error
 
-let error_illegal_rec_call renv fx arg =
+let error_illegal_rec_call renv fx (arg_renv,arg) =
   let (_,le_vars,lt_vars) =
     List.fold_left
       (fun (i,le,lt) sbt ->
@@ -672,7 +627,8 @@ let error_illegal_rec_call renv fx arg =
           | _ -> (i+1, le ,lt))
       (1,[],[]) renv.genv in
   raise (FixGuardError (renv.env,
-                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+                        RecursionOnIllegalTerm(fx,(arg_renv.env, arg),
+					       le_vars,lt_vars)))
 
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
@@ -683,8 +639,11 @@ let error_partial_apply renv fx =
 let check_one_fix renv recpos def =
   let nfi = Array.length recpos in
 
-  (* Checks if [t] only make valid recursive calls *)
-  let rec check_rec_call renv t =
+  (* Checks if [t] only make valid recursive calls 
+     [stack] is the list of constructor's argument specification and 
+     arguments than will be applied after reduction.
+     example u in t where we have (match .. with |.. => t end) u *)
+  let rec check_rec_call renv stack t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
@@ -694,35 +653,43 @@ let check_one_fix renv recpos def =
             (* 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;
+                List.iter (check_rec_call renv []) l;
                 (* the position of the invoked fixpoint: *)
 	        let glob = renv.rel_min+nfi-1-p in
                 (* the decreasing arg of the rec call: *)
 	        let np = recpos.(glob) in
-                if List.length l <= np then error_partial_apply renv glob
+		let stack' = push_stack_closures renv l stack in
+                if List.length stack' <= np then error_partial_apply renv glob
                 else
                   (* Check the decreasing arg is smaller *)
-                  let z = List.nth l np in
-	          if not (check_is_subterm renv z) then
-                    error_illegal_rec_call renv glob z
+                  let z = List.nth stack' np in
+	          if not (check_is_subterm (stack_element_specif z)) then
+                    begin match z with
+		      |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') 
+		      |SArg _ -> error_partial_apply renv glob
+		    end
               end
             else
               begin
                 match pi2 (lookup_rel p renv.env) with
                 | None ->
-                    List.iter (check_rec_call renv) l
+                    List.iter (check_rec_call renv []) l
                 | Some c ->
-                    try List.iter (check_rec_call renv) l
+                    try List.iter (check_rec_call renv []) l
                     with FixGuardError _ ->
-                      check_rec_call renv (applist(lift p c,l))
+                      check_rec_call renv stack (applist(lift p c,l))
               end
-
+		
         | Case (ci,p,c_0,lrest) ->
-            List.iter (check_rec_call renv) (c_0::p::l);
+            List.iter (check_rec_call renv []) (c_0::p::l);
             (* compute the recarg information for the arguments of
                each branch *)
-            let lbr = case_subterm_specif renv ci c_0 lrest in
-            Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+            let case_spec = branches_specif renv 
+	      (lazy_subterm_specif renv [] c_0) ci in
+	    let stack' = push_stack_closures renv l stack in
+              Array.iteri (fun k br' -> 
+			     let stack_br = push_stack_args case_spec.(k) stack' in
+			     check_rec_call renv stack_br br') lrest
 
         (* Enables to traverse Fixpoint definitions in a more intelligent
            way, ie, the rule :
@@ -737,79 +704,79 @@ let check_one_fix renv recpos def =
            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;
+            List.iter (check_rec_call renv []) l;
+            Array.iter (check_rec_call renv []) typarray;
             let decrArg = recindxs.(i) in
             let renv' = push_fix_renv renv recdef in
-            if (List.length l < (decrArg+1)) then
-	      Array.iter (check_rec_call renv') bodies
-            else
+	    let stack' = push_stack_closures renv l stack in
               Array.iteri
                 (fun j body ->
-                  if i=j then
-                    let theDecrArg  = List.nth l decrArg in
-	            let arg_spec = lazy_subterm_specif renv theDecrArg in
-	            check_nested_fix_body renv' (decrArg+1) arg_spec body
-                  else check_rec_call renv' body)
+                   if i=j && (List.length stack' > decrArg) then
+		     let recArg = List.nth stack' decrArg in
+	             let arg_sp = stack_element_specif recArg in
+	             check_nested_fix_body renv' (decrArg+1) arg_sp body
+                   else check_rec_call renv' [] body)
                 bodies
 
         | Const kn ->
             if evaluable_constant kn renv.env then
-              try List.iter (check_rec_call renv) l
+              try List.iter (check_rec_call renv []) l
               with (FixGuardError _ ) ->
-	        check_rec_call renv(applist(constant_value renv.env kn, l))
-	    else List.iter (check_rec_call renv) l
-
-        (* The cases below simply check recursively the condition on the
-           subterms *)
-        | Cast (a,_, b) ->
-            List.iter (check_rec_call renv) (a::b::l)
+		let value = (applist(constant_value renv.env kn, l)) in
+	        check_rec_call renv stack value
+	    else List.iter (check_rec_call renv []) l
 
         | Lambda (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = []);
+	    check_rec_call renv [] a ;
+	    let spec, stack' = extract_stack renv a stack in
+	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
-            List.iter (check_rec_call renv) (a::l);
-            check_rec_call (push_var_renv renv (x,a)) b
+	    assert (l = [] && stack = []);
+            check_rec_call renv [] a;
+            check_rec_call (push_var_renv renv (x,a)) [] b
 
         | CoFix (i,(_,typarray,bodies as recdef)) ->
-            List.iter (check_rec_call renv) l;
-	    Array.iter (check_rec_call renv) typarray;
+            List.iter (check_rec_call renv []) l;
+	    Array.iter (check_rec_call renv []) typarray;
 	    let renv' = push_fix_renv renv recdef in
-	    Array.iter (check_rec_call renv') bodies
+	    Array.iter (check_rec_call renv' []) bodies
 
-        | (Ind _ | Construct _ | Sort _) ->
-            List.iter (check_rec_call renv) l
+        | (Ind _ | Construct _) ->
+            List.iter (check_rec_call renv []) l
 
         | Var id ->
             begin
               match pi2 (lookup_named id renv.env) with
               | None ->
-                  List.iter (check_rec_call renv) l
+                  List.iter (check_rec_call renv []) l
               | Some c ->
-                  try List.iter (check_rec_call renv) l
-                  with (FixGuardError _) -> check_rec_call renv (applist(c,l))
+                  try List.iter (check_rec_call renv []) l
+                  with (FixGuardError _) -> 
+		    check_rec_call renv stack (applist(c,l))
             end
 
+	| Sort _ -> assert (l = [])
+
         (* l is not checked because it is considered as the meta's context *)
         | (Evar _ | Meta _) -> ()
 
-        | (App _ | LetIn _) -> assert false (* beta zeta reduction *)
+        | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
 
   and check_nested_fix_body renv decr recArgsDecrArg body =
     if decr = 0 then
-      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
     else
       match kind_of_term body with
 	| Lambda (x,a,b) ->
-	    check_rec_call renv a;
+	    check_rec_call renv [] a;
             let renv' = push_var_renv renv (x,a) in
-	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+	      check_nested_fix_body renv' (decr-1) recArgsDecrArg b
 	| _ -> anomaly "Not enough abstractions in fix body"
-
+	    
   in
-  check_rec_call renv def
+  check_rec_call renv [] def
 
 let judgment_of_fixpoint (_, types, bodies) =
   array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
@@ -856,7 +823,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
   let (minds, rdef) = inductive_of_mutfix env fix in
   for i = 0 to Array.length bodies - 1 do
     let (fenv,body) = rdef.(i) in
-    let renv = make_renv fenv minds nvect.(i) minds.(i) in
+    let renv = make_renv fenv 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
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 0dac719c..a124647c 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Declarations
 open Environ
-(*i*)
 
-(*s Extracting an inductive type from a construction *)
+(** {6 Extracting an inductive type from a construction } *)
 
-(* [find_m*type env sigma c] coerce [c] to an recursive type (I args).
+(** [find_m*type env sigma c] coerce [c] to an recursive type (I args).
    [find_rectype], [find_inductive] and [find_coinductive]
    respectively accepts any recursive type, only an inductive type and
    only a coinductive type.
@@ -30,32 +26,33 @@ val find_coinductive : env -> types -> inductive * constr list
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
-(*s Fetching information in the environment about an inductive type.
+(** {6 ... } *)
+(** Fetching information in the environment about an inductive type.
     Raises [Not_found] if the inductive type is not found. *)
 val lookup_mind_specif : env -> inductive -> mind_specif
 
-(*s Functions to build standard types related to inductive *)
+(** {6 Functions to build standard types related to inductive } *)
 val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
 
 val type_of_inductive : env -> mind_specif -> types
 
 val elim_sorts : mind_specif -> sorts_family list
 
-(* Return type as quoted by the user *)
+(** Return type as quoted by the user *)
 val type_of_constructor : constructor -> mind_specif -> types
 
-(* Return constructor types in normal form *)
+(** Return constructor types in normal form *)
 val arities_of_constructors : inductive -> mind_specif -> types array
 
-(* Return constructor types in user form *)
+(** Return constructor types in user form *)
 val type_of_constructors : inductive -> mind_specif -> types array
 
-(* Transforms inductive specification into types (in nf) *)
+(** Transforms inductive specification into types (in nf) *)
 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
+(** [type_case_branches env (I,args) (p:A) c] computes useful types
    about the following Cases expression:
       <p>Cases (c :: (I args)) of b1..bn end
    It computes the type of every branch (pattern variables are
@@ -70,20 +67,20 @@ val build_branches_type :
   inductive -> mutual_inductive_body * one_inductive_body ->
     constr list -> constr -> types array
 
-(* Return the arity of an inductive type *)
+(** Return the arity of an inductive type *)
 val mind_arity : one_inductive_body -> rel_context * sorts_family
 
 val inductive_sort_family : one_inductive_body -> sorts_family
 
-(* Check a [case_info] actually correspond to a Case expression on the
+(** Check a [case_info] actually correspond to a Case expression on the
    given inductive type. *)
 val check_case_info : env -> inductive -> case_info -> unit
 
-(*s Guard conditions for fix and cofix-points. *)
+(** {6 Guard conditions for fix and cofix-points. } *)
 val check_fix : env -> fixpoint -> unit
 val check_cofix : env -> cofixpoint -> unit
 
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
 
 (** The "polyprop" optional argument below allows to control
     the "Prop-polymorphism". By default, it is allowed.
@@ -102,8 +99,7 @@ val max_inductive_sort : sorts array -> universe
 val instantiate_universes : env -> rel_context ->
     polymorphic_arity -> types array -> rel_context * sorts
 
-(***************************************************************)
-(* Debug *)
+(** {6 Debug} *)
 
 type size = Large | Strict
 type subterm_spec =
@@ -112,16 +108,13 @@ type subterm_spec =
   | Not_subterm
 type guard_env =
   { env     : env;
-    (* dB of last fixpoint *)
+    (** dB of last fixpoint *)
     rel_min : int;
-    (* inductive of recarg of each fixpoint *)
-    inds    : inductive array;
-    (* the recarg information of inductive family *)
-    recvec  : wf_paths array;
-    (* dB of variables denoting subterms *)
+    (** dB of variables denoting subterms *)
     genv    : subterm_spec Lazy.t list;
   }
 
-val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
-  constr array -> (guard_env * constr) array
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
+
+val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
+
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index ab8b60be..314cc0ee 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -1,305 +1,249 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: mod_subst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Claudio Sacerdoti from contents of term.ml, names.ml and
+   new support for constant inlining in functor application, Nov 2004 *)
+(* Optimizations and bug fixes by Élie Soubiran, from Feb 2008 *)
+
+(* This file provides types and functions for managing name
+   substitution in module constructions *)
 
 open Pp
 open Util
 open Names
 open Term
 
+(* For Inline, the int is an inlining level, and the constr (if present)
+   is the term into which we should inline *)
 
 type delta_hint =
-    Inline of constr option
+  | Inline of int * constr option
   | Equiv of kernel_name
-  | Prefix_equiv of module_path
 
-type delta_key = 
-    KN of kernel_name
-  | MP of module_path
+(* NB: earlier constructor Prefix_equiv of module_path
+   is now stored in a separate table, see Deltamap.t below *)
+
+module Deltamap = struct
+  type t = module_path MPmap.t * delta_hint KNmap.t
+  let empty = MPmap.empty, KNmap.empty
+  let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
+  let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_kn kn map = KNmap.find kn (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_kn kn map = KNmap.mem kn (snd map)
+  let fold_kn f map i = KNmap.fold f (snd map) i
+  let fold fmp fkn (mm,km) i =
+    MPmap.fold fmp mm (KNmap.fold fkn km i)
+  let join map1 map2 = fold add_mp add_kn map1 map2
+end
+
+type delta_resolver = Deltamap.t
 
-module Deltamap =  Map.Make(struct 
-			      type t = delta_key
-			      let compare = Pervasives.compare
-			    end)
+let empty_delta_resolver = Deltamap.empty
 
-type delta_resolver = delta_hint Deltamap.t
+module MBImap = Map.Make
+  (struct
+    type t = mod_bound_id
+    let compare = Pervasives.compare
+   end)
+
+module Umap = struct
+  type 'a t = 'a MPmap.t * 'a MBImap.t
+  let empty = MPmap.empty, MBImap.empty
+  let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2
+  let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2)
+  let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
+  let find_mp mp map = MPmap.find mp (fst map)
+  let find_mbi mbi map = MBImap.find mbi (snd map)
+  let mem_mp mp map = MPmap.mem mp (fst map)
+  let mem_mbi mbi map = MBImap.mem mbi (snd map)
+  let iter_mbi f map = MBImap.iter f (snd map)
+  let fold fmp fmbi (m1,m2) i =
+    MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
+  let join map1 map2 = fold add_mp add_mbi map1 map2
+end
 
-let empty_delta_resolver = Deltamap.empty
+type substitution = (module_path * delta_resolver) Umap.t
 
-type substitution_domain = 
-  | MBI of mod_bound_id
-  | MPI of module_path
+let empty_subst = Umap.empty
 
-let string_of_subst_domain = function
- | MBI mbid -> debug_string_of_mbid mbid
- | MPI mp -> string_of_mp mp
+let is_empty_subst = Umap.is_empty
 
-module Umap = Map.Make(struct
-			 type t = substitution_domain
-			 let compare = Pervasives.compare
-		       end)
+(* <debug> *)
 
-type substitution = (module_path * delta_resolver) Umap.t
-    
-let empty_subst = Umap.empty
+let string_of_hint = function
+  | Inline (_,Some _) -> "inline(Some _)"
+  | Inline _ -> "inline()"
+  | Equiv kn -> string_of_kn kn
+
+let debug_string_of_delta resolve =
+  let kn_to_string kn hint s =
+    s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint)
+  in
+  let mp_to_string mp mp' s =
+    s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp')
+  in
+  Deltamap.fold mp_to_string kn_to_string resolve ""
+
+let list_contents sub =
+  let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in
+  let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in
+  let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in
+  Umap.fold mp_one_pair mbi_one_pair sub []
+
+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 l = list_contents sub in
+  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_comma f l) ++ str "}"
 
+(* </debug> *)
 
-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 resolve =
-  Umap.add (MPI mp1) (mp2,resolve)
+(** Extending a [delta_resolver] *)
 
+let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc))
+
+let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn')
+
+let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2
+
+(** Extending a [substitution *)
+
+let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s
+let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s
 
 let map_mbid mbid mp resolve = add_mbid mbid mp resolve 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 mp_in_delta mp = Deltamap.mem_mp mp
 
-let remove_mp_delta_resolver resolver mp =
-    Deltamap.remove (MP mp) resolver
+let kn_in_delta kn resolver =
+  try
+    match Deltamap.find_kn kn resolver with
+      | Equiv _ -> true
+      | Inline _ -> false
+  with Not_found -> false
 
-exception Inline_kn
+let con_in_delta con resolver = kn_in_delta (user_con con) resolver
+let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver
 
-let rec find_prefix resolve mp = 
+let mp_of_delta resolve mp =
+ try Deltamap.find_mp mp resolve with Not_found -> mp
+
+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"	
+    | MPdot(mp,l) as mp_sup ->
+	(try Deltamap.find_mp mp_sup resolve
+	 with Not_found -> MPdot(sub_mp mp,l))
+    | p -> Deltamap.find_mp p resolve
   in
-    try 
-      sub_mp mp
-    with
-	Not_found -> mp
+  try sub_mp mp with Not_found -> mp
 
-exception Change_equiv_to_inline of constr
+exception Change_equiv_to_inline of (int * 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
-	      
+  try
+    match Deltamap.find_kn kn resolve with
+      | Equiv kn1 -> kn1
+      | Inline (lev, Some c) ->	raise (Change_equiv_to_inline (lev,c))
+      | Inline (_, None) -> raise Not_found
+  with Not_found ->
+    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 kn_of_delta resolve kn =
+  try solve_delta_kn resolve kn
+  with _ -> kn
+
+let constant_of_delta_kn resolve kn =
+  constant_of_kn_equiv kn (kn_of_delta resolve kn)
+
+let gen_of_delta resolve x kn fix_can =
+  try
+    let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then x else fix_can new_kn
+  with _ -> x
 
 let 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 
-	
+  gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+
 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 kn, kn' = canonical_con con, user_con con in
+  gen_of_delta resolve con kn (constant_of_kn_equiv kn')
+
+let mind_of_delta_kn resolve kn =
+  mind_of_kn_equiv kn (kn_of_delta resolve kn)
 
 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 
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
 
 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 []
+  let kn, kn' = canonical_mind mind, user_mind mind in
+  gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
+
+let inline_of_delta inline resolver =
+  match inline with
+    | None -> []
+    | Some inl_lev ->
+      let extract kn hint l =
+	match hint with
+	  | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l
+	  | _ -> l
+      in
+      Deltamap.fold_kn extract resolver []
+
+let find_inline_of_delta kn resolve =
+  match Deltamap.find_kn kn resolve with
+    | Inline (_,o) -> o
+    | _ -> raise Not_found
 
-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
+  try find_inline_of_delta kn2 resolve
+  with Not_found ->
+    try find_inline_of_delta kn1 resolve
+    with Not_found -> None
 
-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,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,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 l = list_contents sub in
-  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_comma f l) ++ str "}"
-      
-      
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
-    | MPfile sid -> 
-        let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
-         mp',resolve
+    | MPfile sid -> Umap.find_mp mp sub
     | MPbound bid ->
 	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
+	  try Umap.find_mbi bid sub
+	  with Not_found -> Umap.find_mp mp sub
 	end
     | MPdot (mp1,l) as mp2 ->
 	begin
-	  try
-	    let mp',resolve = Umap.find (MPI mp2) sub in
-              mp',resolve
+	  try Umap.find_mp mp2 sub
 	  with Not_found ->
 	    let mp1',resolve = aux mp1 in
-	      MPdot (mp1',l),resolve
+	    MPdot (mp1',l),resolve
 	end
  in
-  try
-    Some (aux mp)
-  with Not_found -> None
+ try Some (aux mp) with Not_found -> None
 
 let subst_mp sub mp =
  match subst_mp0 sub mp with
@@ -327,107 +271,47 @@ 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 gen_subst_mp f sub mp1 mp2 =
+  match subst_mp0 sub mp1, subst_mp0 sub mp2 with
+    | None, None -> raise No_subst
+    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
+    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
+    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
 
-let subst_con sub con =
-  let kn1,kn2 = user_con con,canonical_con con in
+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,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 ->
-	    (* In case of inlining, discard the canonical part (cf #2608) *)
-	    constant_of_kn (user_con con'), t
-    with No_subst -> con , mkConst con 
- 
+  let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+  try
+    let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
+    match side with
+      | User -> mind_of_delta resolve mind'
+      | Canonical -> mind_of_delta2 resolve mind'
+  with No_subst -> mind
 
 let subst_con0 sub con =
   let kn1,kn2 = user_con con,canonical_con con in
   let mp1,dir,l = repr_kn kn1 in
   let mp2,_,_ = repr_kn kn2 in
-    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 
+  let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
+  let dup con = con, mkConst con in
+  let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
+  match constant_of_delta_with_inline resolve con' with
+    | Some t ->
+      (* In case of inlining, discard the canonical part (cf #2608) *)
+      constant_of_kn (user_con con'), t
+    | None ->
+      let con'' = match side with
+	| User -> constant_of_delta resolve con'
+	| Canonical -> constant_of_delta2 resolve con'
       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) 
-		
+      if con'' == con then raise No_subst else dup con''
+
+let subst_con sub con =
+  try subst_con0 sub con
+  with No_subst -> con, 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"
@@ -437,29 +321,22 @@ let subst_evaluable_reference subst = function
   | EvalVarRef id -> EvalVarRef id
   | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
 
-
-
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match kind_of_term c with
-      | Const kn ->
-	  (match f' kn with
-	       None -> c
-	     | Some const ->const)
+      | Const kn -> (try snd (f' kn) with No_subst -> c)
       | Ind (kn,i) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	      mkInd (kn',i))
+	  let kn' = f kn in
+	  if kn'==kn then c else mkInd (kn',i)
       | Construct ((kn,i),j) ->
-         (match f kn with
-             None -> c
-           | Some kn' ->
-	       mkConstruct ((kn',i),j))
+	  let kn' = f kn in
+	  if kn'==kn then c else mkConstruct ((kn',i),j)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
-              (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
+	    let kn' = f kn in
+	    if kn'==kn then ci.ci_ind else kn',i
+	  in
 	  let p' = func p in
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
@@ -510,8 +387,9 @@ let rec map_kn f f' c =
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-let subst_mps sub =
-  map_kn (subst_mind0 sub) (subst_con0 sub)
+let subst_mps sub c =
+  if is_empty_subst sub then c
+  else map_kn (subst_ind sub) (subst_con0 sub) c
 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
@@ -533,117 +411,76 @@ let rec mp_in_mp mp mp1 =
     | _ 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
+  let mp_prefix mkey mequ rslv =
+    if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv
+  in
+  let kn_prefix kn hint rslv =
+    match hint with
+      | Inline _ -> rslv
+      | Equiv _ ->
+	if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv
   in
-    Deltamap.fold prefixmp resolver empty_delta_resolver
+  Deltamap.fold mp_prefix kn_prefix 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
+  let mp_apply_subst mkey mequ rslv =
+    Deltamap.add_mp (subst_mp subst mkey) mequ rslv
+  in
+  let kn_apply_subst kkey hint rslv =
+    Deltamap.add_kn (subst_kn subst kkey) hint rslv
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
 
-let subst_mp_delta sub mp key=
+let subst_mp_delta sub mp mkey =
  match subst_mp0 sub mp with
     None -> empty_delta_resolver,mp
-  | Some (mp',resolve) -> 
+  | 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
+      (subst_dom_delta_resolver
+	 (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1
+
+let gen_subst_delta_resolver dom subst resolver =
+  let mp_apply_subst mkey mequ rslv =
+    let mkey' = if dom then subst_mp subst mkey else mkey in
+    let rslv',mequ' = subst_mp_delta subst mequ mkey in
+    Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv)
   in
-    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" 
+  let kn_apply_subst kkey hint rslv =
+    let kkey' = if dom then subst_kn subst kkey else kkey in
+    let hint' = match hint with
+      | Equiv kequ ->
+	  (try Equiv (subst_kn_delta subst kequ)
+	   with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c))
+      | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t))
+      | Inline (_,None) -> hint
+    in
+    Deltamap.add_kn kkey' hint' rslv
   in
-    Deltamap.fold apply_subst resolver empty_delta_resolver
+  Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
+
+let subst_codom_delta_resolver = gen_subst_delta_resolver false
+let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
 
 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
-      Deltamap.fold apply_res resolver1 empty_delta_resolver
+  let mp_apply_rslv mkey mequ rslv =
+    if Deltamap.mem_mp mkey resolver2 then rslv
+    else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+  in
+  let kn_apply_rslv kkey hint rslv =
+    if Deltamap.mem_kn kkey resolver2 then rslv
+    else
+      let hint' = match hint with
+	| Equiv kequ ->
+	  (try Equiv (solve_delta_kn resolver2 kequ)
+	   with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
+	| _ -> hint
+      in
+      Deltamap.add_kn kkey hint' rslv
+  in
+  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver
 
 let add_delta_resolver resolver1 resolver2 =
   if resolver1 == resolver2 then
@@ -651,63 +488,54 @@ let add_delta_resolver resolver1 resolver2 =
   else if resolver2 = empty_delta_resolver then
     resolver1
   else
-    Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2)
-      resolver2
+    Deltamap.join (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
+  let mp_prefixmp kmp (mp_to,reso) sub =
+    if mp_in_mp mp kmp && mp <> kmp then
+      let new_key = replace_mp_in_mp mp k kmp in
+      Umap.add_mp new_key (mp_to,reso) sub
+    else sub
+  in
+  let mbi_prefixmp mbi _ sub = sub
   in
-    Umap.fold prefixmp subst empty_subst
+  Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst
 
-let join (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst key (mp,resolve) res =
+let join subst1 subst2 =
+  let apply_subst mpk add (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 =
+	| None -> mp, None
+	| Some (mp',resolve') ->  mp', Some resolve' in
+    let resolve'' =
       match resolve' with
-          Some res -> 
-	    add_delta_resolver 
+        | Some res ->
+	    add_delta_resolver
 	      (subst_dom_codom_delta_resolver subst2 resolve) res
-	| None -> 
+	| 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 rec occur_in_path uid path =
- match uid,path with
-  | MBI bid,MPbound bid' -> bid = bid'
-  | _,MPdot (mp1,_) -> occur_in_path uid mp1
+    let prefixed_subst = substition_prefixed_by mpk mp' subst2 in
+    Umap.join prefixed_subst (add (mp',resolve'') res)
+  in
+  let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in
+  let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in
+  let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in
+  Umap.join subst2 subst
+
+let rec occur_in_path mbi = function
+  | MPbound bid' -> mbi = bid'
+  | MPdot (mp1,_) -> occur_in_path mbi mp1
   | _ -> false
 
-let occur_uid uid sub =
-  let check_one uid' (mp,_) =
-    if uid = uid' || occur_in_path uid mp then raise Exit
+let occur_mbid mbi sub =
+  let check_one mbi' (mp,_) =
+    if mbi = mbi' || occur_in_path mbi mp then raise Exit
   in
-    try
-      Umap.iter check_one sub;
-      false
-    with Exit -> true
-
-
-let occur_mbid uid = occur_uid (MBI uid)
+  try
+    Umap.iter_mbi check_one sub;
+    false
+  with Exit -> true
 
 type 'a lazy_subst =
   | LSval of 'a
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index 9b48b3ea..55d2ff15 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -1,105 +1,108 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_subst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s [Mod_subst] *)
+(** {6 [Mod_subst] } *)
 
 open Names
 open Term
 
-(* A delta_resolver maps name (constant, inductive, module_path) 
+(** {6 Delta resolver} *)
+
+(** A delta_resolver maps name (constant, inductive, module_path)
    to canonical name  *)
 type delta_resolver
 
-type substitution
-
 val empty_delta_resolver : delta_resolver
 
-val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver
+val add_mp_delta_resolver :
+  module_path -> module_path -> delta_resolver -> delta_resolver
 
-val add_inline_constr_delta_resolver :  constant -> constr -> delta_resolver 
-  -> delta_resolver
+val add_kn_delta_resolver :
+  kernel_name -> kernel_name -> 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_inline_delta_resolver :
+  kernel_name -> (int * constr option) -> 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
+(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *)
 
-(* 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 kn_of_delta : delta_resolver -> kernel_name -> kernel_name
+val constant_of_delta_kn : delta_resolver -> kernel_name -> constant
 val constant_of_delta : delta_resolver -> constant -> constant
 
+val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
 val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
 
-val delta_of_mp : delta_resolver -> module_path -> module_path
+val mp_of_delta : delta_resolver -> module_path -> module_path
 
-(* Extract the set of inlined constant in the resolver *)
-val inline_of_delta : delta_resolver -> kernel_name list
+(** Extract the set of inlined constant in the resolver *)
+val inline_of_delta : int option -> delta_resolver -> (int * 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
+(** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *)
 
-
-(* 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*)
+
+(** {6 Substitution} *)
+
+type substitution
 
 val empty_subst : substitution
 
-(* add_* add [arg2/arg1]{arg3} to the substitution with no 
+val is_empty_subst : substitution -> bool
+
+(** add_* add [arg2/arg1]\{arg3\} to the substitution with no
    sequential composition  *)
 val add_mbid :
   mod_bound_id -> module_path -> delta_resolver  -> substitution -> substitution
 val add_mp :
   module_path -> module_path -> delta_resolver -> substitution -> substitution
 
-(* map_* create a new substitution [arg2/arg1]{arg3} *)
+(** map_* create a new substitution [arg2/arg1]\{arg3\} *)
 val map_mbid :
   mod_bound_id -> module_path -> delta_resolver -> substitution
 val map_mp :
   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
 
+
+(** 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
+
+
 type 'a substituted
 val from_val : 'a -> 'a substituted
 val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a
 val subst_substituted : substitution -> 'a substituted -> 'a substituted
 
-(*i debugging *)
+(**/**)
+(* 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
+(** [subst_mp sub mp] guarantees that whenever the result of the
    substitution is structutally equal [mp], it is equal by pointers
    as well [==] *)
 
@@ -109,13 +112,13 @@ val subst_mp :
 val subst_ind :
   substitution -> mutual_inductive -> mutual_inductive
 
-val subst_kn : 
+val subst_kn :
   substitution -> kernel_name -> kernel_name
 
 val subst_con :
   substitution -> constant -> constant * constr
 
-(* Here the semantics is completely unclear.
+(** 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"
    where X.t is later on instantiated with y? I choose the first
@@ -123,14 +126,14 @@ val subst_con :
 val subst_evaluable_reference :
   substitution -> evaluable_global_reference -> evaluable_global_reference
 
-(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
+(** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
 val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name
 
-(* [subst_mps sub c] performs the substitution [sub] on all kernel
+(** [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_mbid : mod_bound_id -> substitution -> bool
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index e366bc97..a384c836 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -1,12 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module provides the main functions for type-checking module
+   declarations *)
 
 open Util
 open Names
@@ -25,18 +29,17 @@ let path_of_mexpr = function
   | MSEident mp -> mp
   | _ -> raise Not_path
 
+let rec mp_from_mexpr = function
+  | MSEident mp -> mp
+  | MSEapply (expr,_) -> mp_from_mexpr expr
+  | MSEfunctor (_,_,expr) -> mp_from_mexpr expr
+  | MSEwith (expr,_) -> mp_from_mexpr expr
+
 let rec list_split_assoc k rev_before = function
   | [] -> raise Not_found
   | (k',b)::after when k=k' -> rev_before,b,after
   | h::tail -> list_split_assoc k (h::rev_before) tail
 
-let rec list_fold_map2 f e = function
-  |  []  -> (e,[],[])
-  |  h::t ->
-       let e',h1',h2' = f e h in
-       let e'',t1',t2' = list_fold_map2 f e' t in
-	 e'',h1'::t1',h2'::t2'
-
 let discr_resolver env mtb =
      match mtb.typ_expr with
 	SEBstruct _ -> 
@@ -81,40 +84,41 @@ and check_with_aux_def env sign with_decl mp equiv =
           | With_Definition ([],_) -> assert false
 	  | With_Definition ([id],c) ->
 	      let cb = match spec with
-		  SFBconst cb -> cb
+		| SFBconst cb -> cb
 		| _ -> error_not_a_constant l
 	      in
-		begin
-		  match cb.const_body with
-		    | 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
-			    (Constraint.union cb.const_constraints cst1)
-			    cst2 in
-			let body = Some (Declarations.from_val j.uj_val) in
-			let cb' = {cb with
-				     const_body = body;
-				     const_body_code = Cemitcodes.from_val
-                            (compile_constant_body env' body false false);
-                                     const_constraints = cst} in
-			  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
-				     const_body = body;
-				     const_body_code = Cemitcodes.from_val
-                            (compile_constant_body env' body false false);
-                                     const_constraints = cst} in
-			  SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
-	      end
+	      (* In the spirit of subtyping.check_constant, we accept
+                 any implementations of parameters and opaques terms,
+	         as long as they have the right type *)
+	      let def,cst = match cb.const_body with
+		| Undef _ | OpaqueDef _ ->
+		    let (j,cst1) = Typeops.infer env' c in
+		    let typ = Typeops.type_of_constant_type env' cb.const_type in
+		    let cst2 = Reduction.conv_leq env' j.uj_type typ in
+		    let cst =
+		      union_constraints
+			(union_constraints cb.const_constraints cst1)
+			cst2
+		    in
+		    let def = Def (Declarations.from_val j.uj_val) in
+		    def,cst
+		| Def cs ->
+		    let cst1 = Reduction.conv env' c (Declarations.force cs) in
+		    let cst = union_constraints cb.const_constraints cst1 in
+		    let def = Def (Declarations.from_val c) in
+		    def,cst
+	      in
+	      let cb' =
+		{ cb with
+		  const_body = def;
+		  const_body_code =
+		    Cemitcodes.from_val (compile_constant_body env' def);
+		  const_constraints = cst }
+	      in
+	      SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
 	  | With_Definition (_::_,c) ->
 	      let old = match spec with
-		  SFBmodule msb -> msb
+		| SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
 	      in
 		begin
@@ -129,12 +133,12 @@ and check_with_aux_def env sign with_decl mp equiv =
 						    mod_type_alg = None}) in
 			  SEBstruct(before@((l,new_spec)::after)),cb,cst
                     | Some msb ->
-			error_a_generative_module_expected l
+			error_generative_module_expected l
 		end
 	  | _ -> anomaly "Modtyping:incorrect use of with"
     with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
+      | Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_incorrect_with_constraint l
 
 and check_with_aux_mod env sign with_decl mp equiv = 
   let sig_b = match sign with 
@@ -163,24 +167,24 @@ and check_with_aux_mod env sign with_decl mp equiv =
 	      in
 	      let mb_mp1 = (lookup_module mp1 env) in
 	      let mtb_mp1 = 
-		module_type_of_module env' None mb_mp1  in
+		module_type_of_module None mb_mp1  in
 	      let cst =
 		match old.mod_expr with
 		    None ->
 		      begin
-			try Constraint.union
+			try union_constraints
 			  (check_subtypes env' mtb_mp1 
-			     (module_type_of_module env' None old))
+			     (module_type_of_module None old))
 			  old.mod_constraints
-			with Failure _ -> error_with_incorrect (label_of_id id)
+			with Failure _ -> error_incorrect_with_constraint (label_of_id id)
 		      end
 		  | Some (SEBident(mp')) ->
 		      check_modpath_equiv env' mp1 mp';
 		      old.mod_constraints
-		  | _ ->  error_a_generative_module_expected l
+		  | _ ->  error_generative_module_expected l
+	      in
+	      let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false
 	      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);
@@ -215,14 +219,14 @@ and check_with_aux_mod env sign with_decl mp equiv =
 		      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
+			    ,equiv,empty_constraint
 		  | _ ->
-		      error_a_generative_module_expected l
+		      error_generative_module_expected l
               end
 	  | _ -> anomaly "Modtyping:incorrect use of with"
     with
 	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_with_incorrect l
+      | Reduction.NotConvertible -> error_incorrect_with_constraint l
 
 and translate_module env mp inl me =
   match me.mod_entry_expr, me.mod_entry_type with
@@ -243,14 +247,14 @@ and translate_module env mp inl me =
 	let sign,alg1,resolver,cst2 =
 	  match me.mod_entry_type with
 	    | None ->
-		sign,None,resolver,Constraint.empty
+		sign,None,resolver,empty_constraint
 	    | Some mte ->
 		let mtb = translate_module_type env mp inl mte in
                 let cst = check_subtypes env
 		  {typ_mp = mp;
 		   typ_expr = sign;
 		   typ_expr_alg = None;
-		   typ_constraints = Constraint.empty;
+		   typ_constraints = empty_constraint;
 		   typ_delta = resolver;}
 		  mtb
 		in
@@ -258,9 +262,9 @@ and translate_module env mp inl me =
 	in
 	  { mod_mp = mp;
 	    mod_type = sign;
-	    mod_expr = Some alg_implem;
+	    mod_expr = alg_implem;
 	    mod_type_alg = alg1;
-	    mod_constraints = Univ.Constraint.union cst1 cst2;
+	    mod_constraints = Univ.union_constraints cst1 cst2;
 	    mod_delta = resolver;
 	    mod_retroknowledge = []} 
 	    (* spiwack: not so sure about that. It may
@@ -268,125 +272,92 @@ and translate_module env mp inl me =
 	       If it does, I don't really know how to
 	       fix the bug.*)
 
+and translate_apply env inl ftrans mexpr mkalg =
+  let sign,alg,resolver,cst1 = ftrans in
+  let farg_id, farg_b, fbody_b = destr_functor env sign in
+  let mp1 =
+    try path_of_mexpr mexpr
+    with Not_path -> error_application_to_not_path mexpr
+  in
+  let mtb = module_type_of_module None (lookup_module mp1 env) in
+  let cst2 = check_subtypes env mtb farg_b in
+  let mp_delta = discr_resolver env mtb in
+  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
+  let subst = map_mbid farg_id mp1 mp_delta
+  in
+  subst_struct_expr subst fbody_b,
+  mkalg alg mp1 cst2,
+  subst_codom_delta_resolver subst resolver,
+  Univ.union_constraints cst1 cst2
+
+and translate_functor env inl arg_id arg_e trans mkalg =
+  let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
+  let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
+  let sign,alg,resolver,cst = trans env'
+  in
+  SEBfunctor (arg_id, mtb, sign),
+  mkalg alg arg_id mtb,
+  resolver,
+  Univ.union_constraints cst mtb.typ_constraints
 
-and translate_struct_module_entry env mp inl mse  = match mse with
+and translate_struct_module_entry env mp inl = function
   | MSEident mp1 ->
-      let mb = lookup_module mp1 env in 
-      let mb' = strengthen_and_subst_mb mb mp env false in
-	mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty
+      let mb = lookup_module mp1 env in
+      let mb' = strengthen_and_subst_mb mb mp false in
+      mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint
   | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let 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
+      let trans env' = translate_struct_module_entry env' mp inl body_expr in
+      let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in
+      translate_functor env inl arg_id arg_e trans mkalg
   | MSEapply (fexpr,mexpr) ->
-      let sign,alg,resolver,cst1 =
-	translate_struct_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),SEBapply(alg,SEBident mp1,cst),
-      (subst_codom_delta_resolver subst resolver),
-      Univ.Constraint.union cst1 cst
+      let trans = translate_struct_module_entry env mp inl fexpr in
+      let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in
+      translate_apply env inl trans mexpr mkalg
   | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in
-      let sign,alg,resolve,cst2 = check_with env sign with_decl (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
+      let sign,alg,resolve,cst1 =
+	translate_struct_module_entry env mp inl mte in
+      let sign,alg,resolve,cst2 =
+	check_with env sign with_decl alg mp resolve in
+      sign,alg,resolve,Univ.union_constraints cst1 cst2
+
+and translate_struct_type_entry env inl = function
   | MSEident mp1 ->
-      let mtb = lookup_modtype mp1 env in 
-	mtb.typ_expr,
-      Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty
+      let mtb = lookup_modtype mp1 env in
+      mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint
   | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let 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
+      let trans env' = translate_struct_type_entry env' inl body_expr in
+      translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None)
   | MSEapply (fexpr,mexpr) ->
-      let 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
+      let trans = translate_struct_type_entry env inl fexpr in
+      translate_apply env inl trans mexpr (fun _ _ _ -> None)
   | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,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    
+      let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in
+      let sign,alg,resolve,cst2 =
+	check_with env sign with_decl alg (mp_from_mexpr mte) resolve
+      in
+      sign,alg,resolve,Univ.union_constraints cst1 cst2
 
 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 mp_from = mp_from_mexpr mte in
+  let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
+  let mtb = subst_modtype_and_resolver
+    {typ_mp = mp_from;
+     typ_expr = sign;
+     typ_expr_alg = None;
+     typ_constraints = cst;
+     typ_delta = resolve} mp
+  in {mtb with typ_expr_alg = alg}
 
-let rec translate_struct_include_module_entry env mp inl mse  = match mse with
+let rec translate_struct_include_module_entry env mp inl = function
   | MSEident mp1 ->
-      let mb = lookup_module mp1 env in 
-      let mb' = strengthen_and_subst_mb mb mp env true in
-      let mb_typ = clean_bounded_mod_expr mb'.mod_type in 
-	mb_typ, mb'.mod_delta,Univ.Constraint.empty
+      let mb = lookup_module mp1 env in
+      let mb' = strengthen_and_subst_mb mb mp true in
+      let mb_typ = clean_bounded_mod_expr mb'.mod_type in
+      mb_typ,None,mb'.mod_delta,Univ.empty_constraint
   | MSEapply (fexpr,mexpr) ->
-      let 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
+      let ftrans = translate_struct_include_module_entry env mp inl fexpr in
+      translate_apply env inl ftrans mexpr (fun _ _ _ -> None)
   | _ -> error ("You cannot Include a high-order structure.")
-  
 
 let rec add_struct_expr_constraints env = function
   | SEBident _ -> env
@@ -448,11 +419,11 @@ let rec struct_expr_constraints cst = function
 
   | SEBapply (meb1,meb2,cst1) ->
       struct_expr_constraints
-	(struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
+	(struct_expr_constraints (Univ.union_constraints cst1 cst) meb1)
 	meb2
   | SEBwith(meb,With_definition_body(_,cb))->
       struct_expr_constraints
-        (Univ.Constraint.union cb.const_constraints cst) meb
+        (Univ.union_constraints cb.const_constraints cst) meb
   | SEBwith(meb,With_module_body(_,_))->
       struct_expr_constraints  cst meb	
 		
@@ -468,11 +439,11 @@ and module_constraints cst mb =
     | Some meb -> struct_expr_constraints cst meb in
   let cst = 
       struct_expr_constraints cst mb.mod_type in
-  Univ.Constraint.union mb.mod_constraints cst
+  Univ.union_constraints mb.mod_constraints cst
 
 and modtype_constraints cst mtb =
-  struct_expr_constraints  (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr
+  struct_expr_constraints  (Univ.union_constraints 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
+let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint
+let module_constraints = module_constraints Univ.empty_constraint
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index ec5eb332..0987ca5b 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -1,36 +1,44 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Declarations
 open Environ
 open Entries
 open Mod_subst
 open Names
-(*i*)
-
-
-val translate_module : env -> module_path -> bool -> module_entry
-  -> module_body
-
-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 translate_module :
+  env -> module_path -> inline -> module_entry -> module_body
+
+val translate_module_type :
+  env -> module_path -> inline -> module_struct_entry -> module_type_body
+
+val translate_struct_module_entry :
+  env -> module_path -> inline -> module_struct_entry ->
+  struct_expr_body (* Signature *)
+  * struct_expr_body option  (* Algebraic expr, in fact never None *)
+  * delta_resolver
+  * Univ.constraints
+
+val translate_struct_type_entry :
+  env -> inline -> module_struct_entry ->
+  struct_expr_body
+  * struct_expr_body option
+  * delta_resolver
+  * Univ.constraints
+
+val translate_struct_include_module_entry :
+  env -> module_path -> inline -> module_struct_entry ->
+  struct_expr_body
+  * struct_expr_body option (* Algebraic expr, always None *)
+  * delta_resolver
+  * Univ.constraints
 
 val add_modtype_constraints : env -> module_type_body -> env
 
diff --git a/kernel/modops.ml b/kernel/modops.ml
index f0d579a4..0c2c6bd7 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -1,14 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+(* Inlining and more liberal use of modules and module types by Claudio
+   Sacerdoti, Nov 2004 *)
+(* New structure-based model of modules and miscellaneous bug fixes by
+   Élie Soubiran, from Feb 2008 *)
+
+(* This file provides with various operations on modules and module types *)
 
-(*i*)
 open Util
 open Pp
 open Names
@@ -18,80 +24,103 @@ open Declarations
 open Environ
 open Entries
 open Mod_subst
-(*i*)
-
-
-
-let error_existing_label l = 
-  error ("The label "^string_of_label l^" is already declared.")
-
-let error_declaration_not_path _ = error "Declaration is not a path."
-
-let error_application_to_not_path _ = error "Application to not path."
-
-let error_not_a_functor _ = error "Application of not a functor."
-
-let error_incompatible_modtypes _ _ = error "Incompatible module types."
-
-let error_not_equal _ _ = error "Non equal modules."
 
-let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match.")
-
-let error_no_such_label l = error ("No such label "^string_of_label l^".")
-
-let error_incompatible_labels l l' = 
-  error ("Opening and closing labels are not the same: "
-	 ^string_of_label l^" <> "^string_of_label l'^" !")
-
-let error_result_must_be_signature () = 
-  error "The result module type must be a signature."
+type signature_mismatch_error =
+  | InductiveFieldExpected of mutual_inductive_body
+  | DefinitionFieldExpected
+  | ModuleFieldExpected
+  | ModuleTypeFieldExpected
+  | NotConvertibleInductiveField of identifier
+  | NotConvertibleConstructorField of identifier
+  | NotConvertibleBodyField
+  | NotConvertibleTypeField
+  | NotSameConstructorNamesField
+  | NotSameInductiveNameInBlockField
+  | FiniteInductiveFieldExpected of bool
+  | InductiveNumbersFieldExpected of int
+  | InductiveParamsNumberField of int
+  | RecordFieldExpected of bool
+  | RecordProjectionsExpected of name list
+  | NotEqualInductiveAliases
+  | NoTypeConstraintExpected
+
+type module_typing_error =
+  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of label
+  | ApplicationToNotPath of module_struct_entry
+  | NotAFunctor of struct_expr_body
+  | IncompatibleModuleTypes of module_type_body * module_type_body
+  | NotEqualModulePaths of module_path * module_path
+  | NoSuchLabel of label
+  | IncompatibleLabels of label * label
+  | SignatureExpected of struct_expr_body
+  | NoModuleToEnd
+  | NoModuleTypeToEnd
+  | NotAModule of string
+  | NotAModuleType of string
+  | NotAConstant of label
+  | IncorrectWithConstraint of label
+  | GenerativeModuleExpected of label
+  | NonEmptyLocalContect of label option
+  | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
+
+let error_existing_label l =
+  raise (ModuleTypingError (LabelAlreadyDeclared l))
+
+let error_application_to_not_path mexpr =
+  raise (ModuleTypingError (ApplicationToNotPath mexpr))
+
+let error_not_a_functor mtb =
+  raise (ModuleTypingError (NotAFunctor mtb))
+
+let error_incompatible_modtypes mexpr1 mexpr2 =
+  raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2)))
+
+let error_not_equal_modpaths mp1 mp2 =
+  raise (ModuleTypingError (NotEqualModulePaths (mp1,mp2)))
+
+let error_signature_mismatch l spec why =
+  raise (ModuleTypingError (SignatureMismatch (l,spec,why)))
+
+let error_no_such_label l =
+  raise (ModuleTypingError (NoSuchLabel l))
+
+let error_incompatible_labels l l' =
+  raise (ModuleTypingError (IncompatibleLabels (l,l')))
 
 let error_signature_expected mtb =
-  error "Signature expected."
+  raise (ModuleTypingError (SignatureExpected mtb))
 
-let error_no_module_to_end _ = 
-  error "No open module to end."
+let error_no_module_to_end _ =
+  raise (ModuleTypingError NoModuleToEnd)
 
 let error_no_modtype_to_end _ =
-  error "No open module type to end."
-
-let error_not_a_modtype_loc loc s = 
-  user_err_loc (loc,"",str ("\""^s^"\" is not a module type."))
-
-let error_not_a_module_loc loc s = 
-  user_err_loc (loc,"",str ("\""^s^"\" is not a module."))
+  raise (ModuleTypingError NoModuleTypeToEnd)
 
-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_modtype s =
+  raise (ModuleTypingError (NotAModuleType s))
 
-let error_not_a_module s = error_not_a_module_loc dummy_loc s
+let error_not_a_module s =
+  raise (ModuleTypingError (NotAModule s))
 
-let error_not_a_constant l = 
-  error ("\""^(string_of_label l)^"\" is not a constant.")
+let error_not_a_constant l =
+  raise (ModuleTypingError (NotAConstant l))
 
-let error_with_incorrect l =
-  error ("Incorrect constraint for label \""^(string_of_label l)^"\".")
+let error_incorrect_with_constraint l =
+  raise (ModuleTypingError (IncorrectWithConstraint l))
 
-let error_a_generative_module_expected l =
-  error ("The module " ^ string_of_label l ^ " is not generative. Only " ^
-         "component of generative modules can be changed using the \"with\" " ^
-         "construct.")
-
-let error_local_context lo = 
-  match lo with
-      None -> 
-	error ("The local context is not empty.")
-    | (Some l) ->
-	error ("The local context of the component "^
-	       (string_of_label l)^" is not empty.")
+let error_generative_module_expected l =
+  raise (ModuleTypingError (GenerativeModuleExpected l))
 
+let error_non_empty_local_context lo =
+  raise (ModuleTypingError (NonEmptyLocalContect lo))
 
 let error_no_such_label_sub l l1 =
-  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."
+  raise (ModuleTypingError (LabelMissing (l,l1)))
 
-let error_application_to_module_type _ = error "Module application to a module type."
+(************************)
 
 let destr_functor env mtb =
   match mtb with
@@ -116,9 +145,9 @@ 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)
+      if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2)
       then ()
-      else error_not_equal mp1 mp2
+      else error_not_equal_modpaths mp1 mp2
 	
 let rec subst_with_body sub = function
   | With_module_body(id,mp) ->
@@ -235,18 +264,13 @@ let add_retroknowledge mp =
 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 = constant_of_kn kn in
-    let mind = mind_of_kn kn in
-      match elem with
-	| 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 *)
-	| SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+    match elem with
+      | SFBconst cb ->
+	Environ.add_constant (constant_of_delta_kn resolver kn) cb env
+      | SFBmind mib ->
+	Environ.add_mind (mind_of_delta_kn resolver kn) mib env
+      | SFBmodule mb -> add_module mb env (* adds components as well *)
+      | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
   in
     List.fold_left add_one env sign
 
@@ -260,100 +284,83 @@ and add_module mb env =
       | SEBfunctor _ -> env
       | _ -> anomaly "Modops:the evaluation of the structure failed "
 
-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 = 
+let strengthen_const mp_from l cb resolver =
+  match cb.const_body with
+    | Def _ -> cb
+    | _ ->
+      let kn = make_kn mp_from empty_dirpath l in
+      let con = constant_of_delta_kn resolver kn in
+      { cb with
+	const_body = Def (Declarations.from_val (mkConst con));
+	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con)
+      }
+
+let rec strengthen_mod mp_from mp_to mb =
   if mp_in_delta mb.mod_mp mb.mod_delta then
-    mb 
+    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
+     | SEBstruct (sign) ->
+	 let resolve_out,sign_out =
+	   strengthen_sig mp_from sign mp_to mb.mod_delta in
 	   { mb with
 	       mod_expr = Some (SEBident mp_to);
 	       mod_type = SEBstruct(sign_out);
 	       mod_type_alg = mb.mod_type_alg;
 	       mod_constraints = mb.mod_constraints;
-	       mod_delta = add_mp_delta_resolver mp_from mp_to 
+	       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 =
+
+and strengthen_sig mp_from sign mp_to resolver =
   match sign with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = 
-	  l,SFBconst (strengthen_const 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'
+	let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item'::rest'
     | (_,SFBmind _ as item):: rest ->
-	let resolve_out,rest' = 
-	  strengthen_sig env mp_from rest mp_to resolver in
-	  resolve_out,item::rest'
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in 
-	let mb_out = 
-	  strengthen_mod env mp_from' mp_to' mb in
+	let mp_to' = MPdot(mp_to,l) in
+	let mb_out = strengthen_mod mp_from' mp_to' mb in
 	let item' = l,SFBmodule (mb_out) in
-	let 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'
-    
-let strengthen env mtb mp = 
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	add_delta_resolver resolve_out mb.mod_delta, item':: rest'
+    | (l,SFBmodtype mty as item) :: rest ->
+	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+	resolve_out,item::rest'
+
+let strengthen mtb mp =
   if mp_in_delta mtb.typ_mp mtb.typ_delta then
     (* in this case mtb has already been strengthened*)
-    mtb 
+    mtb
   else
     match mtb.typ_expr with
-      | SEBstruct (sign) -> 
+      | SEBstruct (sign) ->
 	  let resolve_out,sign_out =
-	    strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in
+	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
 	    {mtb with
 	       typ_expr = SEBstruct(sign_out);
 	       typ_delta = add_delta_resolver mtb.typ_delta
 		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
       | SEBfunctor _ -> mtb
       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	  
-let module_type_of_module env mp mb =
+
+let module_type_of_module mp mb =
   match mp with
       Some mp ->
-	strengthen env {
+	strengthen {
 	  typ_mp = mp;
 	  typ_expr = mb.mod_type;
 	  typ_expr_alg = None;
 	  typ_constraints = mb.mod_constraints;
 	  typ_delta = mb.mod_delta} mp
-	  
+
     | None ->
 	{typ_mp = mb.mod_mp;
 	 typ_expr = mb.mod_type;
@@ -361,34 +368,29 @@ let module_type_of_module env mp mb =
 	 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 inline_delta_resolver env inl mp mbid mtb delta =
+  let constants = inline_of_delta inl mtb.typ_delta in
   let rec make_inline delta = function
     | [] -> delta
-    | kn::r -> 
+    | (lev,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))
+	let con = constant_of_delta_kn delta kn in
+	try
+	  let constant = lookup_constant con env in
+	  let l = make_inline delta r in
+	  match constant.const_body with
+	    | Undef _ | OpaqueDef _ -> l
+	    | Def body ->
+	      let constr = Declarations.force body in
+	      add_inline_delta_resolver kn (lev, Some constr) l
+	with Not_found ->
+	  error_no_such_label_sub (con_label con)
+	    (string_of_mp (con_modpath con))
   in
-    make_inline delta constants
+  make_inline delta constants
 
 let rec strengthen_and_subst_mod
-    mb subst env mp_from mp_to env resolver =
+    mb subst mp_from mp_to resolver =
      match mb.mod_type with
 	 SEBstruct(str) ->
 	   let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
@@ -397,7 +399,7 @@ let rec strengthen_and_subst_mod
 	       (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb 
 	   else
 	     let resolver,new_sig = 
-	       strengthen_and_subst_struct str subst env
+	       strengthen_and_subst_struct str subst
 		 mp_from mp_from mp_to false false mb.mod_delta 
 	     in
 	       {mb with 
@@ -413,42 +415,48 @@ let rec strengthen_and_subst_mod
        | _ -> 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 =
+    str subst mp_alias mp_from mp_to alias incl resolver =
   match str with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = if alias then
+	let item' = if alias then 
+	  (* case alias no strengthening needed*)
 	  l,SFBconst (subst_const_body subst cb) 
 	else 
-	  l,SFBconst (strengthen_const env mp_from l 
+	  l,SFBconst (strengthen_const 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 
+	  strengthen_and_subst_struct rest subst
 	    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'
-	  else
-	    resolve_out,item'::rest'
+	if incl then
+	    (* If we are performing an inclusion we need to add
+	       the fact that the constant mp_to.l is \Delta-equivalent
+	       to resolver(mp_from.l) *)
+	  let kn_from = make_kn mp_from empty_dirpath l in
+	  let kn_to = make_kn mp_to empty_dirpath l in
+	  let old_name = kn_of_delta resolver kn_from in
+	  (add_kn_delta_resolver kn_to old_name resolve_out),
+	  item'::rest'
+	else
+	    (*In this case the fact that the constant mp_to.l is 
+	      \Delta-equivalent to resolver(mp_from.l) is already known
+	       because resolve_out contains mp_to maps to resolver(mp_from)*)
+	  resolve_out,item'::rest'
     | (l,SFBmind mib) :: rest ->
+	(*Same as constant*)
 	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 
+	  strengthen_and_subst_struct rest subst
 	    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'
-	  else
-	    resolve_out,item'::rest'
+	if incl then
+	  let kn_from = make_kn mp_from empty_dirpath l in
+	  let kn_to = make_kn mp_to empty_dirpath l in
+	  let old_name = kn_of_delta resolver kn_from in
+	  (add_kn_delta_resolver kn_to old_name resolve_out),
+	  item'::rest'
+	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
@@ -457,15 +465,20 @@ and strengthen_and_subst_struct
 	  (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb 
 	else
 	  strengthen_and_subst_mod
-	    mb subst env mp_from' mp_to' env resolver
+	    mb subst mp_from' mp_to' 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' 
+	let resolve_out,rest' =
+	  strengthen_and_subst_struct rest subst
 	    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
+	  (* if mb is a functor we should not derive new equivalences
+	     on names, hence we add the fact that the functor can only
+	     be equivalent to itself. If we adopt an applicative
+	     semantic for functor this should be changed.*)
+	  if is_functor mb_out.mod_type then 
+	    (add_mp_delta_resolver 
+	       mp_to' mp_to' resolve_out),item':: rest' 
+	  else
 	    add_delta_resolver resolve_out mb_out.mod_delta,
 	item':: rest'
     | (l,SFBmodtype mty) :: rest -> 
@@ -474,27 +487,30 @@ and strengthen_and_subst_struct
 	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' 
+	let resolve_out,rest' = strengthen_and_subst_struct rest subst
 	    mp_alias mp_from mp_to alias incl resolver in
 	  (add_mp_delta_resolver 
 	     mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
     
-let strengthen_and_subst_mb mb mp env include_b =
+
+(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M."
+   we need to perform two operations to compute the body of M. The first one is applying
+   the substitution {P <- M} on the type of P and the second one is strenghtening. *)
+let strengthen_and_subst_mb mb mp include_b =
     match mb.mod_type with
 	SEBstruct str ->
 	  let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	    (*if mb is an alias then the strengthening is useless 
+	    (*if mb.mod_mp 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 mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
 	  let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
 	  let new_resolver = 
 	    add_mp_delta_resolver mp mp_alias
-	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in	    
+	      (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
+	    strengthen_and_subst_struct str subst
+	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta 
 	  in
 	    {mb with 
 	       mod_mp = mp;
@@ -509,7 +525,7 @@ let strengthen_and_subst_mb mb mp env include_b =
       | _ -> anomaly "Modops:the evaluation of the structure failed "
 
 
-let subst_modtype_and_resolver mtb mp env =
+let subst_modtype_and_resolver mtb mp =
   let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
   let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in 
   let full_subst = (map_mp mtb.typ_mp mp new_delta) in
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 37f4e8e0..b9c36d5a 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Univ
@@ -16,14 +13,13 @@ open Environ
 open Declarations
 open Entries
 open Mod_subst
-(*i*)
 
-(* Various operations on modules and module types *)
+(** Various operations on modules and module types *)
 
 
 val module_body_of_type : module_path -> module_type_body  -> module_body 
 
-val module_type_of_module : env -> module_path option -> module_body -> 
+val module_type_of_module : module_path option -> module_body ->
   module_type_body
 
 val destr_functor :
@@ -36,71 +32,95 @@ val subst_signature : substitution -> structure_body -> structure_body
 val add_signature :
   module_path -> structure_body -> delta_resolver -> env -> env
 
-(* adds a module and its components, but not the constraints *)
+(** adds a module and its components, but not the constraints *)
 val add_module : module_body -> env -> env
 
 val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-val strengthen : env -> module_type_body -> module_path -> module_type_body
+val strengthen : module_type_body -> module_path -> module_type_body
 
-val complete_inline_delta_resolver :
-  env -> module_path -> mod_bound_id -> module_type_body ->
+val inline_delta_resolver :
+  env -> inline -> module_path -> mod_bound_id -> module_type_body ->
   delta_resolver -> delta_resolver
 
-val strengthen_and_subst_mb : module_body -> module_path -> env -> bool 
-  -> module_body
+val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
 
-val subst_modtype_and_resolver : module_type_body -> module_path -> env ->
+val subst_modtype_and_resolver : module_type_body -> module_path ->
   module_type_body
 
 val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
 
-val error_existing_label : label -> 'a
+(** Errors *)
+
+type signature_mismatch_error =
+  | InductiveFieldExpected of mutual_inductive_body
+  | DefinitionFieldExpected
+  | ModuleFieldExpected
+  | ModuleTypeFieldExpected
+  | NotConvertibleInductiveField of identifier
+  | NotConvertibleConstructorField of identifier
+  | NotConvertibleBodyField
+  | NotConvertibleTypeField
+  | NotSameConstructorNamesField
+  | NotSameInductiveNameInBlockField
+  | FiniteInductiveFieldExpected of bool
+  | InductiveNumbersFieldExpected of int
+  | InductiveParamsNumberField of int
+  | RecordFieldExpected of bool
+  | RecordProjectionsExpected of name list
+  | NotEqualInductiveAliases
+  | NoTypeConstraintExpected
+
+type module_typing_error =
+  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of label
+  | ApplicationToNotPath of module_struct_entry
+  | NotAFunctor of struct_expr_body
+  | IncompatibleModuleTypes of module_type_body * module_type_body
+  | NotEqualModulePaths of module_path * module_path
+  | NoSuchLabel of label
+  | IncompatibleLabels of label * label
+  | SignatureExpected of struct_expr_body
+  | NoModuleToEnd
+  | NoModuleTypeToEnd
+  | NotAModule of string
+  | NotAModuleType of string
+  | NotAConstant of label
+  | IncorrectWithConstraint of label
+  | GenerativeModuleExpected of label
+  | NonEmptyLocalContect of label option
+  | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
 
-val error_declaration_not_path : module_struct_entry -> 'a
+val error_existing_label : label -> 'a
 
 val error_application_to_not_path : module_struct_entry -> 'a
 
-val error_not_a_functor :  module_struct_entry -> 'a
-
 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_signature_mismatch :
+  label -> structure_field_body -> signature_mismatch_error -> 'a
 
 val error_incompatible_labels : label -> label -> 'a
 
 val error_no_such_label : label -> 'a
 
-val error_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_modtype_to_end : unit -> 'a
 
-val error_not_a_modtype_loc : loc -> string -> 'a
-
-val error_not_a_module_loc : loc -> string -> 'a
-
-val error_not_a_module_or_modtype_loc : loc -> string -> 'a
-
 val error_not_a_module : string -> 'a
 
 val error_not_a_constant : label -> 'a
 
-val error_with_incorrect : label -> 'a
+val error_incorrect_with_constraint : label -> 'a
 
-val error_a_generative_module_expected : label -> 'a
+val error_generative_module_expected : label -> 'a
 
-val error_local_context : label option -> 'a
+val error_non_empty_local_context : label option -> 'a
 
 val error_no_such_label_sub : label->string->'a
-
-val error_with_in_module : unit -> 'a
-
-val error_application_to_module_type : unit -> 'a
-
diff --git a/kernel/names.ml b/kernel/names.ml
index 642f5562..ae8ad093 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -1,35 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* File created around Apr 1994 for CiC V5.10.5 by Chet Murthy collecting
+   parts of file initial.ml from CoC V4.8, Dec 1988, by Gérard Huet,
+   Thierry Coquand and Christine Paulin *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Extra functions for splitting/generation of identifiers by Hugo Herbelin *)
+(* Restructuration by Jacek Chrzaszcz as part of the implementation of
+   the module system, Aug 2002 *)
+(* Abstraction over the type of constant for module inlining by Claudio
+   Sacerdoti, Nov 2004 *)
+(* Miscellaneous features or improvements by Hugo Herbelin, 
+   Élie Soubiran, ... *)
 
 open Pp
 open Util
 
-(*s Identifiers *)
+(** {6 Identifiers } *)
 
 type identifier = string
 
-let id_ord = Pervasives.compare
-
 let id_of_string s = check_ident_soft s; String.copy s
-
 let string_of_id id = String.copy id
 
-(* Hash-consing of identifier *)
-module Hident = Hashcons.Make(
-  struct
-    type t = string
-    type u = string -> string
-    let hash_sub hstr id = hstr id
-    let equal id1 id2 = id1 == id2
-    let hash = Hashtbl.hash
-  end)
+let id_ord = Pervasives.compare
 
 module IdOrdered =
   struct
@@ -38,15 +37,27 @@ module IdOrdered =
   end
 
 module Idset = Set.Make(IdOrdered)
-module Idmap = Map.Make(IdOrdered)
+module Idmap =
+struct
+  include Map.Make(IdOrdered)
+  exception Finded
+  let exists f m =
+    try iter (fun a b -> if f a b then raise Finded) m ; false
+    with |Finded -> true
+  let singleton k v = add k v empty
+end
 module Idpred = Predicate.Make(IdOrdered)
 
-(* Names *)
+(** {6 Various types based on identifiers } *)
 
 type name = Name of identifier | Anonymous
+type variable = identifier
 
-(* Dirpaths are lists of module identifiers. The actual representation
-   is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
+(** {6 Directory paths = section names paths } *)
+
+(** 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
@@ -58,14 +69,17 @@ let repr_dirpath x = x
 
 let empty_dirpath = []
 
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
+
 let string_of_dirpath = function
   | [] -> "<>"
   | sl -> String.concat "." (List.map string_of_id (List.rev sl))
 
+(** {6 Unique names for bound modules } *)
 
 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)
+type uniq_ident = int * identifier * dir_path
+let make_uid dir s = incr u_number;(!u_number,s,dir)
  let debug_string_of_uid (i,s,p) =
  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
 let string_of_uid (i,s,p) =
@@ -76,30 +90,31 @@ module Umap = Map.Make(struct
 			 let compare = Pervasives.compare
 		       end)
 
-type label = string
-
 type mod_bound_id = uniq_ident
 let make_mbid = make_uid
 let repr_mbid (n, id, dp) = (n, id, dp)
 let debug_string_of_mbid = debug_string_of_uid
 let string_of_mbid = string_of_uid
 let id_of_mbid (_,s,_) = s
-let label_of_mbid (_,s,_) = s
 
+(** {6 Names of structure elements } *)
 
-let mk_label l = l
-let string_of_label = string_of_id
+type label = identifier
 
+let mk_label = id_of_string
+let string_of_label = string_of_id
+let pr_label l = str (string_of_label l)
 let id_of_label l = l
 let label_of_id id = id
 
 module Labset = Idset
 module Labmap = Idmap
 
+(** {6 The module part of the kernel name } *)
+
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
- (* | MPapp of module_path * module_path *)
   | MPdot of module_path * label
 
 let rec check_bound_mp = function
@@ -110,12 +125,9 @@ let rec check_bound_mp = function
 let rec string_of_mp = function
   | MPfile sl -> string_of_dirpath sl
   | MPbound 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 *)
+(** we compare labels first if both are MPdots *)
 let rec mp_ord mp1 mp2 = match (mp1,mp2) with
     MPdot(mp1,l1), MPdot(mp2,l2) ->
       let c = Pervasives.compare l1 l2 in
@@ -133,7 +145,12 @@ end
 module MPset = Set.Make(MPord)
 module MPmap = Map.Make(MPord)
 
-(* Kernel names *)
+let default_module_name = "If you see this, it's a bug"
+
+let initial_dir = make_dirpath [default_module_name]
+let initial_path = MPfile initial_dir
+
+(** {6 Kernel names } *)
 
 type kernel_name = module_path * dir_path * label
 
@@ -147,11 +164,12 @@ let label kn =
   let _,_,l = repr_kn kn in l
 
 let string_of_kn (mp,dir,l) =
-  string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l
+  let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#"
+  in
+  string_of_mp mp ^ str_dir ^ string_of_label l
 
 let pr_kn kn = str (string_of_kn kn)
 
-
 let kn_ord kn1 kn2 =
     let mp1,dir1,l1 = kn1 in
     let mp2,dir2,l2 = kn2 in
@@ -165,87 +183,84 @@ let kn_ord kn1 kn2 =
 	  else
 	    MPord.compare mp1 mp2
 
-(* a constant name is a kernel name couple (kn1,kn2) 
+module KNord = struct
+  type t = kernel_name
+  let compare = kn_ord
+end
+
+module KNmap = Map.Make(KNord)
+module KNpred = Predicate.Make(KNord)
+module KNset = Set.Make(KNord)
+
+(** {6 Constant names } *)
+
+(** a constant name is a kernel name couple (kn1,kn2)
    where kn1 corresponds to the name used at toplevel
-   (i.e. what the user see) 
-   and kn2 corresponds to the canonical kernel name 
-   i.e. in the environment we have 
+   (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*)
+let constant_of_kn kn = (kn,kn)
+let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
+let make_con mp dir l = constant_of_kn (mp,dir,l)
+let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let canonical_con con = snd con
+let user_con con = fst con
+let repr_con con = fst con
+
+let eq_constant (_,kn1) (_,kn2) = kn1=kn2
+
+let con_label con = label (fst con)
+let con_modpath con = modpath (fst con)
+
+let string_of_con con = string_of_kn (fst con)
+let pr_con con = str (string_of_con con)
+let debug_string_of_con con =
+  "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
+let debug_pr_con con = str (debug_string_of_con con)
+
+let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
+  if lbl = l1 && lbl = l2 then con
+  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
+
+(** For the environment we distinguish constants by their user part*)
 module User_ord = struct
   type t = kernel_name*kernel_name
   let compare x y= kn_ord (fst x) (fst y)
 end
 
-(* For other uses (ex: non-logical things) it is enough
-   to deal with the canonical part *)
+(** 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
-  let compare =kn_ord
-end
-
-module KNmap = Map.Make(KNord)
-module KNpred = Predicate.Make(KNord)
-module KNset = Set.Make(KNord)
-
 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_path = MPfile initial_dir
+(** {6 Names of mutual inductive types } *)
 
-type variable = identifier
+(** The same thing is done for mutual inductive names
+    it replaces also the old mind_equiv field of mutual
+    inductive types *)
+(** Beware: first inductive has index 0 *)
+(** Beware: first constructor has index 1 *)
 
-(* 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,kn)
-let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_con mp dir l = constant_of_kn (mp,dir,l)
-let make_con_equiv mp1 mp2 dir l = ((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_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
-  if lbl = l1 && lbl = l2 then con
-  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
-
-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))
@@ -253,12 +268,15 @@ 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 string_of_mind mind = string_of_kn (fst mind)
+let pr_mind mind = str (string_of_mind mind)
+let debug_string_of_mind mind =
+  "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")"
+let debug_pr_mind con = str (debug_string_of_mind con)
 
 let ith_mutual_inductive (kn,_) i = (kn,i)
 let ith_constructor_of_inductive ind i = (ind,i)
@@ -267,6 +285,10 @@ let index_of_constructor (ind,i) = i
 let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
 let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
 
+module Mindmap = Map.Make(Canonical_ord)
+module Mindset = Set.Make(Canonical_ord)
+module Mindmap_env = Map.Make(User_ord)
+
 module InductiveOrdered = struct
   type t = inductive
   let compare (spx,ix) (spy,iy) =
@@ -306,7 +328,8 @@ let eq_egr e1 e2 = match e1,e2 with
     EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
   | _,_ -> e1 = e2
 
-(* Hash-consing of name objects *)
+(** {6 Hash-consing of name objects } *)
+
 module Hname = Hashcons.Make(
   struct
     type t = name
@@ -326,7 +349,7 @@ module Hdir = Hashcons.Make(
   struct
     type t = dir_path
     type u = identifier -> identifier
-    let hash_sub hident d = List.map hident d
+    let hash_sub hident d = list_smartmap hident d
     let rec equal d1 d2 = match (d1,d2) with
       | [],[] -> true
       | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
@@ -337,9 +360,9 @@ module Hdir = Hashcons.Make(
 module Huniqid = Hashcons.Make(
   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)
-    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2
+    type u = (identifier -> identifier) * (dir_path -> dir_path)
+    let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
+    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2
     let hash = Hashtbl.hash
   end)
 
@@ -355,34 +378,66 @@ module Hmod = Hashcons.Make(
     let rec equal d1 d2 = match (d1,d2) with
       | MPfile dir1, MPfile dir2 -> dir1 == dir2
       | MPbound m1, MPbound m2 -> m1 == m2
-      | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
       | _ -> false
     let hash = Hashtbl.hash
   end)
 
-
-module Hcn = Hashcons.Make(
-  struct 
-    type t = kernel_name*kernel_name
+module Hkn = Hashcons.Make(
+  struct
+    type t = kernel_name
     type u = (module_path -> module_path)
 	* (dir_path -> dir_path) * (string -> string)
-    let hash_sub (hmod,hdir,hstr) ((md,dir,l),(mde,dire,le)) = 
-      ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le))
-    let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) =
+    let hash_sub (hmod,hdir,hstr) (md,dir,l) =
+      (hmod md, hdir dir, hstr l)
+    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
       mod1 == mod2 && dir1 == dir2 && l1 == l2
     let hash = Hashtbl.hash
   end)
 
-let hcons_names () =
-  let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in
-  let hident = Hashcons.simple_hcons Hident.f hstring in
-  let hname = Hashcons.simple_hcons Hname.f hident in
-  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 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)
+(** For [constant] and [mutual_inductive], we discriminate only on
+    the user part : having the same user part implies having the
+    same canonical part (invariant of the system). *)
+
+module Hcn = Hashcons.Make(
+  struct
+    type t = kernel_name*kernel_name
+    type u = kernel_name -> kernel_name
+    let hash_sub hkn (user,can) = (hkn user, hkn can)
+    let equal (user1,_) (user2,_) = user1 == user2
+    let hash (user,_) = Hashtbl.hash user
+  end)
+
+module Hind = Hashcons.Make(
+  struct
+    type t = inductive
+    type u = mutual_inductive -> mutual_inductive
+    let hash_sub hmind (mind, i) = (hmind mind, i)
+    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2
+    let hash = Hashtbl.hash
+  end)
+
+module Hconstruct = Hashcons.Make(
+  struct
+    type t = constructor
+    type u = inductive -> inductive
+    let hash_sub hind (ind, j) = (hind ind, j)
+    let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2
+    let hash = Hashtbl.hash
+  end)
+
+let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f ()
+let hcons_ident = hcons_string
+let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident
+let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident
+let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath)
+let hcons_mp =
+  Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string)
+let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string)
+let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind
+let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind
 
 
 (*******)
diff --git a/kernel/names.mli b/kernel/names.mli
index 612851dd..34c5e62c 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -1,62 +1,59 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: names.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s Identifiers *)
+(** {6 Identifiers } *)
 
 type identifier
-type name = Name of identifier | Anonymous
-(* Parsing and printing of identifiers *)
+
+(** Parsing and printing of identifiers *)
 val string_of_id : identifier -> string
 val id_of_string : string -> identifier
 
 val id_ord : identifier -> identifier -> int
 
-(* Identifiers sets and maps *)
+(** Identifiers sets and maps *)
 module Idset  : Set.S with type elt = identifier
 module Idpred : Predicate.S with type elt = identifier
-module Idmap  : Map.S with type key = identifier
+module Idmap  : sig
+  include Map.S with type key = identifier
+  val exists : (identifier -> 'a -> bool) -> 'a t -> bool
+  val singleton : key -> 'a -> 'a t
+end
+
+(** {6 Various types based on identifiers } *)
+
+type name = Name of identifier | Anonymous
+type variable = identifier
+
+(** {6 Directory paths = section names paths } *)
 
-(*s Directory paths = section names paths *)
 type module_ident = identifier
 module ModIdmap : Map.S with type key = module_ident
 
 type dir_path
 
-(* Inner modules idents on top of list (to improve sharing).
+(** Inner modules idents on top of list (to improve sharing).
    For instance: A.B.C is ["C";"B";"A"] *)
 val make_dirpath : module_ident list -> dir_path
 val repr_dirpath : dir_path -> module_ident list
 
 val empty_dirpath : dir_path
 
-(* Printing of directory paths as ["coq_root.module.submodule"] *)
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
 val string_of_dirpath : dir_path -> 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
-val label_of_mbid : mod_bound_id -> label
-val debug_string_of_mbid : mod_bound_id -> string
-val string_of_mbid : mod_bound_id -> string
+(** {6 Names of structure elements } *)
 
-(*s Names of structure elements *)
+type label
 
 val mk_label : string -> label
 val string_of_label : label -> string
+val pr_label : label -> Pp.std_ppcmds
 
 val label_of_id : identifier -> label
 val id_of_label : label -> identifier
@@ -64,14 +61,26 @@ val id_of_label : label -> identifier
 module Labset : Set.S with type elt = label
 module Labmap : Map.S with type key = label
 
-(*s The module part of the kernel name *)
+(** {6 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 -> identifier -> mod_bound_id
+val repr_mbid : mod_bound_id -> int * identifier * dir_path
+val id_of_mbid : mod_bound_id -> identifier
+val debug_string_of_mbid : mod_bound_id -> string
+val string_of_mbid : mod_bound_id -> string
+
+(** {6 The module part of the kernel name } *)
+
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
- (* | MPapp of module_path * module_path  very soon *)
   | MPdot of module_path * label
 
-
 val check_bound_mp : module_path -> bool
 
 val string_of_mp : module_path -> string
@@ -79,17 +88,17 @@ 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
 
-(* Initial "seed" of the unique identifier generator *)
+(** 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] *)
+(** Name of the toplevel structure *)
+val initial_path : module_path (** [= MPfile initial_dir] *)
 
-(*s The absolute names of objects seen by kernel *)
+(** {6 The absolute names of objects seen by kernel } *)
 
 type kernel_name
 
-(* Constructor and destructor *)
+(** Constructor and destructor *)
 val make_kn : module_path -> dir_path -> label -> kernel_name
 val repr_kn : kernel_name -> module_path * dir_path * label
 
@@ -99,23 +108,25 @@ val label : kernel_name -> label
 val string_of_kn : kernel_name -> string
 val pr_kn : kernel_name -> Pp.std_ppcmds
 
+val kn_ord : kernel_name -> kernel_name -> int
 
 module KNset  : Set.S with type elt = kernel_name
 module KNpred : Predicate.S with type elt = kernel_name
 module KNmap  : Map.S with type key = kernel_name
 
 
-(*s Specific paths for declarations *)
+(** {6 Specific paths for declarations } *)
 
-type variable = identifier
 type constant
 type mutual_inductive
-(* Beware: first inductive has index 0 *)
+
+(** Beware: first inductive has index 0 *)
 type inductive = mutual_inductive * int
-(* Beware: first constructor has index 1 *)
+
+(** Beware: first constructor has index 1 *)
 type constructor = inductive * int
 
-(* *_env modules consider an order on user part of names
+(** *_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
@@ -169,7 +180,6 @@ val debug_string_of_mind : mutual_inductive -> string
 
 
 
-val mind_modpath : mutual_inductive -> module_path
 val ind_modpath : inductive -> module_path
 val constr_modpath : constructor -> module_path
 
@@ -180,7 +190,7 @@ 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 *)
+(** Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
   | EvalConstRef of constant
@@ -188,12 +198,16 @@ type evaluable_global_reference =
 val eq_egr : evaluable_global_reference ->  evaluable_global_reference
   -> bool
 
-(* Hash-consing *)
-val hcons_names : unit ->
-  (constant -> constant) *
-  (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) *
-  (name -> name) * (identifier -> identifier) * (string -> string)
+(** {6 Hash-consing } *)
 
+val hcons_string : string -> string
+val hcons_ident : identifier -> identifier
+val hcons_name : name -> name
+val hcons_dirpath : dir_path -> dir_path
+val hcons_con : constant -> constant
+val hcons_mind : mutual_inductive -> mutual_inductive
+val hcons_ind : inductive -> inductive
+val hcons_construct : constructor -> constructor
 
 (******)
 
@@ -209,8 +223,8 @@ val full_transparent_state : transparent_state
 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}
+type inv_rel_key = int (** index in the [rel_context] part of environment
+			  starting by the end, {e inverse}
 			  of de Bruijn indice *)
 
 type id_key = inv_rel_key tableKey
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index c852ab72..985aac95 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Benjamin Grégoire out of environ.ml for better
+   modularity in the design of the bytecode virtual evaluation
+   machine, Dec 2005 *)
+(* Bug fix by Jean-Marc Notin *)
+
+(* This file defines the type of kernel environments *)
 
 open Util
 open Names
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 70776551..40ce887b 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Sign
@@ -15,7 +13,7 @@ open Univ
 open Term
 open Declarations
 
-(* The type of environments. *)
+(** The type of environments. *)
 
 
 type key = int option ref
@@ -57,25 +55,27 @@ val empty_named_context_val : named_context_val
 
 val empty_env : env
 
-(* Rel context *)
+(** Rel context *)
 
 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
-(* Named context *)
+
+(** Named context *)
 
 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
-(* Global constants *)
+
+(** Global constants *)
 
 
 val lookup_constant_key : constant -> env -> constant_key
 val lookup_constant : constant -> env -> constant_body
 
-(* Mutual Inductives *)
+(** Mutual Inductives *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 38d1c70b..fc5e32cf 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -1,12 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created under Benjamin Werner account by Bruno Barras to implement
+   a call-by-value conversion algorithm and a lazy reduction machine
+   with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Irreversibility of opacity by Bruno Barras *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Equal inductive types by Jacek Chrzaszcz as part of the module
+   system, Aug 2002 *)
 
 open Util
 open Names
@@ -190,9 +197,9 @@ let sort_cmp pb s0 s1 cuniv =
     | (_, _) -> raise NotConvertible
 
 
-let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
+let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint
 
-let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
+let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint
 
 let rec no_arg_available = function
   | [] -> true
@@ -232,14 +239,14 @@ 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 =
-  eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
+let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv =
+  eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
-and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
+and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
   Util.check_for_interrupt ();
   (* First head reduce both terms *)
-  let rec  whd_both (t1,stk1) (t2,stk2) =
+  let rec whd_both (t1,stk1) (t2,stk2) =
     let st1' = whd_stack (snd infos) t1 stk1 in
     let st2' = whd_stack (snd infos) t2 stk2 in
     (* Now, whd_stack on term2 might have modified st1 (due to sharing),
@@ -260,13 +267,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
 	       sort_cmp cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
                if n=m
-	       then convert_stacks infos lft1 lft2 v1 v2 cuniv
+	       then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
                else raise NotConvertible
 	   | _ -> raise NotConvertible)
     | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) ->
         if ev1=ev2 then
-          let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in
-          convert_vect infos el1 el2
+          let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
+          convert_vect l2r infos el1 el2
             (Array.map (mk_clos env1) args1)
             (Array.map (mk_clos env2) args2) u1
         else raise NotConvertible
@@ -274,19 +281,19 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* 2 index known to be bound to no constant *)
     | (FRel n, FRel m) ->
         if reloc_rel n el1 = reloc_rel m el2
-        then convert_stacks infos lft1 lft2 v1 v2 cuniv
+        then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
         else raise NotConvertible
 
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
 	(try (* try first intensional equality *)
 	  if eq_table_key fl1 fl2
-          then convert_stacks infos lft1 lft2 v1 v2 cuniv
+          then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
           else raise NotConvertible
         with NotConvertible ->
           (* else the oracle tells which constant is to be expanded *)
           let (app1,app2) =
-            if Conv_oracle.oracle_order fl1 fl2 then
+            if Conv_oracle.oracle_order l2r fl1 fl2 then
               match unfold_reference infos fl1 with
                 | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
                 | None ->
@@ -300,79 +307,95 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
                     (match unfold_reference infos fl1 with
                     | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
 		    | None -> raise NotConvertible) in
-          eqappr cv_pb infos app1 app2 cuniv)
-
-    (* only one constant, defined var or defined rel *)
-    | (FFlex fl1, _)      ->
-        (match unfold_reference infos fl1 with
-           | Some def1 ->
-	       eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
-           | None -> raise NotConvertible)
-    | (_, FFlex fl2)      ->
-        (match unfold_reference infos fl2 with
-           | Some def2 ->
-	       eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
-           | None -> raise NotConvertible)
+          eqappr cv_pb l2r infos app1 app2 cuniv)
 
     (* other constructors *)
     | (FLambda _, FLambda _) ->
+        (* Inconsistency: we tolerate that v1, v2 contain shift and update but
+           we throw them away *)
         if not (is_empty_stack v1 && is_empty_stack v2) then
 	  anomaly "conversion was given ill-typed terms (FLambda)";
         let (_,ty1,bd1) = destFLambda mk_clos hd1 in
         let (_,ty2,bd2) = destFLambda mk_clos hd2 in
-        let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
-        ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+        let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1
 
     | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
         if not (is_empty_stack v1 && is_empty_stack v2) then
 	  anomaly "conversion was given ill-typed terms (FProd)";
 	(* Luo's system *)
-        let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
-        ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
+        let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1
+
+    (* Eta-expansion on the fly *)
+    | (FLambda _, _) ->
+        if v1 <> [] then
+	  anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
+	eqappr CONV l2r infos
+	  (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv
+    | (_, FLambda _) ->
+        if v2 <> [] then
+	  anomaly "conversion was given unreduced term (FLambda)";
+        let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
+	eqappr CONV l2r infos
+	  (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 ->
+	       eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 ->
+	       eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
+           | None -> raise NotConvertible)
 
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
-     | (FInd ind1, FInd 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 && eq_ind ind1 ind2
-	 then
-           convert_stacks infos lft1 lft2 v1 v2 cuniv
-         else raise NotConvertible
-
-     | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
-	 if op1 = op2
-	 then
-	   let n = Array.length cl1 in
-           let fty1 = Array.map (mk_clos e1) tys1 in
-           let fty2 = Array.map (mk_clos e2) tys2 in
-           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
-           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-	   let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
-           let u2 =
-             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
-
-     | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
-         if op1 = op2
-         then
-	   let n = Array.length cl1 in
-           let fty1 = Array.map (mk_clos e1) tys1 in
-           let fty2 = Array.map (mk_clos e2) tys2 in
-           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
-           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-           let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
-           let u2 =
-	     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
+    | (FInd ind1, FInd ind2) ->
+        if eq_ind ind1 ind2
+	then
+          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+        else raise NotConvertible
+
+    | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
+	if j1 = j2 && eq_ind ind1 ind2
+	then
+          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+        else raise NotConvertible
+
+    | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
+	if op1 = op2
+	then
+	  let n = Array.length cl1 in
+          let fty1 = Array.map (mk_clos e1) tys1 in
+          let fty2 = Array.map (mk_clos e2) tys2 in
+          let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+          let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+	  let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let u2 =
+            convert_vect l2r infos
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+        else raise NotConvertible
+
+    | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
+        if op1 = op2
+        then
+	  let n = Array.length cl1 in
+          let fty1 = Array.map (mk_clos e1) tys1 in
+          let fty2 = Array.map (mk_clos e2) tys2 in
+          let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+          let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+          let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let u2 =
+	    convert_vect l2r infos
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+        else raise NotConvertible
 
      (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
      | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
@@ -382,13 +405,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
      (* In all other cases, terms are not convertible *)
      | _ -> raise NotConvertible
 
-and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
+and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
-    (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
+    (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c)
     (eq_ind)
     lft1 stk1 lft2 stk2 cuniv
 
-and convert_vect infos lft1 lft2 v1 v2 cuniv =
+and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
   let lv1 = Array.length v1 in
   let lv2 = Array.length v2 in
   if lv1 = lv2
@@ -396,62 +419,62 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv =
     let rec fold n univ =
       if n >= lv1 then univ
       else
-        let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
+        let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in
         fold (n+1) u1 in
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv trans cv_pb evars env t1 t2 =
+let clos_fconv trans cv_pb l2r evars env t1 t2 =
   let infos = trans, create_clos_infos ~evars betaiotazeta env in
-  ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
+  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint
 
-let trans_fconv reds cv_pb evars env t1 t2 =
-  if eq_constr t1 t2 then Constraint.empty
-  else clos_fconv reds cv_pb evars env t1 t2
+let trans_fconv reds cv_pb l2r evars env t1 t2 =
+  if eq_constr t1 t2 then empty_constraint
+  else clos_fconv reds cv_pb l2r evars env t1 t2
 
-let trans_conv_cmp conv reds = trans_fconv reds conv (fun _->None)
-let trans_conv ?(evars=fun _->None) reds = trans_fconv reds CONV evars
-let trans_conv_leq ?(evars=fun _->None) reds = trans_fconv reds CUMUL evars
+let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None)
+let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars
+let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars
 
 let fconv = trans_fconv (Idpred.full, Cpred.full)
 
-let conv_cmp cv_pb = fconv cv_pb (fun _->None)
-let conv ?(evars=fun _->None) = fconv CONV evars
-let conv_leq ?(evars=fun _->None) = fconv CUMUL evars
+let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None)
+let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars
+let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars
 
-let conv_leq_vecti ?(evars=fun _->None) env v1 v2 =
+let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
   array_fold_left2_i
     (fun i c t1 t2 ->
       let c' =
-        try conv_leq ~evars env t1 t2
+        try conv_leq ~l2r ~evars env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
-      Constraint.union c c')
-    Constraint.empty
+      union_constraints c c')
+    empty_constraint
     v1
     v2
 
 (* option for conversion *)
 
-let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
 let set_vm_conv f = vm_conv := f
 let vm_conv cv_pb env t1 t2 =
   try
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
-      fconv cv_pb (fun _->None) env t1 t2
+      fconv cv_pb false (fun _->None) env t1 t2
 
 
-let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None))
 
 let set_default_conv f = default_conv := f
 
-let default_conv cv_pb env t1 t2 =
+let default_conv cv_pb ?(l2r=false) env t1 t2 =
   try
-    !default_conv cv_pb env t1 t2
+    !default_conv ~l2r 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
+      fconv cv_pb false (fun _->None) env t1 t2
 
 let default_conv_leq = default_conv CUMUL
 (*
@@ -511,15 +534,16 @@ let dest_prod_assum env =
   in
   prodec_rec env empty_rel_context
 
+exception NotArity
+
 let dest_arity env c =
   let l, c = dest_prod_assum env c in
   match kind_of_term c with
     | Sort s -> l,s
-    | _ -> error "not an arity"
+    | _ -> raise NotArity
 
 let is_arity env c =
   try
     let _ = dest_arity env c in
     true
-  with UserError _ -> false
-
+  with NotArity -> false
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 4a3e4cd5..aa78fbda 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Environ
 open Closure
-(*i*)
 
-(************************************************************************)
-(*s Reduction functions *)
+(***********************************************************************
+  s Reduction functions *)
 
 val whd_betaiotazeta        : constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
@@ -24,8 +20,8 @@ val whd_betadeltaiota_nolet : env -> constr -> constr
 val whd_betaiota      : constr -> constr
 val nf_betaiota      : constr -> constr
 
-(************************************************************************)
-(*s conversion functions *)
+(***********************************************************************
+  s conversion functions *)
 
 exception NotConvertible
 exception NotConvertibleVect of int
@@ -40,45 +36,47 @@ val sort_cmp :
 val conv_sort      : sorts conversion_function
 val conv_sort_leq  : sorts conversion_function
 
-val trans_conv_cmp       : conv_pb -> constr trans_conversion_function
+val trans_conv_cmp       : ?l2r:bool -> conv_pb -> constr trans_conversion_function
 val trans_conv           :
-  ?evars:(existential->constr option) -> constr trans_conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function
 val trans_conv_leq       :
-  ?evars:(existential->constr option) -> types trans_conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
 
-val conv_cmp       : conv_pb -> constr conversion_function
+val conv_cmp       : ?l2r:bool -> conv_pb -> constr conversion_function
 val conv           :
-  ?evars:(existential->constr option) -> constr conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
 val conv_leq       :
-  ?evars:(existential->constr option) -> types conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function
 val conv_leq_vecti :
-  ?evars:(existential->constr option) -> types array conversion_function
+  ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
 
-(* option for conversion *)
+(** option for conversion *)
 val set_vm_conv : (conv_pb -> types conversion_function) -> unit
 val vm_conv : conv_pb -> types conversion_function
 
-val set_default_conv : (conv_pb -> types conversion_function) -> unit
-val default_conv     : conv_pb -> types conversion_function
-val default_conv_leq : types conversion_function
+val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit
+val default_conv     : conv_pb -> ?l2r:bool -> types conversion_function
+val default_conv_leq : ?l2r:bool -> types conversion_function
 
 (************************************************************************)
 
-(* 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. *)
+(** 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] *)
+(** Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
 val hnf_prod_applist : env -> types -> constr list -> types
 
 
-(************************************************************************)
-(*s Recognizing products and arities modulo reduction *)
+(***********************************************************************
+  s Recognizing products and arities modulo reduction *)
 
 val dest_prod       : env -> types -> rel_context * types
 val dest_prod_assum : env -> types -> rel_context * types
 
-val dest_arity : env -> types -> arity
+exception NotArity
+
+val dest_arity : env -> types -> arity (* raises NotArity if not an arity *)
 val is_arity   : env -> types -> bool
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index 5e8dd9f8..10d0bae7 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retroknowledge.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Arnaud Spiwack, May 2007 *)
+(* Addition of native Head (nb of heading 0) and Tail (nb of trailing 0) by
+   Benjamin Grégoire, Jun 2007 *)
+
+(* This file defines the knowledge that the kernel is able to optimize
+   for evaluation in the bytecode virtual machine *)
 
 open Term
 open Names
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 6cf871d3..b9793f6d 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retroknowledge.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
-(*i*)
 
 type retroknowledge
 
-(* aliased type for clarity purpose*)
+(** aliased type for clarity purpose*)
 type entry =  (constr, types) kind_of_term
 
-(* the following types correspond to the different "things"
+(** the following types correspond to the different "things"
    the kernel can learn about.*)
 type nat_field =
   | NatType
@@ -58,25 +54,26 @@ type int31_field =
   | Int31Tail0
 
 type field =
-(*  | KEq
+
+(**  | KEq
   | KNat of nat_field
   | KN of n_field *)
   | KInt31 of string*int31_field
 
 
-(* This type represent an atomic action of the retroknowledge. It
-   is stored in the compiled libraries *)
-(* As per now, there is only the possibility of registering things
+(** This type represent an atomic action of the retroknowledge. It
+   is stored in the compiled libraries 
+   As per now, there is only the possibility of registering things
    the possibility of unregistering or changing the flag is under study *)
 type action =
     | RKRegister of field*entry
 
 
-(* initial value for retroknowledge *)
+(** initial value for retroknowledge *)
 val initial_retroknowledge : retroknowledge
 
 
-(* Given an identifier id (usually Const _)
+(** Given an identifier id (usually Const _)
    and the continuation cont of the bytecode compilation
    returns the compilation of id in cont if it has a specific treatment
    or raises Not_found if id should be compiled as usual *)
@@ -103,28 +100,29 @@ 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
+
+(** 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
+(** 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
 
 
-(* the following functions are solely used in Pre_env and Environ to implement
+(** the following functions are solely used in Pre_env and Environ to implement
    the functions  register and unregister (and mem) of Environ *)
 val add_field : retroknowledge -> field -> entry -> retroknowledge
 val mem : retroknowledge -> field -> bool
 val remove : retroknowledge -> field -> retroknowledge
 val find : retroknowledge -> field -> entry
 
-(* the following function manipulate the reactive information of values
+(** 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 ->
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 4575d5bc..c2d71ebb 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -1,12 +1,61 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre as part of the rebuilding of
+   Coq around a purely functional abstract type-checker, Dec 1999 *)
+
+(* This file provides the entry points to the kernel type-checker. It
+   defines the abstract type of well-formed environments and
+   implements the rules that build well-formed environments.
+
+   An environment is made of constants and inductive types (E), of
+   section declarations (Delta), of local bound-by-index declarations
+   (Gamma) and of universe constraints (C). Below E[Delta,Gamma] |-_C
+   means that the tuple E, Delta, Gamma, C is a well-formed
+   environment. Main rules are:
+
+   empty_environment:
+
+     ------
+     [,] |-
+
+   push_named_assum(a,T):
+   
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E[Delta,Gamma,a:T] |-_G'
+
+   push_named_def(a,t,T):
+   
+     E[Delta,Gamma] |-_G
+     ---------------------------
+     E[Delta,Gamma,a:=t:T] |-_G'
+
+   add_constant(ConstantEntry(DefinitionEntry(c,t,T))):
+
+     E[Delta,Gamma] |-_G
+     ---------------------------
+     E,c:=t:T[Delta,Gamma] |-_G'
+
+   add_constant(ConstantEntry(ParameterEntry(c,T))):
+
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E,c:T[Delta,Gamma] |-_G'
+
+   add_mind(Ind(Ind[Gamma_p](Gamma_I:=Gamma_C))):
+
+     E[Delta,Gamma] |-_G
+     ------------------------
+     E,Ind[Gamma_p](Gamma_I:=Gamma_C)[Delta,Gamma] |-_G'
+
+   etc.
+*)
 
 open Util
 open Names
@@ -41,25 +90,6 @@ type module_info =
      resolver : delta_resolver;
      resolver_of_param : delta_resolver;}
 
-let check_label l labset =
-  if Labset.mem l labset then error_existing_label l
-
-let check_labels ls senv =
-  Labset.iter (fun l -> check_label l senv) ls
-
-let labels_of_mib mib =
-  let add,get =
-    let labels = ref Labset.empty in
-    (fun id -> labels := Labset.add (label_of_id id) !labels),
-    (fun () -> !labels)
-  in
-  let visit_mip mip =
-    add mip.mind_typename;
-    Array.iter add mip.mind_consnames
-  in
-  Array.iter visit_mip mib.mind_packets;
-  get ()
-
 let set_engagement_opt oeng env =
   match oeng with
       Some eng -> set_engagement eng env
@@ -79,16 +109,26 @@ type safe_environment =
       loads : (module_path * module_body) list;
       local_retroknowledge : Retroknowledge.action list}
 
-(*
-  { old = senv.old;
-    env = ;
-    modinfo = senv.modinfo;
-    labset = ;
-    revsign = ;
-    imports = senv.imports ;
-    loads = senv.loads }
-*)
+let exists_label l senv = Labset.mem l senv.labset
+
+let check_label l senv =
+  if exists_label l senv then error_existing_label l
 
+let check_labels ls senv =
+  Labset.iter (fun l -> check_label l senv) ls
+
+let labels_of_mib mib =
+  let add,get =
+    let labels = ref Labset.empty in
+    (fun id -> labels := Labset.add (label_of_id id) !labels),
+    (fun () -> !labels)
+  in
+  let visit_mip mip =
+    add mip.mind_typename;
+    Array.iter add mip.mind_consnames
+  in
+  Array.iter visit_mip mib.mind_packets;
+  get ()
 
 (* a small hack to avoid variants and an unused case in all functions *)
 let rec empty_environment =
@@ -102,7 +142,7 @@ let rec empty_environment =
       resolver_of_param = empty_delta_resolver};
     labset = Labset.empty;
     revstruct = [];
-    univ = Univ.Constraint.empty;
+    univ = Univ.empty_constraint;
     engagement = None;
     imports = [];
     loads = [];
@@ -111,16 +151,50 @@ let rec empty_environment =
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
 
-
-
-
-
-
-
 let add_constraints cst senv =
-  {senv with
+  { senv with
     env = Environ.add_constraints cst senv.env;
-    univ = Univ.Constraint.union cst senv.univ }
+    univ = Univ.union_constraints cst senv.univ }
+
+let constraints_of_sfb = function
+  | SFBconst cb -> cb.const_constraints
+  | SFBmind mib -> mib.mind_constraints
+  | SFBmodtype mtb -> mtb.typ_constraints
+  | SFBmodule mb -> mb.mod_constraints
+
+(* A generic function for adding a new field in a same environment.
+   It also performs the corresponding [add_constraints]. *)
+
+type generic_name =
+  | C of constant
+  | I of mutual_inductive
+  | MT of module_path
+  | M
+
+let add_field ((l,sfb) as field) gn senv =
+  let labels = match sfb with
+    | SFBmind mib -> labels_of_mib mib
+    | _ -> Labset.singleton l
+  in
+  check_labels labels senv;
+  let senv = add_constraints (constraints_of_sfb sfb) senv in
+  let env' = match sfb, gn with
+    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+    | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
+    | SFBmodule mb, M -> Modops.add_module mb senv.env
+    | _ -> assert false
+  in
+  { senv with
+    env = env';
+    labset = Labset.union labels senv.labset;
+    revstruct = field :: senv.revstruct }
+
+(* Applying a certain function to the resolver of a safe environment *)
+
+let update_resolver f senv =
+  let mi = senv.modinfo in
+  { senv with modinfo = { mi with resolver = f mi.resolver }}
 
 
 (* universal lifting, used for the "get" operations mostly *)
@@ -131,8 +205,9 @@ 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 =
+  {senv with
+    env = Environ.register senv.env field value;
+    local_retroknowledge =
       Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
   }
 
@@ -185,52 +260,21 @@ type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
 
-let hcons_constant_type = function
-  | NonPolymorphicType t ->
-      NonPolymorphicType (hcons1_constr t)
-  | PolymorphicArity (ctx,s) ->
-      PolymorphicArity (map_rel_context hcons1_constr ctx,s)
-
-let hcons_constant_body cb =
-  let body = match cb.const_body with
-      None -> None
-    | Some l_constr -> let constr = Declarations.force l_constr in
-	Some (Declarations.from_val (hcons1_constr constr))
-  in
-    { cb with
-	const_body = body;
-	const_type = hcons_constant_type cb.const_type }
-
 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
-      | ConstantEntry ce -> translate_constant senv.env kn ce
-      | GlobalRecipe r ->
-	  let cb = translate_recipe senv.env kn r in
-	    if dir = empty_dirpath then hcons_constant_body cb else cb
+  let cb = match decl with
+    | ConstantEntry ce -> translate_constant senv.env kn ce
+    | GlobalRecipe r ->
+      let cb = translate_recipe senv.env kn r in
+      if dir = empty_dirpath then hcons_const_body cb else cb
   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
+  let senv' = add_field (l,SFBconst cb) (C kn) senv in
+  let senv'' = match cb.const_body with
+    | Undef (Some lev) ->
+      update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv'
+    | _ -> senv'
   in
-    kn, { old = senv'.old;
-	  env = env'';
-	  modinfo = {senv'.modinfo with
-		       resolver = resolver};
-	  labset = Labset.add l senv'.labset;
-	  revstruct = (l,SFBconst cb)::senv'.revstruct;
-          univ = senv'.univ;
-          engagement = senv'.engagement;
-	  imports = senv'.imports;
-	  loads = senv'.loads ;
-	  local_retroknowledge = senv'.local_retroknowledge }
-
+  kn, senv''
 
 (* Insertion of inductive types. *)
 
@@ -242,79 +286,41 @@ let add_mind dir l mie senv =
   if l <> label_of_id id then
     anomaly ("the label of inductive packet and its first inductive"^
 	     " type do not match");
-  let mib = translate_mind senv.env mie in
-  let labels = labels_of_mib mib in
-  check_labels labels senv.labset;
-  let senv' = add_constraints mib.mind_constraints senv 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'';
-	modinfo = senv'.modinfo;
-	labset = Labset.union labels 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 }
+  let mib = translate_mind senv.env kn mie in
+  let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in
+  let senv' = add_field (l,SFBmind mib) (I kn) senv in
+  kn, senv'
 
 (* Insertion of module types *)
 
 let add_modtype l mte inl senv =
-  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
   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 }
-
+  let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in
+  mp, senv'
 
 (* full_add_module adds module with universes and constraints *)
 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}
+  { senv with env = Modops.add_module mb senv.env }
 
 (* Insertion of modules *)
 
 let add_module l me inl senv =
-  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
   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
+  let senv' = add_field (l,SFBmodule mb) M senv in
+  let senv'' = match mb.mod_type with
+    | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv'
+    | _ -> senv'
   in
-    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 }
-    
+  mp,mb.mod_delta,senv''
+
 (* Interactive modules *)
 
 let start_module l senv =
-  check_label l senv.labset;
+  check_label l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -327,7 +333,7 @@ let start_module l senv =
 	 modinfo = modinfo;
 	 labset = Labset.empty;
 	 revstruct = [];
-         univ = Univ.Constraint.empty;
+         univ = Univ.empty_constraint;
          engagement = None;
 	 imports = senv.imports;
 	 loads = [];
@@ -347,7 +353,7 @@ let end_module l restype senv =
       | 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;
+  if not (empty_context senv.env) then error_non_empty_local_context None;
   let functorize_struct tb =
     List.fold_left
       (fun mtb (arg_id,arg_b) ->
@@ -361,13 +367,13 @@ let end_module l restype senv =
    let mexpr,mod_typ,mod_typ_alg,resolver,cst = 
     match restype with
       | None ->  let mexpr = functorize_struct auto_tb in
-	 mexpr,mexpr,None,modinfo.resolver,Constraint.empty
+	 mexpr,mexpr,None,modinfo.resolver,empty_constraint
       | Some mtb ->
 	  let auto_mtb = {
 	    typ_mp = senv.modinfo.modpath;
 	    typ_expr = auto_tb;
 	    typ_expr_alg = None;
-	    typ_constraints = Constraint.empty;
+	    typ_constraints = empty_constraint;
 	    typ_delta = empty_delta_resolver} in
 	  let cst = check_subtypes senv.env auto_mtb
 	    mtb in
@@ -377,7 +383,7 @@ let end_module l restype senv =
 	    Option.map functorize_struct mtb.typ_expr_alg in
 	    mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
   in
-  let cst = Constraint.union cst senv.univ in
+  let cst = union_constraints cst senv.univ in
   let mb =
     { mod_mp = mp;
       mod_expr = Some mexpr;
@@ -411,12 +417,12 @@ let end_module l restype senv =
 		  modinfo = modinfo;
 		  labset = Labset.add l oldsenv.labset;
 		  revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
-		  univ = Univ.Constraint.union senv'.univ oldsenv.univ;
+		  univ = Univ.union_constraints senv'.univ oldsenv.univ;
 		  (* engagement is propagated to the upper level *)
 		  engagement = senv'.engagement;
 		  imports = senv'.imports;
 		  loads = senv'.loads@oldsenv.loads;
-		  local_retroknowledge = 
+		  local_retroknowledge =
 	senv'.local_retroknowledge@oldsenv.local_retroknowledge }
 
 
@@ -424,8 +430,8 @@ let end_module l restype senv =
  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 
+       let sign,_,resolver,cst =
+	 translate_struct_include_module_entry senv.env
 	   senv.modinfo.modpath inl me in
 	 sign,cst,resolver
      else
@@ -437,106 +443,46 @@ let end_module l restype senv =
    let senv = add_constraints cst senv in
    let mp_sup = senv.modinfo.modpath in
      (* Include Self support  *)
-  let rec compute_sign sign mb resolver senv = 
+   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
+	 let mpsup_delta =
+	   inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta
 	 in
 	 let subst = map_mbid mbid mp_sup mpsup_delta in
 	 let resolver = subst_codom_delta_resolver subst resolver in
 	   (compute_sign 
-	      (subst_struct_expr subst str) mb resolver senv)
+	     (subst_struct_expr subst str) mb resolver senv)
      | str -> resolver,str,senv
-  in
+   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
+				      typ_constraints = empty_constraint;
+				      typ_delta = senv.modinfo.resolver} resolver senv
+   in
    let str = match sign with
      | SEBstruct(str_l) -> str_l
      | _ -> error ("You cannot Include a high-order structure.")
    in
-   let senv =
-     {senv 
-      with modinfo = 
-	 {senv.modinfo
-	  with resolver =
-	     add_delta_resolver resolver senv.modinfo.resolver}}
+   let senv = update_resolver (add_delta_resolver resolver) senv
    in
-   let add senv (l,elem)  =
-     check_label l senv.labset;
-     match elem with
-       | SFBconst cb ->
+   let add senv ((l,elem) as field) =
+     let new_name = match elem with
+       | SFBconst _ ->
 	   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;
-	       env = env'';
-	       modinfo = senv'.modinfo;
-	       labset = Labset.add l senv'.labset;
-	       revstruct = (l,SFBconst cb)::senv'.revstruct;
-               univ = senv'.univ;
-               engagement = senv'.engagement;
-	       imports = senv'.imports;
-	       loads = senv'.loads ;
-	       local_retroknowledge = senv'.local_retroknowledge }
-       | SFBmind mib ->
+	   C (constant_of_delta_kn resolver kn)
+       | SFBmind _ ->
 	   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 labels = labels_of_mib mib in
-	   check_labels labels senv.labset;
-	   let senv' = add_constraints mib.mind_constraints senv in
-	   let env'' = Environ.add_mind mind mib senv'.env in
-	     { old = senv'.old;
-	       env = env'';
-	       modinfo = senv'.modinfo;
-	       labset = Labset.union labels 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 senv' = full_add_module mb senv in
-	     { old = senv'.old;
-	       env = senv'.env;
-	       modinfo = senv'.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 }
-       | SFBmodtype mtb ->
-	   let senv' = add_constraints mtb.typ_constraints senv in
-	   let mp = MPdot(senv.modinfo.modpath, l) in
-	   let env' = Environ.add_modtype mp mtb senv'.env in
-	     { 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 }
+	   I (mind_of_delta_kn resolver kn)
+       | SFBmodule _ -> M
+       | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l))
+     in
+     add_field field new_name senv
    in
-     resolver,(List.fold_left add senv str)
+   resolver,(List.fold_left add senv str)
 
 (* Adding parameters to modules or module types *)
 
@@ -576,7 +522,7 @@ let add_module_parameter mbid mte inl senv =
 (* Interactive module types *)
 
 let start_modtype l senv =
-  check_label l senv.labset;
+  check_label l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -589,7 +535,7 @@ let start_modtype l senv =
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [] ;
@@ -605,7 +551,7 @@ let end_modtype l senv =
       | 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;
+  if not (empty_context senv.env) then error_non_empty_local_context None;
   let auto_tb =
      SEBstruct (List.rev senv.revstruct)
   in
@@ -640,7 +586,7 @@ let end_modtype l senv =
 	  modinfo = oldsenv.modinfo;
 	  labset = Labset.add l oldsenv.labset;
 	  revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
-          univ = Univ.Constraint.union senv.univ oldsenv.univ;
+          univ = Univ.union_constraints senv.univ oldsenv.univ;
           engagement = senv.engagement;
 	  imports = senv.imports;
 	  loads = senv.loads@oldsenv.loads;
@@ -699,7 +645,7 @@ let start_library dir senv =
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [];
@@ -710,7 +656,7 @@ let pack_module senv =
    mod_expr=None;
    mod_type= SEBstruct (List.rev senv.revstruct);
    mod_type_alg=None;
-   mod_constraints=Constraint.empty;
+   mod_constraints=empty_constraint;
    mod_delta=senv.modinfo.resolver;
    mod_retroknowledge=[];
   }
@@ -786,40 +732,146 @@ let import (dp,mb,depends,engmt) digest senv =
 	  loads = (mp,mb)::senv.loads }
 
 
-(* Remove the body of opaque constants in modules *)
- let rec lighten_module mb =
-  { mb with
-    mod_expr = None;
-    mod_type = lighten_modexpr mb.mod_type;
-  }
-
-and lighten_struct struc =
-  let lighten_body (l,body) = (l,match body with
-    | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
-    | (SFBconst _ | SFBmind _ ) as x -> x
-    | SFBmodule m -> SFBmodule (lighten_module m)
-    | SFBmodtype m -> SFBmodtype
-	({m with
-	    typ_expr = lighten_modexpr m.typ_expr}))
-  in
-    List.map lighten_body struc
-
-and lighten_modexpr = function
-  | SEBfunctor (mbid,mty,mexpr) ->
-      SEBfunctor (mbid,
+ (* Store the body of modules' opaque constants inside a table.  
+
+    This module is used during the serialization and deserialization
+    of vo files. 
+
+    By adding an indirection to the opaque constant definitions, we
+    gain the ability not to load them. As these constant definitions
+    are usually big terms, we save a deserialization time as well as
+    some memory space. *)
+module LightenLibrary : sig
+  type table 
+  type lightened_compiled_library 
+  val save : compiled_library -> lightened_compiled_library * table
+  val load : load_proof:Flags.load_proofs -> table Lazy.t
+    -> lightened_compiled_library -> compiled_library
+end = struct
+
+  (* The table is implemented as an array of [constr_substituted].
+     Keys are hence integers. To avoid changing the [compiled_library]
+     type, we brutally encode integers into [lazy_constr]. This isn't
+     pretty, but shouldn't be dangerous since the produced structure
+     [lightened_compiled_library] is abstract and only meant for writing
+     to .vo via Marshal (which doesn't care about types).
+  *)
+  type table = constr_substituted array
+  let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr)
+  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
+
+  (* To avoid any future misuse of the lightened library that could 
+     interpret encoded keys as real [constr_substituted], we hide 
+     these kind of values behind an abstract datatype. *)
+  type lightened_compiled_library = compiled_library
+
+  (* Map a [compiled_library] to another one by just updating 
+     the opaque term [t] to [on_opaque_const_body t]. *)
+  let traverse_library on_opaque_const_body =
+    let rec traverse_module mb =
+      match mb.mod_expr with 
+	  None -> 
+	    { mb with
+		mod_expr = None;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }
+	| Some impl when impl == mb.mod_type-> 
+	    let mtb =  traverse_modexpr mb.mod_type in 
+	      { mb with
+		  mod_expr = Some mtb;
+		  mod_type = mtb;
+	      }    
+	| Some impl -> 
+	    { mb with
+		mod_expr = Option.map traverse_modexpr mb.mod_expr;
+		mod_type = traverse_modexpr mb.mod_type;
+	    }    
+    and traverse_struct struc =
+      let traverse_body (l,body) = (l,match body with
+	| SFBconst cb when is_opaque cb ->
+	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
+	| (SFBconst _ | SFBmind _ ) as x ->
+	  x
+	| SFBmodule m -> 
+	  SFBmodule (traverse_module m)
+	| SFBmodtype m -> 
+	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
+      in
+      List.map traverse_body struc
+	
+    and traverse_modexpr = function
+      | SEBfunctor (mbid,mty,mexpr) ->
+	SEBfunctor (mbid,
 		    ({mty with
-			typ_expr = lighten_modexpr mty.typ_expr}),
-		  lighten_modexpr mexpr)
-  | SEBident mp as x -> x
-  | 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)
-
-let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
-
+		      typ_expr = traverse_modexpr mty.typ_expr}),
+		    traverse_modexpr mexpr)
+      | SEBident mp as x -> x
+      | SEBstruct (struc) ->
+	SEBstruct  (traverse_struct struc)
+      | SEBapply (mexpr,marg,u) ->
+	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
+      | SEBwith (seb,wdcl) ->
+	SEBwith (traverse_modexpr seb,wdcl)
+    in
+    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
+
+  (* To disburden a library from opaque definitions, we simply 
+     traverse it and add an indirection between the module body 
+     and its reference to a [const_body]. *)
+  let save library = 
+    let ((insert    : constant_def -> constant_def),
+	 (get_table : unit -> table)) = 
+      (* We use an integer as a key inside the table. *)
+      let counter = ref (-1) in
+
+      (* During the traversal, the table is implemented by a list 
+	 to get constant time insertion. *)
+      let opaque_definitions = ref [] in
+      
+      ((* Insert inside the table. *) 
+	(fun def ->
+	  let opaque_definition = match def with
+	    | OpaqueDef lc -> force_lazy_constr lc
+	    | _ -> assert false
+	  in
+	  incr counter;
+	  opaque_definitions := opaque_definition :: !opaque_definitions;
+	  OpaqueDef (key_as_lazy_constr !counter)),
+
+       (* Get the final table representation. *)
+       (fun () -> Array.of_list (List.rev !opaque_definitions)))
+    in
+    let lightened_library = traverse_library insert library in
+    (lightened_library, get_table ())
+
+  (* Loading is also a traversing that decodes the embedded keys that
+     are inside the [lightened_library]. If the [load_proof] flag is
+     set, we lookup inside the table to graft the
+     [constr_substituted]. Otherwise, we set the [const_body] field
+     to [None]. 
+  *)
+  let load ~load_proof (table : table Lazy.t) lightened_library =
+    let decode_key = function
+      | Undef _ | Def _ -> assert false
+      | OpaqueDef k ->
+	  let k = key_of_lazy_constr k in
+	  let access key =
+	    try (Lazy.force table).(key)
+	    with _ -> error "Error while retrieving an opaque body"
+	  in
+	  match load_proof with
+	    | Flags.Force ->
+	      let lc = Lazy.lazy_from_val (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Lazy ->
+	      let lc = lazy (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Dont ->
+	      Undef None
+    in
+    traverse_library decode_key lightened_library
+
+end
 
 type judgment = unsafe_judgment
 
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 33a6a775..6f46a45b 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -1,22 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ 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
+(** {6 Safe environments } *)
+
+(** Since we are now able to type terms, we can
   define an abstract type of safe environments, where objects are
   typed before being added.
 
@@ -31,7 +29,7 @@ val env_of_safe_env : safe_environment -> Environ.env
 val empty_environment : safe_environment
 val is_empty : safe_environment -> bool
 
-(* Adding and removing local declarations (Local or Variables) *)
+(** Adding and removing local declarations (Local or Variables) *)
 val push_named_assum :
   identifier * types -> safe_environment ->
     Univ.constraints * safe_environment
@@ -39,7 +37,7 @@ val push_named_def :
   identifier * constr * types option -> safe_environment ->
     Univ.constraints * safe_environment
 
-(* Adding global axioms or definitions *)
+(** Adding global axioms or definitions *)
 type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
@@ -48,39 +46,40 @@ val add_constant :
   dir_path -> label -> global_declaration -> safe_environment ->
       constant * safe_environment
 
-(* Adding an inductive type *)
+(** Adding an inductive type *)
 val add_mind :
   dir_path -> label -> mutual_inductive_entry -> safe_environment ->
     mutual_inductive * safe_environment
 
-(* Adding a module *)
+(** Adding a module *)
 val add_module :
-  label -> module_entry -> bool -> safe_environment
+  label -> module_entry -> inline -> safe_environment
     -> module_path * delta_resolver * safe_environment
 
-(* Adding a module type *)
+(** Adding a module type *)
 val add_modtype :
-  label -> module_struct_entry -> bool -> safe_environment
+  label -> module_struct_entry -> inline -> safe_environment
     -> module_path * safe_environment
 
-(* Adding universe constraints *)
+(** Adding universe constraints *)
 val add_constraints :
   Univ.constraints -> safe_environment -> safe_environment
 
-(* Settin the strongly constructive or classical logical engagement *)
+(** Settin the strongly constructive or classical logical engagement *)
 val set_engagement : engagement -> safe_environment -> safe_environment
 
 
-(*s Interactive module functions *)
+(** {6 Interactive module functions } *)
+
 val start_module :
   label -> safe_environment -> module_path * safe_environment
 
 val end_module :
-  label -> (module_struct_entry * bool) option
+  label -> (module_struct_entry * inline) option
       -> safe_environment -> module_path * delta_resolver * safe_environment 
 
 val add_module_parameter :
-  mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment
+  mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment
 
 val start_modtype :
   label -> safe_environment -> module_path * safe_environment
@@ -89,16 +88,17 @@ val end_modtype :
   label -> safe_environment -> module_path * safe_environment
 
 val add_include :
-  module_struct_entry -> bool -> bool -> safe_environment ->
+  module_struct_entry -> bool -> inline -> safe_environment ->
    delta_resolver * safe_environment
 
 val pack_module : safe_environment -> module_body
 val current_modpath : safe_environment -> module_path
 val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
   
-(* Loading and saving compilation units *)
 
-(* exporting and importing modules *)
+(** Loading and saving compilation units *)
+
+(** exporting and importing modules *)
 type compiled_library
 
 val start_library : dir_path -> safe_environment
@@ -110,18 +110,25 @@ val export : safe_environment -> dir_path
 val import : compiled_library -> Digest.t -> safe_environment
       -> module_path * safe_environment
 
-(* Remove the body of opaque constants *)
+(** Remove the body of opaque constants *)
 
-val lighten_library : compiled_library -> compiled_library
+module LightenLibrary :
+sig
+  type table
+  type lightened_compiled_library
+  val save : compiled_library -> lightened_compiled_library * table
+  val load : load_proof:Flags.load_proofs -> table Lazy.t ->
+    lightened_compiled_library -> compiled_library
+end
 
-(*s Typing judgments *)
+(** {6 Typing judgments } *)
 
 type judgment
 
 val j_val : judgment -> constr
 val j_type : judgment -> constr
 
-(* Safe typing of a term returning a typing judgment and universe
+(** Safe typing of a term returning a typing judgment and universe
    constraints to be added to the environment for the judgment to
    hold. It is guaranteed that the constraints are satisfiable
  *)
@@ -129,7 +136,9 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
 
 val typing : safe_environment -> constr -> judgment
 
+(** {7 Query } *)
 
+val exists_label : label -> safe_environment -> bool
 
 (*spiwack: safe retroknowledge functionalities *)
 
diff --git a/kernel/sign.ml b/kernel/sign.ml
index d241f677..71169563 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -1,12 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
+   rebuilding of Coq around a purely functional abstract type-checker,
+   Aug 1999 *)
+(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
+   Herbelin and Bruno Barras *)
+
+(* This file defines types and combinators regarding indexes-based and
+   names-based contexts *)
 
 open Names
 open Util
@@ -27,6 +34,7 @@ let rec lookup_named id = function
   | [] -> raise Not_found
 
 let named_context_length = List.length
+let named_context_equal = list_equal eq_named_declaration
 
 let vars_of_named_context = List.map (fun (id,_,_) -> id)
 
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 35e49003..074139c9 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -1,19 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: sign.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
-(*i*)
 
-(*s Signatures of ordered named declarations *)
+(** {6 Signatures of ordered named declarations } *)
 
 type named_context = named_declaration list
 type section_context = named_context
@@ -24,39 +20,45 @@ val vars_of_named_context : named_context -> identifier list
 
 val lookup_named : identifier -> named_context -> named_declaration
 
-(* number of declarations *)
+(** number of declarations *)
 val named_context_length : named_context -> int
 
-(*s Recurrence on [named_context]: older declarations processed first *)
+(** named context equality *)
+val named_context_equal : named_context -> named_context -> bool
+
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
 val fold_named_context :
   (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
 val fold_named_context_reverse :
   ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
 
-(*s Section-related auxiliary functions *)
+(** {6 Section-related auxiliary functions } *)
 val instance_from_named_context : named_context -> constr array
 
-(*s Signatures of ordered optionally named variables, intended to be
+(** {6 ... } *)
+(** Signatures of ordered optionally named variables, intended to be
    accessed by de Bruijn indices *)
 
 val push_named_to_rel_context : named_context -> rel_context -> rel_context
 
-(*s Recurrence on [rel_context]: older declarations processed first *)
+(** {6 Recurrence on [rel_context]: older declarations processed first } *)
 val fold_rel_context :
   (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
 val fold_rel_context_reverse :
   ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
 
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
 val map_rel_context : (constr -> constr) -> rel_context -> rel_context
 
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
 val map_named_context : (constr -> constr) -> named_context -> named_context
 
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
 val iter_rel_context : (constr -> unit) -> rel_context -> unit
 
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
 val iter_named_context : (constr -> unit) -> named_context -> unit
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 447e062a..c141a02a 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -1,12 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module checks subtyping of module types *)
 
 (*i*)
 open Util
@@ -22,8 +25,6 @@ open Mod_subst
 open Entries
 (*i*)
 
-
-
 (* 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 *)
@@ -66,26 +67,26 @@ let make_label_map mp list =
   in
     List.fold_right add_one list Labmap.empty
 
-let check_conv_error error cst f env a1 a2 =
+let check_conv_error error why cst f env a1 a2 =
   try
-    Constraint.union cst (f env a1 a2)
+    union_constraints cst (f env a1 a2)
   with
-      NotConvertible -> error ()
+      NotConvertible -> error why
 
 (* for now we do not allow reorderings *)
 
 let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= 
   let kn1 = make_mind mp1 empty_dirpath l in
   let kn2 = make_mind mp2 empty_dirpath l in
-  let error () = error_not_match l spec2 in
-  let check_conv cst f = check_conv_error error cst f in
+  let error why = error_signature_mismatch l spec2 why in
+  let check_conv why cst f = check_conv_error error why cst f in
   let mib1 =
     match info1 with
       | IndType ((_,0), mib) -> subst_mind subst1 mib
-      | _ -> error ()
+      | _ -> error (InductiveFieldExpected mib2)
   in
   let mib2 =  subst_mind subst2 mib2 in
-  let check_inductive_type cst env t1 t2 =
+  let check_inductive_type cst name 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
@@ -114,40 +115,43 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     let s1,s2 =
       match s1, s2 with
       | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort
-      | (Prop _, Type _) | (Type _,Prop _) -> error ()
+      | (Prop _, Type _) | (Type _,Prop _) ->
+	error (NotConvertibleInductiveField name)
       | _ -> (s1, s2) in
-    check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+    check_conv (NotConvertibleInductiveField name)
+      cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   in
 
   let check_packet cst p1 p2 =
-    let check f = if f p1 <> f p2 then error () in
-      check (fun p -> p.mind_consnames);
-      check (fun p -> p.mind_typename);
+    let check f why = if f p1 <> f p2 then error why in
+      check (fun p -> p.mind_consnames) NotSameConstructorNamesField;
+      check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField;
       (* nf_lc later *)
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      check (fun p -> p.mind_nrealargs);
+      check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
       (* nparams done *)
       (* params_ctxt done because part of the inductive types *)
       (* Don't check the sort of the type if polymorphic *)
-      let cst = check_inductive_type cst env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
+      let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
       in
 	cst
   in
   let check_cons_types i cst p1 p2 =
-    array_fold_left2
-      (fun cst t1 t2 -> check_conv cst conv env t1 t2)
+    array_fold_left3
+      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2)
       cst
+      p2.mind_consnames
       (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);
+  let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in
+  check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x);
+  check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x);
   assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
   assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
@@ -157,17 +161,17 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
   (* at the time of checking the inductive arities in check_packet. *)
   (* Notice that we don't expect the local definitions to match: only *)
   (* the inductive types and constructors types have to be convertible *)
-  check (fun mib -> mib.mind_nparams);
+  check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x);
 
-  begin  
+  begin
   match mind_of_delta reso2 kn2  with
       | kn2' when kn2=kn2' -> ()
       | kn2' -> 
 	  if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then 
-	    error ()
+	    error NotEqualInductiveAliases
   end;
   (* we check that records and their field names are preserved. *)
-  check (fun mib -> mib.mind_record);
+  check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x);
   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)
@@ -179,7 +183,11 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     assert (Array.length mib2.mind_packets = 1);
     assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
     assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
-    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
+    check (fun mib ->
+      let nparamdecls = List.length mib.mind_params_ctxt in
+      let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in
+      snd (list_chop nparamdecls names))
+      (fun x -> RecordProjectionsExpected x);
   end;
   (* we first check simple things *)
   let cst =
@@ -193,7 +201,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
 
     
 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
-  let error () = error_not_match l spec2 in
+  let error why = error_signature_mismatch l spec2 why in
   let check_conv cst f = check_conv_error error cst f in
   let check_type cst env t1 t2 =
 
@@ -233,66 +241,42 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
                  constraints of the form "univ <= max(...)" are not
                  expressible in the system of algebraic universes: we fail
                  (the user has to use an explicit type in the interface *)
-                error ()
-          with UserError _ (* "not an arity" *) ->
-            error () end
-        | _ -> t1,t2
+                error NoTypeConstraintExpected
+          with NotArity ->
+            error NotConvertibleTypeField end
+        | _ ->
+	  t1,t2
       else
         (t1,t2) in
-    check_conv cst conv_leq env t1 t2
+    check_conv NotConvertibleTypeField cst conv_leq env t1 t2
   in
 
   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
+      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+      let cb1 = subst_const_body subst1 cb1 in
+      let cb2 = subst_const_body subst2 cb2 in
+      (* Start by checking types*)
       let typ1 = Typeops.type_of_constant_type env cb1.const_type in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
       let cst = check_type cst env typ1 typ2 in
-      let 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 ->
-		      let c = Declarations.force lc1 in
-			begin
-			  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 ->
-					   Declarations.force lc1
-				       | _,_ -> c)
-			    | _ ,_-> c
-			end
-		  | None -> mkConst con
-		in
-		  check_conv cst conv env c1 c2
-	else
-	  match cb2.const_body with
-            | None -> cst
-            | Some lc2 ->
-		let c2 = Declarations.force lc2 in
-		let c1 = match cb1.const_body with
-		  | Some lc1 -> Declarations.force lc1
-		  | None -> mkConst con
-		in
-		  check_conv cst conv env c1 c2
-      in
-	cst
+      (* Now we check the bodies:
+	 - A transparent constant can only be implemented by a compatible
+	   transparent constant.
+         - In the signature, an opaque is handled just as a parameter:
+           anything of the right type can implement it, even if bodies differ.
+      *)
+      (match cb2.const_body with
+	| Undef _ | OpaqueDef _ -> cst
+	| Def lc2 ->
+	  (match cb1.const_body with
+	    | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField
+	    | Def lc1 ->
+	      (* NB: cb1 might have been strengthened and appear as transparent.
+		 Anyway [check_conv] will handle that afterwards. *)
+	      let c1 = Declarations.force lc1 in
+	      let c2 = Declarations.force lc2 in
+	      check_conv NotConvertibleBodyField cst conv env c1 c2))
    | IndType ((kn,i),mind1) ->
        ignore (Util.error (
        "The kernel does not recognize yet that a parameter can be " ^
@@ -300,10 +284,10 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
        "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 () ;
+      if constant_has_body cb2 then error DefinitionFieldExpected;
       let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
-       check_conv cst conv_leq env arity1 typ2
+       check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2
    | IndConstr (((kn,i),j) as cstr,mind1) ->
       ignore (Util.error (
        "The kernel does not recognize yet that a parameter can be " ^
@@ -311,15 +295,15 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
        "constructor and give a definition to map the old name to the new " ^
        "name."));
       assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if cb2.const_body <> None then error () ;
+      if constant_has_body cb2 then error DefinitionFieldExpected;
       let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
-       check_conv cst conv env ty1 ty2
-   | _ -> error ()
+       check_conv NotConvertibleTypeField cst conv env ty1 ty2
+   | _ -> error DefinitionFieldExpected
 
 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 mty1 = module_type_of_module None msb1 in
+  let mty2 =  module_type_of_module None msb2 in
   let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
     cst
 
@@ -344,13 +328,13 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
 	      match info1 with
 		| Module msb -> check_modules cst env msb msb2 
 		    subst1 subst2
-		| _ -> error_not_match l spec2
+		| _ -> error_signature_mismatch l spec2 ModuleFieldExpected
 	    end
 	| SFBmodtype mtb2 ->
 	    let mtb1 =
 	      match info1 with
 		| Modtype mtb -> mtb
-		| _ -> error_not_match l spec2
+		| _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
 	    in
 	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
 	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
@@ -368,7 +352,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
 	      if equiv then
 		let subst2 = 
 		  add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
-		Univ.Constraint.union 
+		Univ.union_constraints 
 		  (check_signatures cst env
 		     mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
 		  mtb1.typ_delta mtb2.typ_delta) 
@@ -412,7 +396,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
 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 
+  check_modtypes empty_constraint env 
+    (strengthen sup sup.typ_mp) super empty_subst
     (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
 
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index a32804b9..cf9cb540 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -1,18 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Univ
 open Declarations
 open Environ
-(*i*)
 
 val check_subtypes : env -> module_type_body -> module_type_body -> constraints
 
diff --git a/kernel/term.ml b/kernel/term.ml
index 1894417c..dcb63cf7 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -1,14 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* This module instantiates the structure of generic deBruijn terms to Coq *)
+(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
+(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
+(* Extension to mutual inductive constructions by Christine Paulin for
+   Coq V5.10.2 *)
+(* Extension to co-inductive constructions by Eduardo Gimenez *)
+(* Optimization of substitution functions by Chet Murthy *)
+(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
+   Filliâtre, 1999 *)
+(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+
+(* This file defines the internal syntax of the Calculus of
+   Inductive Constructions (CIC) terms together with constructors,
+   destructors, iterators and basic functions *)
 
 open Util
 open Pp
@@ -16,12 +29,14 @@ open Names
 open Univ
 open Esubst
 
-(* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *)
 
 type existential_key = int
 type metavariable = int
 
 (* This defines the strategy to use for verifiying a Cast *)
+(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
+(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
 
 (* This defines Cases annotations *)
 type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
@@ -31,7 +46,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_nargs : int array; (* number of real args of each constructor *)
+    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -58,8 +73,6 @@ let family_of_sort = function
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
-type cast_kind = VMcast | DEFAULTcast
-
 (* [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
 type 'constr pexistential = existential_key * 'constr array
@@ -90,24 +103,6 @@ type ('constr, 'types) kind_of_term =
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
 
-(* Experimental *)
-type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
-  | CastType   of 'types * 'types
-  | ProdType   of name * 'types * 'types
-  | LetInType  of name * 'constr * 'types * 'types
-  | AtomicType of 'constr * 'constr array
-
-let kind_of_type = function
-  | Sort s -> SortType s
-  | Cast (c,_,t) -> CastType (c, t)
-  | Prod (na,t,c) -> ProdType (na, t, c)
-  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
-  | App (c,l) -> AtomicType (c, l)
-  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
-    -> AtomicType (c,[||])
-  | (Lambda _ | Construct _) -> failwith "Not a type"
-
 (* constr is the fixpoint of the previous type. Requires option
    -rectypes of the Caml compiler to be set *)
 type constr = (constr,constr) kind_of_term
@@ -117,82 +112,10 @@ type rec_declaration = name array * constr array * constr array
 type fixpoint = (int array * int) * rec_declaration
 type cofixpoint = int * rec_declaration
 
-(***************************)
-(* hash-consing functions  *)
-(***************************)
 
-let comp_term t1 t2 =
-  match t1, t2 with
-  | Rel n1, Rel n2 -> n1 = n2
-  | Meta m1, Meta m2 -> m1 == m2
-  | Var id1, Var id2 -> id1 == id2
-  | Sort s1, Sort s2 -> s1 == s2
-  | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2
-  | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-  | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-  | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
-      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
-  | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2
-  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2
-  | Const c1, Const c2 -> c1 == c2
-  | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
-  | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
-      sp1 == sp2 & i1 = i2 & j1 = j2
-  | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
-      ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2
-  | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_for_all2 (==) lna1 lna2
-      & array_for_all2 (==) tl1 tl2
-      & array_for_all2 (==) bl1 bl2
-  | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_for_all2 (==) lna1 lna2
-      & array_for_all2 (==) tl1 tl2
-      & array_for_all2 (==) bl1 bl2
-  | _ -> false
-
-let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t =
-  match t with
-  | Rel _ -> t
-  | Meta x -> Meta x
-  | Var x -> Var (sh_id x)
-  | Sort s -> Sort (sh_sort s)
-  | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t))
-  | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c)
-  | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c)
-  | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c)
-  | App (c,l) -> App (sh_rec c, Array.map sh_rec l)
-  | Evar (e,l) -> Evar (e, Array.map sh_rec l)
-  | Const c -> Const (sh_con c)
-  | Ind (kn,i) -> Ind (sh_kn kn,i)
-  | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j)
-  | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *)
-      Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl)
-  | Fix (ln,(lna,tl,bl)) ->
-      Fix (ln,(Array.map sh_na lna,
-                 Array.map sh_rec tl,
-                 Array.map sh_rec bl))
-  | CoFix(ln,(lna,tl,bl)) ->
-      CoFix (ln,(Array.map sh_na lna,
-                   Array.map sh_rec tl,
-                   Array.map sh_rec bl))
-
-module Hconstr =
-  Hashcons.Make(
-    struct
-      type t = constr
-      type u = (constr -> constr) *
-               ((sorts -> sorts) * (constant -> constant) *
-               (mutual_inductive -> mutual_inductive) * (name -> name) *
-               (identifier -> identifier))
-      let hash_sub = hash_term
-      let equal = comp_term
-      let hash = Hashtbl.hash
-    end)
-
-let hcons_term (hsorts,hcon,hkn,hname,hident) =
-  Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident)
+(*********************)
+(* Term constructors *)
+(*********************)
 
 (* Constructs a DeBrujin index with number n *)
 let rels =
@@ -201,21 +124,20 @@ let rels =
 
 let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
 
-(* Constructs an existential variable named "?n" *)
-let mkMeta  n =  Meta n
-
-(* Constructs a Variable named id *)
-let mkVar id = Var id
-
 (* Construct a type *)
-let mkSort s = Sort s
+let mkProp   = Sort prop_sort
+let mkSet    = Sort set_sort
+let mkType u = Sort (Type u)
+let mkSort   = function
+  | Prop Null -> mkProp (* Easy sharing *)
+  | Prop Pos -> mkSet
+  | s -> Sort s
 
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1)
-   [s] is the strategy to use when *)
+(* (that means t2 is declared as the type of t1) *)
 let mkCast (t1,k2,t2) =
   match t1 with
-  | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2)
+  | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2)
   | _ -> Cast (t1,k2,t2)
 
 (* Constructs the product (x:t1)t2 *)
@@ -236,16 +158,13 @@ let mkApp (f, a) =
       | App (g, cl) -> App (g, Array.append cl a)
       | _ -> App (f, a)
 
-
 (* Constructs a constant *)
-(* The array of terms correspond to the variables introduced in the section *)
 let mkConst c = Const c
 
 (* Constructs an existential variable *)
 let mkEvar e = Evar e
 
 (* Constructs the ith (co)inductive type of the block named kn *)
-(* 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
@@ -256,12 +175,48 @@ let mkConstruct c = Construct c
 (* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
 let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
 
+(* If recindxs = [|i1,...in|]
+      funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkFix ((recindxs,i),(funnames,typarray,bodies))
+
+   constructs the ith function of the block
+
+    Fixpoint f1 [ctx1] : t1 := b1
+    with     f2 [ctx2] : t2 := b2
+    ...
+    with     fn [ctxn] : tn := bn.
+
+   where the lenght of the jth context is ij.
+*)
+
 let mkFix fix = Fix fix
 
-let mkCoFix cofix = CoFix cofix
+(* If funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkCoFix (i,(funnames,typsarray,bodies))
+
+   constructs the ith function of the block
+
+    CoFixpoint f1 : t1 := b1
+    with       f2 : t2 := b2
+    ...
+    with       fn : tn := bn.
+*)
+let mkCoFix cofix= CoFix cofix
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
 
-let kind_of_term c = c
-let kind_of_term2 c = c
 
 (************************************************************************)
 (*    kind_of_term = constructions as seen by the user                 *)
@@ -271,15 +226,25 @@ let kind_of_term2 c = c
    least one argument and the function is not itself an applicative
    term *)
 
-let kind_of_term = kind_of_term
+let kind_of_term c = c
 
+(* Experimental, used in Presburger contrib *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of name * 'types * 'types
+  | LetInType  of name * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
 
-(* En vue d'un kind_of_type : constr -> hnftype ??? *)
-type hnftype =
-  | HnfSort   of sorts
-  | HnfProd   of name * constr * constr
-  | HnfAtom   of constr
-  | HnfInd of inductive * constr array
+let kind_of_type = function
+  | Sort s -> SortType s
+  | Cast (c,_,t) -> CastType (c, t)
+  | Prod (na,t,c) -> ProdType (na, t, c)
+  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+  | App (c,l) -> AtomicType (c, l)
+  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
+    -> AtomicType (c,[||])
+  | (Lambda _ | Construct _) -> failwith "Not a type"
 
 (**********************************************************************)
 (*          Non primitive term destructors                            *)
@@ -334,18 +299,12 @@ let rec is_Type c = match kind_of_term c with
   | Cast (c,_,_) -> is_Type c
   | _ -> false
 
-let isType = function
-  | Type _ -> true
-  | _ -> false
-
 let is_small = function
   | Prop _ -> true
   | _ -> false
 
 let iskind c = isprop c or is_Type c
 
-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
 
@@ -366,6 +325,7 @@ let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
 
 (* Tests if a variable *)
 let isVar c = match kind_of_term c with Var _ -> true | _ -> false
+let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false
 
 (* Tests if an inductive *)
 let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
@@ -387,7 +347,7 @@ let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 (* Destructs the let [x:=b:t1]t2 *)
 let destLetIn c = match kind_of_term c with
   | LetIn (x,b,t1,t2) -> (x,b,t1,t2)
-  | _ -> invalid_arg "destProd"
+  | _ -> invalid_arg "destLetIn"
 
 let isLetIn c =  match kind_of_term c with LetIn _ -> true | _ -> false
 
@@ -412,10 +372,6 @@ let destEvar c = match kind_of_term c with
   | Evar (kn, a as r) -> r
   | _ -> invalid_arg "destEvar"
 
-let num_of_evar c = match kind_of_term c with
-  | Evar (n, _) -> n
-  | _ -> anomaly "num_of_evar called with bad args"
-
 (* Destructs a (co)inductive type named kn *)
 let destInd c = match kind_of_term c with
   | Ind (kn, a as r) -> r
@@ -485,18 +441,6 @@ let decompose_app c =
     | App (f,cl) -> (f, Array.to_list cl)
     | _ -> (c,[])
 
-(* strips head casts and flattens head applications *)
-let rec strip_head_cast c = match kind_of_term c with
-  | 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
-      collapse_rec f cl
-  | Cast (c,_,_) -> strip_head_cast c
-  | _ -> c
-
 (****************************************************************************)
 (*              Functions to recur through subterms                         *)
 (****************************************************************************)
@@ -621,15 +565,11 @@ let compare_constr f t1 t2 =
   | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
   | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
   | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
+  | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+  | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
   | App (c1,l1), App (c2,l2) ->
-      if Array.length l1 = Array.length l2 then
-        f c1 c2 & array_for_all2 f l1 l2
-      else
-        let (h1,l1) = decompose_app t1 in
-        let (h2,l2) = decompose_app t2 in
-        if List.length l1 = List.length l2 then
-          f h1 h2 & List.for_all2 f l1 l2
-        else false
+    Array.length l1 = Array.length l2 &&
+      f c1 c2 && array_for_all2 f l1 l2
   | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
   | Const c1, Const c2 -> eq_constant c1 c2
   | Ind c1, Ind c2 -> eq_ind c1 c2
@@ -642,6 +582,62 @@ let compare_constr f t1 t2 =
       ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
   | _ -> false
 
+(*******************************)
+(*  alpha conversion functions *)
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let rec eq_constr m n =
+  (m==n) or
+  compare_constr eq_constr m n
+
+let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+let constr_ord_int f t1 t2 =
+  let (=?) f g i1 i2 j1 j2=
+    let c=f i1 i2 in
+    if c=0 then g j1 j2 else c in
+  let (==?) fg h i1 i2 j1 j2 k1 k2=
+    let c=fg i1 i2 j1 j2 in
+    if c=0 then h k1 k2 else c in
+  match kind_of_term t1, kind_of_term t2 with
+    | Rel n1, Rel n2 -> n1 - n2
+    | Meta m1, Meta m2 -> m1 - m2
+    | Var id1, Var id2 -> id_ord id1 id2
+    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
+    | Cast (c1,_,_), _ -> f c1 t2
+    | _, Cast (c2,_,_) -> f t1 c2
+    | Prod (_,t1,c1), Prod (_,t2,c2)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+	(f =? f) t1 t2 c1 c2
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+    | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+    | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
+    | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2
+    | Evar (e1,l1), Evar (e2,l2) ->
+	((-) =? (array_compare f)) e1 e2 l1 l2
+    | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2)
+    | Ind (spx, ix), Ind (spy, iy) ->
+	let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c
+    | Construct ((spx, ix), jx), Construct ((spy, iy), jy) ->
+	let c = jx - jy in if c = 0 then
+	  (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c)
+	else c
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+	((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | t1, t2 -> Pervasives.compare t1 t2
+
+let rec constr_ord m n=
+  constr_ord_int constr_ord m n
+
 (***************************************************************************)
 (*     Type of assumptions                                                 *)
 (***************************************************************************)
@@ -659,6 +655,18 @@ let map_rel_declaration = map_named_declaration
 let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
 let fold_rel_declaration = fold_named_declaration
 
+let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
+let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
+
+let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
+let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
+
+let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+  id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
+let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
+  n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
 (***************************************************************************)
 (*     Type of local contexts (telescopes)                                 *)
 (***************************************************************************)
@@ -762,12 +770,12 @@ let rec exliftn el c = match kind_of_term c with
 
 (* Lifting the binding depth across k bindings *)
 
-let liftn k n =
-  match el_liftn (pred n) (el_shft k ELID) with
+let liftn n k =
+  match el_liftn (pred k) (el_shft n el_id) with
     | ELID -> (fun c -> c)
     | el -> exliftn el
 
-let lift k = liftn k 1
+let lift n = liftn n 1
 
 (*********************)
 (*   Substituting    *)
@@ -814,12 +822,12 @@ let substnl laml n =
 let substl laml = substnl laml 0
 let subst1 lam = substl [lam]
 
-let substnl_decl laml k (id,bodyopt,typ) =
-  (id,Option.map (substnl laml k) bodyopt,substnl laml k typ)
+let substnl_decl laml k = map_rel_declaration (substnl laml k)
 let substl_decl laml = substnl_decl laml 0
 let subst1_decl lam = substl_decl [lam]
-let subst1_named_decl = subst1_decl
+let substnl_named laml k = map_named_declaration (substnl laml k)
 let substl_named_decl = substl_decl
+let subst1_named_decl = subst1_decl
 
 (* (thin_val sigma) removes identity substitutions from sigma *)
 
@@ -858,44 +866,12 @@ let substn_vars p vars =
 
 let subst_vars = substn_vars 1
 
-(*********************)
-(* Term constructors *)
-(*********************)
-
-(* Constructs a DeBrujin index with number n *)
-let mkRel = mkRel
-
-(* Constructs an existential variable named "?n" *)
-let mkMeta = mkMeta
-
-(* Constructs a Variable named id *)
-let mkVar = mkVar
-
-(* Construct a type *)
-let mkProp   = mkSort prop_sort
-let mkSet    = mkSort set_sort
-let mkType u = mkSort (Type u)
-let mkSort   = function
-  | Prop Null -> mkProp (* Easy sharing *)
-  | Prop Pos -> mkSet
-  | s -> mkSort s
-
-(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast = mkCast
+(***************************)
+(* Other term constructors *)
+(***************************)
 
-(* Constructs the product (x:t1)t2 *)
-let mkProd = mkProd
 let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c)
-let mkProd_string   s t c = mkProd (Name (id_of_string s), t, c)
-
-(* Constructs the abstraction [x:t1]t2 *)
-let mkLambda = mkLambda
 let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c)
-let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
-
-(* Constructs [x=c_1:t]c_2 *)
-let mkLetIn = mkLetIn
 let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2)
 
 (* Constructs either [(x:t)c] or [[x=b:t]c] *)
@@ -909,17 +885,6 @@ let mkNamedProd_or_LetIn (id,body,t) c =
     | None -> mkNamedProd id t c
     | Some b -> mkNamedLetIn id b t c
 
-(* Constructs either [[x:t]c] or [[x=b:t]c] *)
-let mkLambda_or_LetIn (na,body,t) c =
-  match body with
-    | None -> mkLambda (na, t, c)
-    | Some b -> mkLetIn (na, b, t, c)
-
-let mkNamedLambda_or_LetIn (id,body,t) c =
-  match body with
-    | None -> mkNamedLambda id t c
-    | Some b -> mkNamedLetIn id b t c
-
 (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
 let mkProd_wo_LetIn (na,body,t) c =
   match body with
@@ -934,83 +899,16 @@ let mkNamedProd_wo_LetIn (id,body,t) c =
 (* non-dependent product t1 -> t2 *)
 let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
 
-(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
-(* We ensure applicative terms have at most one arguments and the
-   function is not itself an applicative term *)
-let mkApp = mkApp
-
-let mkAppA v =
-  let l = Array.length v in
-  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 *)
-(* The array of terms correspond to the variables introduced in the section *)
-let mkConst = mkConst
-
-(* Constructs an existential variable *)
-let mkEvar = mkEvar
-
-(* Constructs the ith (co)inductive type of the block named kn *)
-(* 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
-   block named kn. The array of terms correspond to the variables
-   introduced in the section *)
-let mkConstruct = mkConstruct
-
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
-let mkCase = mkCase
-let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac)
-
-(* If recindxs = [|i1,...in|]
-      funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
-
-      mkFix ((recindxs,i),(funnames,typarray,bodies))
-
-   constructs the ith function of the block
-
-    Fixpoint f1 [ctx1] : t1 := b1
-    with     f2 [ctx2] : t2 := b2
-    ...
-    with     fn [ctxn] : tn := bn.
-
-   where the lenght of the jth context is ij.
-*)
-
-let mkFix = mkFix
-
-(* If funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
-
-      mkCoFix (i,(funnames,typsarray,bodies))
-
-   constructs the ith function of the block
-
-    CoFixpoint f1 : t1 := b1
-    with       f2 : t2 := b2
-    ...
-    with       fn : tn := bn.
-*)
-let mkCoFix = mkCoFix
-
-(* Construct an implicit *)
-let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0))
-let mkImplicit = mkSort implicit_sort
-
-(***************************)
-(* Other term constructors *)
-(***************************)
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+let mkLambda_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkLambda (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
 
-let abs_implicit c = mkLambda (Anonymous, mkImplicit, c)
-let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a)
-let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a)
+let mkNamedLambda_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedLambda id t c
+    | Some b -> mkNamedLetIn id b t c
 
 (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
 let prodn n env b =
@@ -1252,37 +1150,216 @@ let rec isArity c =
   | Sort _          -> true
   | _               -> false
 
-(*******************************)
-(*  alpha conversion functions *)
-(*******************************)
-
-(* alpha conversion : ignore print names and casts *)
-
-let rec eq_constr m n =
-  (m==n) or
-  compare_constr eq_constr m n
-
-let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
-
 (*******************)
 (*  hash-consing   *)
 (*******************)
 
-module Htype =
-  Hashcons.Make(
-    struct
-      type t = types
-      type u = (constr -> constr) * (sorts -> sorts)
-(*
-      let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ}
-      let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ
+(* Hash-consing of [constr] does not use the module [Hashcons] because
+   [Hashcons] is not efficient on deep tree-like data
+   structures. Indeed, [Hashcons] is based the (very efficient)
+   generic hash function [Hashtbl.hash], which computes the hash key
+   through a depth bounded traversal of the data structure to be
+   hashed. As a consequence, for a deep [constr] like the natural
+   number 1000 (S (S (... (S O)))), the same hash is assigned to all
+   the sub [constr]s greater than the maximal depth handled by
+   [Hashtbl.hash]. This entails a huge number of collisions in the
+   hash table and leads to cubic hash-consing in this worst-case.
+
+   In order to compute a hash key that is independent of the data
+   structure depth while being constant-time, an incremental hashing
+   function must be devised. A standard implementation creates a cache
+   of the hashing function by decorating each node of the hash-consed
+   data structure with its hash key. In that case, the hash function
+   can deduce the hash key of a toplevel data structure by a local
+   computation based on the cache held on its substructures.
+   Unfortunately, this simple implementation introduces a space
+   overhead that is damageable for the hash-consing of small [constr]s
+   (the most common case). One can think of an heterogeneous
+   distribution of caches on smartly chosen nodes, but this is forbidden
+   by the use of generic equality in Coq source code. (Indeed, this forces
+   each [constr] to have a unique canonical representation.)
+
+   Given that hash-consing proceeds inductively, we can nonetheless
+   computes the hash key incrementally during hash-consing by changing
+   a little the signature of the hash-consing function: it now returns
+   both the hash-consed term and its hash key. This simple solution is
+   implemented in the following code: it does not introduce a space
+   overhead in [constr], that's why the efficiency is unchanged for
+   small [constr]s. Besides, it does handle deep [constr]s without
+   introducing an unreasonable number of collisions in the hash table.
+   Some benchmarks make us think that this implementation of
+   hash-consing is linear in the size of the hash-consed data
+   structure for our daily use of Coq.
 *)
-(**)
-      let hash_sub (hc,hs) j = hc j
-      let equal j1 j2 = j1==j2
-(**)
-      let hash = Hashtbl.hash
-    end)
+
+let array_eqeq t1 t2 =
+  t1 == t2 ||
+  (Array.length t1 = Array.length t2 &&
+   let rec aux i =
+     (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1))
+   in aux 0)
+
+let equals_constr t1 t2 =
+  match t1, t2 with
+    | Rel n1, Rel n2 -> n1 == n2
+    | Meta m1, Meta m2 -> m1 == m2
+    | Var id1, Var id2 -> id1 == id2
+    | Sort s1, Sort s2 -> s1 == s2
+    | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2
+    | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+    | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+    | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
+      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
+    | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2
+    | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2
+    | Const c1, Const c2 -> c1 == c2
+    | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
+    | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
+      sp1 == sp2 & i1 = i2 & j1 = j2
+    | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+      ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2
+    | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_eqeq lna1 lna2
+      & array_eqeq tl1 tl2
+      & array_eqeq bl1 bl2
+    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_eqeq lna1 lna2
+      & array_eqeq tl1 tl2
+      & array_eqeq bl1 bl2
+    | _ -> false
+
+(** Note that the following Make has the side effect of creating
+    once and for all the table we'll use for hash-consing all constr *)
+
+module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end)
+
+open Hashtbl_alt.Combine
+
+(* [hcons_term hash_consing_functions constr] computes an hash-consed
+   representation for [constr] using [hash_consing_functions] on
+   leaves. *)
+let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
+
+  (* Note : we hash-cons constr arrays *in place* *)
+
+  let rec hash_term_array t =
+    let accu = ref 0 in
+    for i = 0 to Array.length t - 1 do
+      let x, h = sh_rec t.(i) in
+      accu := combine !accu h;
+      t.(i) <- x
+    done;
+    !accu
+
+  and hash_term t =
+    match t with
+      | Var i ->
+	(Var (sh_id i), combinesmall 1 (Hashtbl.hash i))
+      | Sort s ->
+	(Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s))
+      | Cast (c, k, t) ->
+	let c, hc = sh_rec c in
+	let t, ht = sh_rec t in
+	(Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht))
+      | Prod (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc))
+      | Lambda (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc))
+      | LetIn (na,b,t,c) ->
+	let b, hb = sh_rec b in
+	let t, ht = sh_rec t in
+	let c, hc = sh_rec c in
+	(LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc))
+      | App (c,l) ->
+	let c, hc = sh_rec c in
+	let hl = hash_term_array l in
+	(App (c, l), combinesmall 7 (combine hl hc))
+      | Evar (e,l) ->
+	let hl = hash_term_array l in
+	(* since the array have been hashed in place : *)
+	(t, combinesmall 8 (combine (Hashtbl.hash e) hl))
+      | Const c ->
+	(Const (sh_con c), combinesmall 9 (Hashtbl.hash c))
+      | Ind ((kn,i) as ind) ->
+	(Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i))
+      | Construct (((kn,i),j) as c)->
+	(Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j))
+      | Case (ci,p,c,bl) ->
+	let p, hp = sh_rec p
+	and c, hc = sh_rec c in
+	let hbl = hash_term_array bl in
+	let hbl = combine (combine hc hp) hbl in
+	(Case (sh_ci ci, p, c, bl), combinesmall 11 hbl)
+      | Fix (ln,(lna,tl,bl)) ->
+	let hbl = hash_term_array  bl in
+	let htl = hash_term_array  tl in
+	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+	(* since the three arrays have been hashed in place : *)
+	(t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl)))
+      | CoFix(ln,(lna,tl,bl)) ->
+	let hbl = hash_term_array bl in
+	let htl = hash_term_array tl in
+	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+	(* since the three arrays have been hashed in place : *)
+	(t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl)))
+      | Meta n ->
+	(t, combinesmall 15 n)
+      | Rel n ->
+	(t, combinesmall 16 n)
+
+  and sh_rec t =
+    let (y, h) = hash_term t in
+    (* [h] must be positive. *)
+    let h = h land 0x3FFFFFFF in
+    (H.may_add_and_get h y, h)
+
+  in
+  (* Make sure our statically allocated Rels (1 to 16) are considered
+     as canonical, and hence hash-consed to themselves *)
+  ignore (hash_term_array rels);
+
+  fun t -> fst (sh_rec t)
+
+(* Exported hashing fonction on constr, used mainly in plugins.
+   Appears to have slight differences from [snd (hash_term t)] above ? *)
+
+let rec hash_constr t =
+  match kind_of_term t with
+    | Var i -> combinesmall 1 (Hashtbl.hash i)
+    | Sort s -> combinesmall 2 (Hashtbl.hash s)
+    | Cast (c, _, _) -> hash_constr c
+    | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c))
+    | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c))
+    | LetIn (_, b, t, c) ->
+      combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c))
+    | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l))
+    | App (c,l) ->
+      combinesmall 7 (combine (hash_term_array l) (hash_constr c))
+    | Evar (e,l) ->
+      combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l))
+    | Const c ->
+      combinesmall 9 (Hashtbl.hash c)	(* TODO: proper hash function for constants *)
+    | Ind (kn,i) ->
+      combinesmall 9 (combine (Hashtbl.hash kn) i)
+    | Construct ((kn,i),j) ->
+      combinesmall 10 (combine3 (Hashtbl.hash kn) i j)
+    | Case (_ , p, c, bl) ->
+      combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl))
+    | Fix (ln ,(_, tl, bl)) ->
+      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
+    | CoFix(ln, (_, tl, bl)) ->
+       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
+    | Meta n -> combinesmall 15 n
+    | Rel n -> combinesmall 16 n
+
+and hash_term_array t =
+  Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t
 
 module Hsorts =
   Hashcons.Make(
@@ -1300,16 +1377,34 @@ module Hsorts =
       let hash = Hashtbl.hash
     end)
 
-let hsort = Hsorts.f
+module Hcaseinfo =
+  Hashcons.Make(
+    struct
+      type t = case_info
+      type u = inductive -> inductive
+      let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind }
+      let equal ci ci' =
+	ci.ci_ind == ci'.ci_ind &&
+	ci.ci_npar = ci'.ci_npar &&
+	ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *)
+	ci.ci_pp_info = ci'.ci_pp_info  (* we use (=) on purpose *)
+      let hash = Hashtbl.hash
+    end)
 
-let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) =
-  let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
-  let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in
-  let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
-  (hcci,htcci)
+let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ
+let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind
 
-let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
+let hcons_constr =
+  hcons_term
+    (hcons_sorts,
+     hcons_caseinfo,
+     hcons_construct,
+     hcons_ind,
+     hcons_con,
+     hcons_name,
+     hcons_ident)
 
+let hcons_types = hcons_constr
 
 (*******)
 (* Type of abstract machine values *)
diff --git a/kernel/term.mli b/kernel/term.mli
index c9a97bbe..d5899f18 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -1,169 +1,176 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
-(*i*)
 
 
-(*s The sorts of CCI. *)
+(** {6 The sorts of CCI. } *)
 
 type contents = Pos | Null
 
 type sorts =
-  | Prop of contents       (* Prop and Set *)
-  | Type of Univ.universe  (* Type *)
+  | Prop of contents       (** Prop and Set *)
+  | Type of Univ.universe  (** Type *)
 
 val set_sort  : sorts
 val prop_sort : sorts
 val type1_sort  : sorts
 
-(*s The sorts family of CCI. *)
+(** {6 The sorts family of CCI. } *)
 
 type sorts_family = InProp | InSet | InType
 
 val family_of_sort : sorts -> sorts_family
 
-(*s Useful types *)
+(** {6 Useful types } *)
 
-(*s Existential variables *)
+(** {6 Existential variables } *)
 type existential_key = int
 
-(*s Existential variables *)
+(** {6 Existential variables } *)
 type metavariable = int
 
-(*s Case annotation *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
+(** {6 Case annotation } *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle 
+  | RegularStyle (** infer printing form from number of constructor *)
 type case_printing =
-  { ind_nargs : int; (* length of the arity of the inductive type *)
+  { 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 *)
+
+(** the integer is the number of real args, needed for reduction *)
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_nargs : int array; (* number of real args of each constructor *)
-    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+    ci_cstr_ndecls : int array; (** number of real args of each constructor *)
+    ci_pp_info    : case_printing (** not interpreted by the kernel *)
   }
 
-(*s*******************************************************************)
-(* The type of constructions *)
+(** {6 The type of constructions } *)
 
 type constr
 
-(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
+(** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
    and application grouping *)
 val eq_constr : constr -> constr -> bool
 
-(* [types] is the same as [constr] but is intended to be used for
+(** [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 {e 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.
+(** {5 Functions for dealing with constr terms. }
   The following functions are intended to simplify and to uniform the
   manipulation of terms. Some of these functions may be overlapped with
   previous ones. *)
 
-(*s Term constructors. *)
+(** {6 Term constructors. } *)
 
-(* Constructs a DeBrujin index (DB indices begin at 1) *)
+(** Constructs a DeBrujin index (DB indices begin at 1) *)
 val mkRel : int -> constr
 
-(* Constructs a Variable *)
+(** Constructs a Variable *)
 val mkVar : identifier -> constr
 
-(* Constructs an patvar named "?n" *)
+(** Constructs an patvar named "?n" *)
 val mkMeta : metavariable -> constr
 
-(* Constructs an existential variable *)
+(** Constructs an existential variable *)
 type existential = existential_key * constr array
 val mkEvar : existential -> constr
 
-(* Construct a sort *)
+(** Construct a sort *)
 val mkSort : sorts -> types
 val mkProp : types
 val mkSet  : types
 val mkType : Univ.universe -> types
 
 
-(* This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast
+(** This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
 
-(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the
-   type $t_2$ (that means t2 is declared as the type of t1). *)
+(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
+   type t{_ 2} (that means t2 is declared as the type of t1). *)
 val mkCast : constr * cast_kind * constr -> constr
 
-(* Constructs the product [(x:t1)t2] *)
+(** Constructs the product [(x:t1)t2] *)
 val mkProd : name * types * types -> types
 val mkNamedProd : identifier -> types -> types -> types
-(* non-dependant product $t_1 \rightarrow t_2$, an alias for
-   [(_:t1)t2]. Beware $t_2$ is NOT lifted.
-   Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *)
+
+(** non-dependent product [t1 -> t2], an alias for
+   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
+   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
+*)
 val mkArrow : types -> types -> constr
 
-(* Constructs the abstraction $[x:t_1]t_2$ *)
+(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
 val mkLambda : name * types * constr -> constr
 val mkNamedLambda : identifier -> types -> constr -> constr
 
-(* Constructs the product [let x = t1 : t2 in t3] *)
+(** Constructs the product [let x = t1 : t2 in t3] *)
 val mkLetIn : name * constr * types * constr -> constr
 val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
 
-(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application
-   $(f~t_1~\dots~t_n)$. *)
+(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+   {% $(f~t_1~\dots~t_n)$ %}. *)
 val mkApp : constr * constr array -> constr
 
-(* Constructs a constant *)
-(* The array of terms correspond to the variables introduced in the section *)
+(** Constructs a constant 
+   The array of terms correspond to the variables introduced in the section *)
 val mkConst : constant -> constr
 
-(* Inductive types *)
+(** Inductive types *)
 
-(* Constructs the ith (co)inductive type of the block named kn *)
-(* The array of terms correspond to the variables introduced in the section *)
+(** Constructs the ith (co)inductive type of the block named kn 
+   The array of terms correspond to the variables introduced in the section *)
 val mkInd : inductive -> constr
 
-(* Constructs the jth constructor of the ith (co)inductive type of the
+(** Constructs the jth constructor of the ith (co)inductive type of the
    block named kn. The array of terms correspond to the variables
    introduced in the section *)
 val mkConstruct : constructor -> constr
 
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+(** Constructs a destructor of inductive type.
+    
+    [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] 
+    presented as describe in [ci].
+
+    [p] stucture is [fun args x -> "return clause"]
+
+    [ac]{^ ith} element is ith constructor case presented as 
+    {e lambda construct_args (without params). case_term } *)
 val mkCase : case_info * constr * constr * constr array -> constr
 
-(* If [recindxs = [|i1,...in|]]
+(** If [recindxs = [|i1,...in|]]
       [funnames = [|f1,.....fn|]]
       [typarray = [|t1,...tn|]]
       [bodies   = [|b1,.....bn|]]
-   then [ mkFix ((recindxs,i), funnames, typarray, bodies) ]
-   constructs the $i$th function of the block (counting from 0)
+   then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
+   constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
 
     [Fixpoint f1 [ctx1] = b1
      with     f2 [ctx2] = b2
      ...
      with     fn [ctxn] = bn.]
 
-   \noindent where the length of the $j$th context is $ij$.
+   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
 *)
 type rec_declaration = name array * types array * constr array
 type fixpoint = (int array * int) * rec_declaration
 val mkFix : fixpoint -> constr
 
-(* If [funnames = [|f1,.....fn|]]
+(** If [funnames = [|f1,.....fn|]]
       [typarray = [|t1,...tn|]]
-      [bodies   = [b1,.....bn]] \par\noindent
-   then [mkCoFix (i, (typsarray, funnames, bodies))]
+      [bodies   = [b1,.....bn]] 
+   then [mkCoFix (i, (funnames, typarray, bodies))]
    constructs the ith function of the block
-
+   
     [CoFixpoint f1 = b1
      with       f2 = b2
      ...
@@ -173,9 +180,9 @@ type cofixpoint = int * rec_declaration
 val mkCoFix : cofixpoint -> constr
 
 
-(*s Concrete type for making pattern-matching. *)
+(** {6 Concrete type for making pattern-matching. } *)
 
-(* [constr array] is an instance matching definitional [named_context] in
+(** [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
 type 'constr pexistential = existential_key * 'constr array
 type ('constr, 'types) prec_declaration =
@@ -203,14 +210,13 @@ type ('constr, 'types) kind_of_term =
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
 
-(* User view of [constr]. For [App], it is ensured there is at
+(** User view of [constr]. For [App], it is ensured there is at
    least one argument and the function is not itself an applicative
    term *)
 
 val kind_of_term : constr -> (constr, types) kind_of_term
-val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term
 
-(* Experimental *)
+(** Experimental, used in Presburger contrib *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
   | CastType   of 'types * 'types
@@ -220,10 +226,11 @@ type ('constr, 'types) kind_of_type =
 
 val kind_of_type : types -> (constr, types) kind_of_type
 
-(*s Simple term case analysis. *)
+(** {6 Simple term case analysis. } *)
 
 val isRel  : constr -> bool
 val isVar  : constr -> bool
+val isVarId  : identifier -> constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
@@ -247,77 +254,83 @@ val is_Type : constr -> bool
 val iskind : constr -> bool
 val is_small : sorts -> bool
 
-(*s Term destructors.
-   Destructor operations are partial functions and
-   raise [invalid_arg "dest*"] if the term has not the expected form. *)
 
-(* Destructs a DeBrujin index *)
+(** {6 Term destructors } *)
+(** Destructor operations are partial functions and
+    @raise Invalid_argument "dest*" if the term has not the expected form. *)
+
+(** Destructs a DeBrujin index *)
 val destRel : constr -> int
 
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
 val destMeta : constr -> metavariable
 
-(* Destructs a variable *)
+(** Destructs a variable *)
 val destVar : constr -> identifier
 
-(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether
-   [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *)
+(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether
+   [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *)
 val destSort : constr -> sorts
 
-(* Destructs a casted term *)
+(** Destructs a casted term *)
 val destCast : constr -> constr * cast_kind * constr
 
-(* Destructs the product $(x:t_1)t_2$ *)
+(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
 val destProd : types -> name * types * types
 
-(* Destructs the abstraction $[x:t_1]t_2$ *)
+(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
 val destLambda : constr -> name * types * constr
 
-(* Destructs the let $[x:=b:t_1]t_2$ *)
+(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
 val destLetIn : constr -> name * constr * types * constr
 
-(* Destructs an application *)
+(** Destructs an application *)
 val destApp : constr -> constr * constr array
 
-(* Obsolete synonym of destApp *)
+(** Obsolete synonym of destApp *)
 val destApplication : constr -> constr * constr array
 
-(* Decompose any term as an applicative term; the list of args can be empty *)
+(** Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
-(* Destructs a constant *)
+(** Destructs a constant *)
 val destConst : constr -> constant
 
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
 val destEvar : constr -> existential
 
-(* Destructs a (co)inductive type *)
+(** Destructs a (co)inductive type *)
 val destInd : constr -> inductive
 
-(* Destructs a constructor *)
+(** Destructs a constructor *)
 val destConstruct : constr -> constructor
 
-(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+(** Destructs a [match c as x in I args return P with ... |
+Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
+return P in t1], or [if c then t1 else t2])
+@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])]
+where [info] is pretty-printing information *)
 val destCase : constr -> case_info * constr * constr * constr array
 
-(* 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
-    \mathit{with}     ~ f_n ~ [ctx_n] = b_n$,
-   where the lenght of the $j$th context is $ij$.
+(** Destructs the {% $ %}i{% $ %}th function of the block
+   [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
+    with    f{_ 2} ctx{_ 2} = b{_ 2}
+    ...
+    with    f{_ n} ctx{_ n} = b{_ n}],
+   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
 *)
 val destFix : constr -> fixpoint
 
 val destCoFix : constr -> cofixpoint
 
 
-(*s A {\em declaration} has the form (name,body,type). It is either an
-    {\em assumption} if [body=None] or a {\em definition} if
-    [body=Some actualbody]. It is referred by {\em name} if [na] is an
-    identifier or by {\em relative index} if [na] is not an identifier
+(** {6 Local } *)
+(** A {e declaration} has the form [(name,body,type)]. It is either an
+    {e assumption} if [body=None] or a {e definition} if
+    [body=Some actualbody]. It is referred by {e name} if [na] is an
+    identifier or by {e relative index} if [na] is not an identifier
     (in the latter case, [na] is of type [name] but just for printing
-    purpose *)
+    purpose) *)
 
 type named_declaration = identifier * constr option * types
 type rel_declaration = name * constr option * types
@@ -332,9 +345,25 @@ 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 *)
+val exists_named_declaration :
+  (constr -> bool) -> named_declaration -> bool
+val exists_rel_declaration :
+  (constr -> bool) -> rel_declaration -> bool
 
-(* In [rel_context], more recent declaration is on top *)
+val for_all_named_declaration :
+  (constr -> bool) -> named_declaration -> bool
+val for_all_rel_declaration :
+  (constr -> bool) -> rel_declaration -> bool
+
+val eq_named_declaration :
+  named_declaration -> named_declaration -> bool
+
+val eq_rel_declaration :
+    rel_declaration -> rel_declaration -> bool
+
+(** {6 Contexts of declarations referred to by de Bruijn indices } *)
+
+(** In [rel_context], more recent declaration is on top *)
 type rel_context = rel_declaration list
 
 val empty_rel_context : rel_context
@@ -344,185 +373,186 @@ 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] *)
+(** Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkProd_wo_LetIn : rel_declaration -> types -> types
 val mkNamedProd_or_LetIn : named_declaration -> types -> types
 val mkNamedProd_wo_LetIn : named_declaration -> types -> types
 
-(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+(** Constructs either [[x:t]c] or [[x=b:t]c] *)
 val mkLambda_or_LetIn : rel_declaration -> constr -> constr
 val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
 
-(*s Other term constructors. *)
+(** {6 Other term constructors. } *)
 
-val abs_implicit : constr -> constr
-val lambda_implicit : constr -> constr
-val lambda_implicit_lift : int -> constr -> constr
-
-(* [applist (f,args)] and co work as [mkApp] *)
+(** [applist (f,args)] and its variants work as [mkApp] *)
 
 val applist : constr * constr list -> constr
 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$
-   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+(** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
 val prodn : int -> (name * constr) list -> constr -> constr
 
-(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$
-   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+(** [compose_prod l b]
+   @return [forall (x_1:T_1)...(x_n:T_n), b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)].
    Inverse of [decompose_prod]. *)
 val compose_prod : (name * constr) list -> constr -> constr
 
-(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$
-   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+(** [lamn n l b]
+    @return [fun (x_1:T_1)...(x_n:T_n) => b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
 val lamn : int -> (name * constr) list -> constr -> constr
 
-(* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$
-   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+(** [compose_lam l b]
+   @return [fun (x_1:T_1)...(x_n:T_n) => b]
+   where [l] is [(x_n,T_n)...(x_1,T_1)].
    Inverse of [it_destLam] *)
 val compose_lam : (name * constr) list -> constr -> constr
 
-(* [to_lambda n l]
-   = $[x_1:T_1]...[x_n:T_n]T$
-   where $l = (x_1:T_1)...(x_n:T_n)T$ *)
+(** [to_lambda n l]
+   @return [fun (x_1:T_1)...(x_n:T_n) => T]
+   where [l] is [forall (x_1:T_1)...(x_n:T_n), T] *)
 val to_lambda : int -> constr -> constr
 
-(* [to_prod n l]
-   = $(x_1:T_1)...(x_n:T_n)T$
-   where $l = [x_1:T_1]...[x_n:T_n]T$ *)
+(** [to_prod n l]
+   @return [forall (x_1:T_1)...(x_n:T_n), T]
+   where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *)
 val to_prod : int -> constr -> constr
 
-(* pseudo-reduction rule *)
+(** pseudo-reduction rule *)
 
-(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *)
+(** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
 val prod_appvect : constr -> constr array -> constr
 val prod_applist : constr -> constr list -> constr
 
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
 val it_mkProd_or_LetIn : types -> rel_context -> types
 
-(*s Other term destructors. *)
+(** {6 Other term destructors. } *)
 
-(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair
-   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product.
+(** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair
+   {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product.
    It includes also local definitions *)
 val decompose_prod : constr -> (name*constr) list * constr
 
-(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair
-   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *)
+(** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair
+   {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *)
 val decompose_lam : constr -> (name*constr) list * constr
 
-(* 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)$. *)
+(** 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
-   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+(** 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
+(** 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 *)
+(** Idem with lambda's *)
 val decompose_lam_assum : constr -> rel_context * constr
 
-(* Idem but extract the first [n] premisses *)
+(** 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) *)
+(** [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) *)
+(** 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)*)
+(** 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 *)
+(** 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 *)
+(** 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) *)
+(** 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 *)
+(** flattens application lists *)
 val collapse_appl : constr -> constr
 
 
-(* Removes recursively the casts around a term i.e.
-   [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
+(** Removes recursively the casts around a term i.e.
+   [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
 val strip_outer_cast : constr -> constr
 
-(* Apply a function letting Casted types in place *)
+(** Apply a function letting Casted types in place *)
 val under_casts : (constr -> constr) -> constr -> constr
 
-(* Apply a function under components of Cast if any *)
+(** 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.
+(** {6 ... } *)
+(** 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 *)
+(** Build an "arity" from its canonical form *)
 val mkArity : arity -> types
 
-(* Destructs an "arity" into its canonical form *)
+(** Destructs an "arity" into its canonical form *)
 val destArity : types -> arity
 
-(* Tells if a term has the form of an arity *)
+(** Tells if a term has the form of an arity *)
 val isArity : types -> bool
 
-(*s Occur checks *)
+(** {6 Occur checks } *)
 
-(* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
 val closedn : int -> constr -> bool
 
-(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
 val closed0 : constr -> bool
 
-(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
+(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
 val noccurn : int -> constr -> bool
 
-(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
   for n <= p < n+m *)
 val noccur_between : int -> int -> constr -> bool
 
-(* Checking function for terms containing existential- or
+(** Checking function for terms containing existential- or
    meta-variables.  The function [noccur_with_meta] does not consider
    meta-variables applied to some terms (intended to be its local
    context) (for existential variables, it is necessarily the case) *)
 val noccur_with_meta : int -> int -> constr -> bool
 
-(*s Relocation and substitution *)
+(** {6 Relocation and substitution } *)
 
-(* [exliftn el c] lifts [c] with lifting [el] *)
+(** [exliftn el c] lifts [c] with lifting [el] *)
 val exliftn : Esubst.lift -> constr -> constr
 
-(* [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
+(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
 val liftn : int -> int -> constr -> constr
 
-(* [lift n c] lifts by [n] the positive indexes in [c] *)
+(** [lift n c] lifts by [n] the positive indexes in [c] *)
 val lift : int -> constr -> constr
 
-(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
     for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
     accordingly indexes in [a1],...,[an] *)
 val substnl : constr list -> int -> constr -> constr
@@ -539,29 +569,30 @@ val substl_named_decl : constr list -> named_declaration -> named_declaration
 val replace_vars : (identifier * constr) list -> constr -> constr
 val subst_var : identifier -> constr -> constr
 
-(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
    if two names are identical, the one of least indice is kept *)
 val subst_vars : identifier list -> constr -> constr
-(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+
+(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
    if two names are identical, the one of least indice is kept *)
 val substn_vars : int -> identifier list -> constr -> constr
 
 
-(*s Functionals working on the immediate subterm of a construction *)
+(** {6 Functionals working on the immediate subterm of a construction } *)
 
-(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+(** [fold_constr f acc c] folds [f] on the immediate subterms of [c]
    starting from [acc] and proceeding from left to right according to
    the usual representation of the constructions; it is not recursive *)
 
 val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
 
-(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+(** [map_constr f c] maps [f] on the immediate subterms of [c]; it is
    not recursive and the order with which subterms are processed is
    not specified *)
 
 val map_constr : (constr -> constr) -> constr -> constr
 
-(* [map_constr_with_binders g f n c] maps [f n] on the immediate
+(** [map_constr_with_binders g f n c] maps [f n] on the immediate
    subterms of [c]; it carries an extra data [n] (typically a lift
    index) which is processed by [g] (which typically add 1 to [n]) at
    each binder traversal; it is not recursive and the order with which
@@ -570,13 +601,13 @@ val map_constr : (constr -> constr) -> constr -> constr
 val map_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
 
-(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+(** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
    not recursive and the order with which subterms are processed is
    not specified *)
 
 val iter_constr : (constr -> unit) -> constr -> unit
 
-(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
+(** [iter_constr_with_binders g f n c] iters [f n] on the immediate
    subterms of [c]; it carries an extra data [n] (typically a lift
    index) which is processed by [g] (which typically add 1 to [n]) at
    each binder traversal; it is not recursive and the order with which
@@ -585,27 +616,20 @@ val iter_constr : (constr -> unit) -> constr -> unit
 val iter_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
 
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+(** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
    the immediate subterms of [c1] of [c2] if needed; Cast's, binders
    name and Cases annotations are not taken into account *)
 
 val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 
+val constr_ord : constr -> constr -> int
+val hash_constr : constr -> int
+
 (*********************************************************************)
 
-val hcons_constr:
-  (constant -> constant) *
-  (mutual_inductive -> mutual_inductive) *
-  (dir_path -> dir_path) *
-  (name -> name) *
-  (identifier -> identifier) *
-  (string -> string)
-  ->
-    (constr -> constr) *
-    (types -> types)
-
-val hcons1_constr : constr -> constr
-val hcons1_types : types -> types
+val hcons_sorts : sorts -> sorts
+val hcons_constr : constr -> constr
+val hcons_types : types -> types
 
 (**************************************)
 
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index c1eb97a6..478b9c6f 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -1,12 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+   the Coq module system *)
+
+(* This module provides the main entry points for type-checking basic
+   declarations *)
 
 open Util
 open Names
@@ -28,8 +32,9 @@ let constrain_type env j cst1 = function
   | 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);
-      NonPolymorphicType t, Constraint.union (Constraint.union cst1 cst2) cst3
+	assert (eq_constr t tj.utj_val);
+	let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in
+	  NonPolymorphicType t, cstrs
 
 let local_constrain_type env j cst1 = function
   | None ->
@@ -37,8 +42,8 @@ let local_constrain_type env j cst1 = function
   | 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);
-      t, Constraint.union (Constraint.union cst1 cst2) cst3
+      assert (eq_constr t tj.utj_val);
+      t, union_constraints (union_constraints cst1 cst2) cst3
 
 let translate_local_def env (b,topt) =
   let (j,cst) = infer env b in
@@ -88,13 +93,20 @@ let infer_declaration env dcl =
   match dcl with
   | DefinitionEntry c ->
       let (j,cst) = infer env c.const_entry_body in
+      let j =
+        {uj_val = hcons_constr j.uj_val;
+         uj_type = hcons_constr j.uj_type} in
       let (typ,cst) = constrain_type env j cst c.const_entry_type in
-      Some (Declarations.from_val j.uj_val), typ, cst,
-        c.const_entry_opaque, c.const_entry_boxed, false
-  | ParameterEntry (t,nl) ->
+      let def =
+	if c.const_entry_opaque
+	then OpaqueDef (Declarations.opaque_from_val j.uj_val)
+	else Def (Declarations.from_val j.uj_val)
+      in
+      def, typ, cst, c.const_entry_secctx
+  | ParameterEntry (ctx,t,nl) ->
       let (j,cst) = infer env t in
-      None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst,
-        false, false, nl
+      let t = hcons_constr (Typeops.assumption_of_judgment env j) in
+      Undef nl, NonPolymorphicType t, cst, ctx
 
 let global_vars_set_constant_type env = function
   | NonPolymorphicType t -> global_vars_set env t
@@ -104,25 +116,32 @@ let global_vars_set_constant_type env = function
 	  (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
-    | None -> global_vars_set_constant_type env typ
-    | Some 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
-  let hyps = keep_hyps env ids in
-    { const_hyps = hyps;
-      const_body = body;
-      const_type = typ;
-      const_body_code = tps;
-     (* const_type_code = to_patch env typ;*)
-      const_constraints = cst;
-      const_opaque = op;
-      const_inline = inline}
+let build_constant_declaration env kn (def,typ,cst,ctx) =
+  let hyps = 
+    let inferred =
+      let ids_typ = global_vars_set_constant_type env typ in
+      let ids_def = match def with
+      | Undef _ -> Idset.empty
+      | Def cs -> global_vars_set env (Declarations.force cs)
+      | OpaqueDef lc -> 
+          global_vars_set env (Declarations.force_opaque lc) in
+      keep_hyps env (Idset.union ids_typ ids_def) in
+    let declared = match ctx with
+      | None -> inferred 
+      | Some declared -> declared in
+    let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in
+    let inferred_set, declared_set = mk_set inferred, mk_set declared in
+    if not (Idset.subset inferred_set declared_set) then
+      error ("The following section variable are used but not declared:\n"^
+        (String.concat ", " (List.map string_of_id
+          (Idset.elements (Idset.diff inferred_set declared_set)))));
+    declared in
+  let tps = Cemitcodes.from_val (compile_constant_body env def) in
+  { const_hyps = hyps;
+    const_body = def;
+    const_type = typ;
+    const_body_code = tps;
+    const_constraints = cst }
 
 (*s Global and local constant declaration. *)
 
@@ -130,8 +149,9 @@ let translate_constant env kn ce =
   build_constant_declaration env kn (infer_declaration env ce)
 
 let translate_recipe env kn r =
-  build_constant_declaration env kn (Cooking.cook_constant env r)
+  build_constant_declaration env kn 
+    (let def,typ,cst = Cooking.cook_constant env r in def,typ,cst,None)
 
 (* Insertion of inductive types. *)
 
-let translate_mind env mie = check_inductive env mie
+let translate_mind env kn mie = check_inductive env kn mie
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 217c9f91..3bbf5667 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Univ
@@ -17,7 +14,6 @@ open Inductive
 open Environ
 open Entries
 open Typeops
-(*i*)
 
 val translate_local_def : env -> constr * types option ->
   constr * types * Univ.constraints
@@ -26,16 +22,16 @@ val translate_local_assum : env -> types ->
   types * Univ.constraints
 
 val infer_declaration : env -> constant_entry ->
-   constr_substituted option * constant_type * constraints * bool * bool * bool
+  constant_def * constant_type * constraints * Sign.section_context option
 
 val build_constant_declaration : env -> 'a ->
-    constr_substituted option * constant_type * constraints * bool * bool * bool ->
-      constant_body
+  constant_def * constant_type * constraints * Sign.section_context option -> 
+    constant_body
 
 val translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind :
-  env -> mutual_inductive_entry -> mutual_inductive_body
+  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
 
 val translate_recipe :
   env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 2e6b8d50..8f129999 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Sign
@@ -20,7 +18,7 @@ type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
   | CodomainNotInductiveType of constr
@@ -50,7 +48,7 @@ type type_error =
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * int * constr * constr
+  | IllFormedBranch of constr * constructor * constr * constr
   | Generalization of (name * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
@@ -111,4 +109,9 @@ let error_ill_formed_rec_body env why lna i fixenv vdefj =
 let error_ill_typed_rec_body env i lna vdefj vargs =
   raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
 
+let error_elim_explain kp ki =
+  match kp,ki with
+  | (InType | InSet), InProp -> NonInformativeToInformative
+  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
+  | _ -> WrongArity
 
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 989b8fbb..7c61e105 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Environ
-(*i*)
 
-(* Type errors. \label{typeerrors} *)
+(** Type errors. {% \label{%}typeerrors{% }%} *)
 
 (*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
     notation i*)
 type guard_error =
-  (* Fixpoints *)
+  (** Fixpoints *)
   | NotEnoughAbstractionInFixBody
   | RecursionNotOnInductiveType of constr
-  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
   | NotEnoughArgumentsForFixCall of int
-  (* CoFixpoints *)
+  (** CoFixpoints *)
   | CodomainNotInductiveType of constr
   | NestedRecursiveOccurrences
   | UnguardedRecursiveCall of constr
@@ -52,7 +48,7 @@ type type_error =
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * int * constr * constr
+  | IllFormedBranch of constr * constructor * constr * constr
   | Generalization of (name * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
@@ -82,7 +78,7 @@ val error_case_not_inductive : env -> unsafe_judgment -> 'a
 
 val error_number_branches : env -> unsafe_judgment -> int -> 'a
 
-val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
+val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a
 
 val error_generalization : env -> name * types -> unsafe_judgment -> 'a
 
@@ -101,3 +97,4 @@ val error_ill_formed_rec_body :
 val error_ill_typed_rec_body  :
   env -> int -> name array -> unsafe_judgment array -> types array -> 'a
 
+val error_elim_explain : sorts_family -> sorts_family -> arity_error
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 2fd02063..49106c91 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -20,8 +18,7 @@ open Reduction
 open Inductive
 open Type_errors
 
-let conv = default_conv CONV
-let conv_leq = default_conv CUMUL
+let conv_leq l2r = default_conv CUMUL ~l2r
 
 let conv_leq_vecti env v1 v2 =
   array_fold_left2_i
@@ -29,8 +26,8 @@ let conv_leq_vecti env v1 v2 =
       let c' =
         try default_conv CUMUL env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
-      Constraint.union c c')
-    Constraint.empty
+      union_constraints c c')
+    empty_constraint
     v1
     v2
 
@@ -47,8 +44,6 @@ let assumption_of_judgment env j =
   with TypeError _ ->
     error_assumption env j
 
-let sort_judgment env j = (type_judgment env j).utj_type
-
 (************************************************)
 (* Incremental typing rules: builds a typing judgement given the *)
 (* judgements for the subterms. *)
@@ -206,8 +201,8 @@ let judge_of_apply env funj argjv =
         (match kind_of_term (whd_betadeltaiota env typ) with
           | Prod (_,c1,c2) ->
 	      (try
-		let c = conv_leq env hj.uj_type c1 in
-		let cst' = Constraint.union cst c in
+		let c = conv_leq false env hj.uj_type c1 in
+		let cst' = union_constraints cst c in
 		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
 	      with NotConvertible ->
 		error_cant_apply_bad_type env
@@ -219,7 +214,7 @@ let judge_of_apply env funj argjv =
   in
   apply_rec 1
     funj.uj_type
-    Constraint.empty
+    empty_constraint
     (Array.to_list argjv)
 
 (* Type of product *)
@@ -270,11 +265,18 @@ 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 =
+    let c, cst =
       match k with
-      | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
-      | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
-    { uj_val = mkCast (cj.uj_val, k, expected_type);
+      | VMcast ->
+          mkCast (cj.uj_val, k, expected_type),
+          vm_conv CUMUL env cj.uj_type expected_type
+      | DEFAULTcast ->
+          mkCast (cj.uj_val, k, expected_type),
+          conv_leq false env cj.uj_type expected_type
+      | REVERTcast ->
+          cj.uj_val,
+          conv_leq true env cj.uj_type expected_type in
+    { uj_val = c;
       uj_type = expected_type },
     cst
   with NotConvertible ->
@@ -318,11 +320,11 @@ let judge_of_constructor env c =
 
 (* Case. *)
 
-let check_branch_types env cj (lfj,explft) =
+let check_branch_types env ind cj (lfj,explft) =
   try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
+        error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
@@ -333,11 +335,11 @@ let judge_of_case env ci pj cj lfj =
   let _ = check_case_info env (fst indspec) ci in
   let (bty,rslty,univ) =
     type_case_branches env indspec pj cj.uj_val in
-  let univ' = check_branch_types env cj (lfj,bty) in
+  let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in
   ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
                        Array.map j_val lfj);
      uj_type = rslty },
-  Constraint.union univ univ')
+  union_constraints univ univ')
 
 (* Fixpoints. *)
 
@@ -359,7 +361,7 @@ let type_fixpoint env lna lar vdefj =
    graph and in the universes of the environment. This is to ensure
    that the infered local graph is satisfiable. *)
 let univ_combinator (cst,univ) (j,c') =
-  (j,(Constraint.union cst c', merge_constraints c' univ))
+  (j,(union_constraints cst c', merge_constraints c' univ))
 
 (* The typing machine. *)
     (* ATTENTION : faudra faire le typage du contexte des Const,
@@ -476,23 +478,21 @@ 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)
-
 (* Derived functions *)
 let infer env constr =
   let (j,(cst,_)) =
-    execute env constr (Constraint.empty, universes env) in
-  assert (j.uj_val = constr);
-  ({ j with uj_val = constr }, cst)
+    execute env constr (empty_constraint, universes env) in
+  assert (eq_constr j.uj_val constr);
+  (j, cst)
 
 let infer_type env constr =
   let (j,(cst,_)) =
-    execute_type env constr (Constraint.empty, universes env) in
+    execute_type env constr (empty_constraint, universes env) in
   (j, cst)
 
 let infer_v env cv =
   let (jv,(cst,_)) =
-    execute_array env cv (Constraint.empty, universes env) in
+    execute_array env cv (empty_constraint, universes env) in
   (jv, cst)
 
 (* Typing of several terms. *)
@@ -510,8 +510,8 @@ let infer_local_decls env decls =
   | (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
-  | [] -> env, empty_rel_context, Constraint.empty in
+      push_rel d env, add_rel_decl d l, union_constraints cst1 cst2
+  | [] -> env, empty_rel_context, empty_constraint in
   inferec env decls
 
 (* Exported typing functions *)
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 6e922041..c1c805f3 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
 open Environ
 open Entries
 open Declarations
-(*i*)
 
-(*s Typing functions (not yet tagged as safe) *)
+(** {6 Typing functions (not yet tagged as safe) } *)
 
 val infer      : env -> constr       -> unsafe_judgment * constraints
 val infer_v    : env -> constr array -> unsafe_judgment array * constraints
@@ -27,56 +23,56 @@ val infer_local_decls :
   env -> (identifier * local_entry) list
     -> env * rel_context * constraints
 
-(*s Basic operations of the typing machine. *)
+(** {6 Basic operations of the typing machine. } *)
 
-(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j]
-   returns the type $c$, checking that $t$ is a sort. *)
+(** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j]
+   returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *)
 
 val assumption_of_judgment :  env -> unsafe_judgment -> types
 val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
 
-(*s Type of sorts. *)
+(** {6 Type of sorts. } *)
 val judge_of_prop_contents : contents -> unsafe_judgment
 val judge_of_type          : universe -> unsafe_judgment
 
-(*s Type of a bound variable. *)
+(** {6 Type of a bound variable. } *)
 val judge_of_relative : env -> int -> unsafe_judgment
 
-(*s Type of variables *)
+(** {6 Type of variables } *)
 val judge_of_variable : env -> variable -> unsafe_judgment
 
-(*s type of a constant *)
+(** {6 type of a constant } *)
 val judge_of_constant : env -> constant -> unsafe_judgment
 
 val judge_of_constant_knowing_parameters :
   env -> constant -> unsafe_judgment array -> unsafe_judgment
 
-(*s Type of application. *)
+(** {6 Type of application. } *)
 val judge_of_apply :
   env -> unsafe_judgment -> unsafe_judgment array
     -> unsafe_judgment * constraints
 
-(*s Type of an abstraction. *)
+(** {6 Type of an abstraction. } *)
 val judge_of_abstraction :
   env -> name -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
-(*s Type of a product. *)
+(** {6 Type of a product. } *)
 val judge_of_product :
   env -> name -> unsafe_type_judgment -> unsafe_type_judgment
     -> unsafe_judgment
 
-(* s Type of a let in. *)
+(** s Type of a let in. *)
 val judge_of_letin :
   env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
-(*s Type of a cast. *)
+(** {6 Type of a cast. } *)
 val judge_of_cast :
   env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
     unsafe_judgment * constraints
 
-(*s Inductive types. *)
+(** {6 Inductive types. } *)
 
 val judge_of_inductive : env -> inductive -> unsafe_judgment
 
@@ -85,16 +81,16 @@ val judge_of_inductive_knowing_parameters :
 
 val judge_of_constructor : env -> constructor -> unsafe_judgment
 
-(*s Type of Cases. *)
+(** {6 Type of Cases. } *)
 val judge_of_case : env -> case_info
   -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
     -> unsafe_judgment * constraints
 
-(* Typecheck general fixpoint (not checking guard conditions) *)
+(** Typecheck general fixpoint (not checking guard conditions) *)
 val type_fixpoint : env -> name array -> types array
     -> unsafe_judgment array -> constraints
 
-(* Kernel safe typing but applicable to partial proofs *)
+(** Kernel safe typing but applicable to partial proofs *)
 val typing : env -> constr -> unsafe_judgment
 
 val type_of_constant : env -> constant -> types
@@ -104,7 +100,7 @@ val type_of_constant_type : env -> constant_type -> types
 val type_of_constant_knowing_parameters :
   env -> constant_type -> constr array -> types
 
-(* Make a type polymorphic if an arity *)
+(** Make a type polymorphic if an arity *)
 val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
   constant_type
 
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 0646a501..a8934544 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -1,17 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
-(* Extension with algebraic universes by HH [Sep 2001] *)
+(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *)
+(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *)
+(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *)
 (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
 
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+
+open Pp
+open Util
+
 (* Universes are stratified by a partial ordering $\le$.
    Let $\~{}$ be the associated equivalence. We also have a strict ordering
    $<$ between equivalence classes, and we maintain that $<$ is acyclic,
@@ -24,11 +28,40 @@
    union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
-open Pp
-open Util
+module UniverseLevel = struct
+
+  type t =
+    | Set
+    | Level of Names.dir_path * int
+
+  (* A specialized comparison function: we compare the [int] part
+     first (this property is used by the [check_sorted] function
+     below). This way, most of the time, the [dir_path] part is not
+     considered. *)
+
+  let compare u v = match u,v with
+    | Set, Set -> 0
+    | Set, _ -> -1
+    | _, Set -> 1
+    | Level (dp1, i1), Level (dp2, i2) ->
+      if i1 < i2 then -1
+      else if i1 > i2 then 1
+      else compare dp1 dp2
+
+  let to_string = function
+    | Set -> "Set"
+    | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+end
+
+module UniverseLMap = Map.Make (UniverseLevel)
+module UniverseLSet = Set.Make (UniverseLevel)
+
+type universe_level = UniverseLevel.t
+
+let compare_levels = UniverseLevel.compare
 
 (* An algebraic universe [universe] is either a universe variable
-   [universe_level] or a formal universe known to be greater than some
+   [UniverseLevel.t] or a formal universe known to be greater than some
    universe variables and strictly greater than some (other) universe
    variables
 
@@ -37,38 +70,21 @@ open Util
    universes inferred while type-checking: it is either the successor
    of a universe present in the initial term to type-check or the
    maximum of two algebraic universes
- *)
-
-type universe_level =
-  | Set
-  | Level of Names.dir_path * int
-
-(* A specialized comparison function: we compare the [int] part first.
-   This way, most of the time, the [dir_path] part is not considered. *)
-
-let cmp_univ_level u v = match u,v with
-  | Set, Set -> 0
-  | Set, _ -> -1
-  | _, Set -> 1
-  | Level (dp1,i1), Level (dp2,i2) ->
-      if i1 < i2 then -1
-      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
+  | Atom of UniverseLevel.t
+  | Max of UniverseLevel.t list * UniverseLevel.t list
+
+let make_universe_level (m,n) = UniverseLevel.Level (m,n)
+let make_universe l = Atom l
+let make_univ c = Atom (make_universe_level c)
 
-let make_univ (m,n) = Atom (Level (m,n))
+let universe_level = function
+  | Atom l -> Some l
+  | Max _ -> None
 
-let pr_uni_level u = str (string_of_univ_level u)
+let pr_uni_level u = str (UniverseLevel.to_string u)
 
 let pr_uni = function
   | Atom u ->
@@ -97,7 +113,7 @@ let super = function
 let sup u v =
   match u,v with
     | Atom u, Atom v ->
-	if cmp_univ_level u v = 0 then Atom u else Max ([u;v],[])
+	if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[])
     | u, Max ([],[]) -> u
     | Max ([],[]), v -> v
     | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
@@ -109,16 +125,16 @@ let sup u v =
 
 (* Comparison on this type is pointer equality *)
 type canonical_arc =
-    { univ: universe_level; lt: universe_level list; le: universe_level list }
+    { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list }
 
 let terminal u = {univ=u; lt=[]; le=[]}
 
-(* A universe_level is either an alias for another one, or a canonical one,
+(* A UniverseLevel.t is either an alias for another one, or a canonical one,
    for which we know the universes that are above *)
 
 type univ_entry =
     Canonical of canonical_arc
-  | Equiv of universe_level
+  | Equiv of UniverseLevel.t
 
 
 type universes = univ_entry UniverseLMap.t
@@ -129,12 +145,6 @@ let enter_equiv_arc u v g =
 let enter_arc ca g =
   UniverseLMap.add ca.univ (Canonical ca) g
 
-let declare_univ u g =
-  if not (UniverseLMap.mem u g) then
-    enter_arc (terminal u) g
-  else
-    g
-
 (* The lower predicative level of the hierarchy that contains (impredicative)
    Prop and singleton inductive types *)
 let type0m_univ = Max ([],[])
@@ -144,28 +154,30 @@ let is_type0m_univ = function
   | _ -> false
 
 (* The level of predicative Set *)
-let type0_univ = Atom Set
+let type0_univ = Atom UniverseLevel.Set
 
 let is_type0_univ = function
-  | Atom Set -> true
-  | Max ([Set],[]) -> warning "Non canonical Set"; true
+  | Atom UniverseLevel.Set -> true
+  | Max ([UniverseLevel.Set], []) -> warning "Non canonical Set"; true
   | u -> false
 
 let is_univ_variable = function
-  | Atom a when a<>Set -> true
+  | Atom a when a<>UniverseLevel.Set -> true
   | _ -> false
 
 (* When typing [Prop] and [Set], there is no constraint on the level,
    hence the definition of [type1_univ], the type of [Prop] *)
 
-let type1_univ = Max ([],[Set])
+let type1_univ = Max ([], [UniverseLevel.Set])
 
 let initial_universes = UniverseLMap.empty
+let is_initial_universes = UniverseLMap.is_empty
 
-(* Every universe_level has a unique canonical arc representative *)
+(* Every UniverseLevel.t has a unique canonical arc representative *)
 
-(* repr : universes -> universe_level -> canonical_arc *)
+(* repr : universes -> UniverseLevel.t -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
+
 let repr g u =
   let rec repr_rec u =
     let a =
@@ -181,6 +193,20 @@ let repr g u =
 
 let can g = List.map (repr g)
 
+(* [safe_repr] also search for the canonical representative, but
+   if the graph doesn't contain the searched universe, we add it. *)
+
+let safe_repr g u =
+  let rec safe_repr_rec u =
+    match UniverseLMap.find u g with
+      | Equiv v -> safe_repr_rec v
+      | Canonical arc -> arc
+  in
+  try g, safe_repr_rec u
+  with Not_found ->
+    let can = terminal u in
+    enter_arc can g, can
+
 (* reprleq : canonical_arc -> canonical_arc list *)
 (* All canonical arcv such that arcu<=arcv with arcv#arcu *)
 let reprleq g arcu =
@@ -196,11 +222,11 @@ let reprleq g arcu =
   searchrec [] arcu.le
 
 
-(* between : universe_level -> canonical_arc -> canonical_arc list *)
+(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *)
 (* between u v = {w|u<=w<=v, w canonical}          *)
 (* between is the most costly operation *)
 
-let between g u arcv =
+let between g arcu arcv =
   (* good are all w | u <= w <= v  *)
   (* bad are all w | u <= w ~<= v *)
     (* find good and bad nodes in {w | u <= w} *)
@@ -221,7 +247,7 @@ let between g u arcv =
 	else
 	  good, arcu::bad, b    (* b or false *)
   in
-  let good,_,_ = explore ([arcv],[],false) (repr g u) in
+  let good,_,_ = explore ([arcv],[],false) arcu in
     good
 
 (* We assume  compare(u,v) = LE with v canonical (see compare below).
@@ -272,9 +298,7 @@ let compare_neq g arcu arcv =
   in
   cmp [] [] ([],[arcu])
 
-let compare g u v =
-  let arcu = repr g u
-  and arcv = repr g v in
+let compare g arcu arcv =
   if arcu == arcv then EQ else compare_neq g arcu arcv
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
@@ -286,11 +310,12 @@ let compare g u v =
    Adding u>v is consistent iff compare(v,u) = NLE
     and then it is redundant iff compare(u,v) = LT *)
 
-let compare_eq g u v =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  repr g u == repr g v
+(** * Universe checks [check_eq] and [check_geq], used in coqchk *)
 
+let compare_eq g u v =
+  let g, arcu = safe_repr g u in
+  let _, arcv = safe_repr g v in
+  arcu == arcv
 
 type check_function = universes -> universe -> universe -> bool
 
@@ -310,10 +335,10 @@ let rec check_eq g u v =
     | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
 
 let compare_greater g strict u v =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  if not strict && compare_eq g v Set then true else
-  match compare g v u with
+  let g, arcu = safe_repr g u in
+  let g, arcv = safe_repr g v in
+  if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else
+  match compare g arcv arcu with
     | (EQ|LE) -> not strict
     | LT -> true
     | NLE -> false
@@ -323,44 +348,50 @@ let compare_greater g strict u v =
   ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
   b
 *)
-let rec check_greater g strict u v =
+let check_geq g u v =
   match u, v with
-    | Atom ul, Atom vl -> compare_greater g strict ul vl
+    | Atom ul, Atom vl -> compare_greater g false ul vl
     | Atom ul, Max(le,lt) ->
-        List.for_all (fun vl -> compare_greater g strict ul vl) le &&
+        List.for_all (fun vl -> compare_greater g false ul vl) le &&
         List.for_all (fun vl -> compare_greater g true ul vl) lt
     | _ -> anomaly "check_greater"
 
-let check_geq g = check_greater g false
+(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
 
-(* setlt : universe_level -> universe_level -> unit *)
+(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* forces u > v *)
-let setlt g u v =
-  let arcu = repr g u in
-  enter_arc {arcu with lt=v::arcu.lt} g
+(* this is normally an update of u in g rather than a creation. *)
+let setlt g arcu arcv =
+  let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
+  enter_arc arcu' g, arcu'
 
 (* checks that non-redundant *)
-let setlt_if g u v = match compare g u v with
-  | LT -> g
-  | _ -> setlt g u v
+let setlt_if (g,arcu) v =
+  let arcv = repr g v in
+  match compare g arcu arcv with
+  | LT -> g, arcu
+  | _ -> setlt g arcu arcv
 
-(* setleq : universe_level -> universe_level -> unit *)
+(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* forces u >= v *)
-let setleq g u v =
-  let arcu = repr g u in
-  enter_arc {arcu with le=v::arcu.le} g
+(* this is normally an update of u in g rather than a creation. *)
+let setleq g arcu arcv =
+  let arcu' = {arcu with le=arcv.univ::arcu.le} in
+  enter_arc arcu' g, arcu'
 
 
 (* checks that non-redundant *)
-let setleq_if g u v = match compare g u v with
-  | NLE -> setleq g u v
-  | _ -> g
+let setleq_if (g,arcu) v =
+  let arcv = repr g v in
+  match compare g arcu arcv with
+  | NLE -> setleq g arcu arcv
+  | _ -> g, arcu
 
-(* merge : universe_level -> universe_level -> unit *)
+(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* we assume  compare(u,v) = LE *)
 (* merge u v  forces u ~ v with repr u as canonical repr *)
-let merge g u v =
-  match between g u (repr g v) with
+let merge g arcu arcv =
+  match between g arcu arcv with
     | arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
                  (* redirected to it *)
 	let redirect (g,w,w') arcv =
@@ -368,87 +399,84 @@ let merge g u v =
  	  (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
-	let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in
-	g'''
+	let g_arcu = (g',arcu) in
+	let g_arcu = List.fold_left setlt_if g_arcu w in
+	let g_arcu = List.fold_left setleq_if g_arcu w' in
+	fst g_arcu
     | [] -> anomaly "Univ.between"
 
-(* merge_disc : universe_level -> universe_level -> unit *)
+(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* we assume  compare(u,v) = compare(v,u) = NLE *)
 (* merge_disc u v  forces u ~ v with repr u as canonical repr *)
-let merge_disc g u v =
-  let arcu = repr g u in
-  let arcv = repr g v in
+let merge_disc g arcu arcv =
   let g' = enter_equiv_arc arcv.univ arcu.univ g in
-  let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in
-  let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in
-  g'''
+  let g_arcu = (g',arcu) in
+  let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
+  let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
+  fst g_arcu
 
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
 
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
 
 let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v))
 
-(* enforce_univ_leq : universe_level -> universe_level -> unit *)
+(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
 let enforce_univ_leq u v g =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  match compare g u v with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | NLE ->
-	(match compare g v u with
+	(match compare g arcv arcu with
            | LT -> error_inconsistency Le u v
-           | LE -> merge g v u
-           | NLE -> setleq g u v
+           | LE -> merge g arcv arcu
+           | NLE -> fst (setleq g arcu arcv)
            | EQ -> anomaly "Univ.compare")
     | _ -> g
 
-(* enforc_univ_eq : universe_level -> universe_level -> unit *)
+(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
 (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
 let enforce_univ_eq u v g =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  match compare g u v with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | EQ -> g
     | LT -> error_inconsistency Eq u v
-    | LE -> merge g u v
+    | LE -> merge g arcu arcv
     | NLE ->
-	(match compare g v u with
+	(match compare g arcv arcu with
            | LT -> error_inconsistency Eq u v
-           | LE -> merge g v u
-           | NLE -> merge_disc g u v
+           | LE -> merge g arcv arcu
+           | NLE -> merge_disc g arcu arcv
            | EQ -> anomaly "Univ.compare")
 
 (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
 let enforce_univ_lt u v g =
-  let g = declare_univ u g in
-  let g = declare_univ v g in
-  match compare g u v with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  match compare g arcu arcv with
     | LT -> g
-    | LE -> setlt g u v
+    | LE -> fst (setlt g arcu arcv)
     | EQ -> error_inconsistency Lt u v
     | NLE ->
-	(match compare g v u with
-           | NLE -> setlt g u v
+	(match compare g arcv arcu with
+           | NLE -> fst (setlt g arcu arcv)
            | _ -> error_inconsistency Lt u v)
 
 (* Constraints and sets of consrtaints. *)
 
-type constraint_type = Lt | Leq | Eq
-
-type univ_constraint = universe_level * constraint_type * universe_level
+type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t
 
 let enforce_constraint cst g =
   match cst with
     | (u,Lt,v) -> enforce_univ_lt u v g
-    | (u,Leq,v) -> enforce_univ_leq u v g
+    | (u,Le,v) -> enforce_univ_leq u v g
     | (u,Eq,v) -> enforce_univ_eq u v g
 
-
 module Constraint = Set.Make(
   struct
     type t = univ_constraint
@@ -457,11 +485,16 @@ module Constraint = Set.Make(
 
 type constraints = Constraint.t
 
+let empty_constraint = Constraint.empty
+let is_empty_constraint = Constraint.is_empty
+
+let union_constraints = Constraint.union
+
 type constraint_function =
     universe -> universe -> constraints -> constraints
 
 let constraint_add_leq v u c =
-  if v = Set then c else Constraint.add (v,Leq,u) c
+  if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c
 
 let enforce_geq u v c =
   match u, v with
@@ -479,13 +512,207 @@ let enforce_eq u v c =
 let merge_constraints c g =
   Constraint.fold enforce_constraint c g
 
+(* Normalization *)
+
+let lookup_level u g =
+  try Some (UniverseLMap.find u g) with Not_found -> None
+
+(** [normalize_universes g] returns a graph where all edges point
+    directly to the canonical representent of their target. The output
+    graph should be equivalent to the input graph from a logical point
+    of view, but optimized. We maintain the invariant that the key of
+    a [Canonical] element is its own name, by keeping [Equiv] edges
+    (see the assertion)... I (Stéphane Glondu) am not sure if this
+    plays a role in the rest of the module. *)
+let normalize_universes g =
+  let rec visit u arc cache = match lookup_level u cache with
+    | Some x -> x, cache
+    | None -> match Lazy.force arc with
+    | None ->
+      u, UniverseLMap.add u u cache
+    | Some (Canonical {univ=v; lt=_; le=_}) ->
+      v, UniverseLMap.add u v cache
+    | Some (Equiv v) ->
+      let v, cache = visit v (lazy (lookup_level v g)) cache in
+      v, UniverseLMap.add u v cache
+  in
+  let cache = UniverseLMap.fold
+    (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
+    g UniverseLMap.empty
+  in
+  let repr x = UniverseLMap.find x cache in
+  let lrepr us = List.fold_left
+    (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us
+  in
+  let canonicalize u = function
+    | Equiv _ -> Equiv (repr u)
+    | Canonical {univ=v; lt=lt; le=le} ->
+      assert (u == v);
+      (* avoid duplicates and self-loops *)
+      let lt = lrepr lt and le = lrepr le in
+      let le = UniverseLSet.filter
+        (fun x -> x != u && not (UniverseLSet.mem x lt)) le
+      in
+      UniverseLSet.iter (fun x -> assert (x != u)) lt;
+      Canonical {
+        univ = v;
+        lt = UniverseLSet.elements lt;
+        le = UniverseLSet.elements le;
+      }
+  in
+  UniverseLMap.mapi canonicalize g
+
+(** [check_sorted g sorted]: [g] being a universe graph, [sorted]
+    being a map to levels, checks that all constraints in [g] are
+    satisfied in [sorted]. *)
+let check_sorted g sorted =
+  let get u = try UniverseLMap.find u sorted with
+    | Not_found -> assert false
+  in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with
+    | Equiv v -> assert (lu = get v)
+    | Canonical {univ=u'; lt=lt; le=le} ->
+      assert (u == u');
+      List.iter (fun v -> assert (lu <= get v)) le;
+      List.iter (fun v -> assert (lu < get v)) lt) g
+
+(**
+  Bellman-Ford algorithm with a few customizations:
+    - [weight(eq|le) = 0], [weight(lt) = -1]
+    - a [le] edge is initially added from [bottom] to all other
+      vertices, and [bottom] is used as the source vertex
+*)
+let bellman_ford bottom g =
+  assert (lookup_level bottom g = None);
+  let ( << ) a b = match a, b with
+    | _, None -> true
+    | None, _ -> false
+    | Some x, Some y -> x < y
+  and ( ++ ) a y = match a with
+    | None -> None
+    | Some x -> Some (x-y)
+  and push u x m = match x with
+    | None -> m
+    | Some y -> UniverseLMap.add u y m
+  in
+  let relax u v uv distances =
+    let x = lookup_level u distances ++ uv in
+    if x << lookup_level v distances then push v x distances
+    else distances
+  in
+  let init = UniverseLMap.add bottom 0 UniverseLMap.empty in
+  let vertices = UniverseLMap.fold (fun u arc res ->
+    let res = UniverseLSet.add u res in
+    match arc with
+      | Equiv e -> UniverseLSet.add e res
+      | Canonical {univ=univ; lt=lt; le=le} ->
+        assert (u == univ);
+        let add res v = UniverseLSet.add v res in
+        let res = List.fold_left add res le in
+        let res = List.fold_left add res lt in
+        res) g UniverseLSet.empty
+  in
+  let g =
+    let node = Canonical {
+      univ = bottom;
+      lt = [];
+      le = UniverseLSet.elements vertices
+    } in UniverseLMap.add bottom node g
+  in
+  let rec iter count accu =
+    if count <= 0 then
+      accu
+    else
+      let accu = UniverseLMap.fold (fun u arc res -> match arc with
+        | Equiv e -> relax e u 0 (relax u e 0 res)
+        | Canonical {univ=univ; lt=lt; le=le} ->
+          assert (u == univ);
+          let res = List.fold_left (fun res v -> relax u v 0 res) res le in
+          let res = List.fold_left (fun res v -> relax u v 1 res) res lt in
+          res) g accu
+      in iter (count-1) accu
+  in
+  let distances = iter (UniverseLSet.cardinal vertices) init in
+  let () = UniverseLMap.iter (fun u arc ->
+    let lu = lookup_level u distances in match arc with
+      | Equiv v ->
+        let lv = lookup_level v distances in
+        assert (not (lu << lv) && not (lv << lu))
+      | Canonical {univ=univ; lt=lt; le=le} ->
+        assert (u == univ);
+        List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le;
+        List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g
+  in distances
+
+(** [sort_universes g] builds a map from universes in [g] to natural
+    numbers. It outputs a graph containing equivalence edges from each
+    level appearing in [g] to [Type.n], and [lt] edges between the
+    [Type.n]s. The output graph should imply the input graph (and the
+    implication will be strict most of the time), but is not
+    necessarily minimal. Note: the result is unspecified if the input
+    graph already contains [Type.n] nodes (calling a module Type is
+    probably a bad idea anyway). *)
+let sort_universes orig =
+  let mp = Names.make_dirpath [Names.id_of_string "Type"] in
+  let rec make_level accu g i =
+    let type0 = UniverseLevel.Level (mp, i) in
+    let distances = bellman_ford type0 g in
+    let accu, continue = UniverseLMap.fold (fun u x (accu, continue) ->
+      let continue = continue || x < 0 in
+      let accu =
+        if x = 0 && u != type0 then UniverseLMap.add u i accu
+        else accu
+      in accu, continue) distances (accu, false)
+    in
+    let filter x = not (UniverseLMap.mem x accu) in
+    let push g u =
+      if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g
+    in
+    let g = UniverseLMap.fold (fun u arc res -> match arc with
+      | Equiv v as x ->
+        begin match filter u, filter v with
+          | true, true -> UniverseLMap.add u x res
+          | true, false -> push res u
+          | false, true -> push res v
+          | false, false -> res
+        end
+      | Canonical {univ=v; lt=lt; le=le} ->
+        assert (u == v);
+        if filter u then
+          let lt = List.filter filter lt in
+          let le = List.filter filter le in
+          UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res
+        else
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
+          res) g UniverseLMap.empty
+    in
+    if continue then make_level accu g (i+1) else i, accu
+  in
+  let max, levels = make_level UniverseLMap.empty orig 0 in
+  (* defensively check that the result makes sense *)
+  check_sorted orig levels;
+  let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
+  let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
+  let g =
+    let rec aux i g =
+      if i < max then
+        let u = types.(i) in
+        let g = UniverseLMap.add u (Canonical {
+          univ = u;
+          le = [];
+          lt = [types.(i+1)]
+        }) g in aux (i+1) g
+      else g
+    in aux 0 g
+  in g
+
 (**********************************************************************)
 (* Tools for sort-polymorphic inductive types                         *)
 
 (* Temporary inductive type levels *)
 
 let fresh_level =
-  let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n)
+  let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n)
 
 let fresh_local_univ () = Atom (fresh_level ())
 
@@ -559,16 +786,6 @@ let no_upper_constraints u cst =
 
 (* Pretty-printing *)
 
-let num_universes g =
-  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
-  UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0
-
 let pr_arc = function
   | _, Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
@@ -590,7 +807,7 @@ let pr_constraints c =
   Constraint.fold (fun (u1,op,u2) pp_std ->
 		     let op_str = match op with
 		       | Lt -> " < "
-		       | Leq -> " <= "
+		       | Le -> " <= "
 		       | Eq -> " = "
 		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
 			  pr_uni_level u2 ++ fnl () )  c (str "")
@@ -600,37 +817,40 @@ let pr_constraints c =
 let dump_universes output g =
   let dump_arc u = function
     | Canonical {univ=u; lt=lt; le=le} ->
-	let u_str = string_of_univ_level u in
-	  List.iter
-	    (fun v ->
-	       Printf.fprintf output "%s < %s ;\n" u_str
-		 (string_of_univ_level v))
-	    lt;
-	  List.iter
-	    (fun v ->
-	       Printf.fprintf output "%s <= %s ;\n" u_str
-		 (string_of_univ_level v))
-	    le
+	let u_str = UniverseLevel.to_string u in
+	List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt;
+	List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le
     | Equiv v ->
-	Printf.fprintf output "%s = %s ;\n"
-	  (string_of_univ_level u) (string_of_univ_level v)
+      output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v)
   in
     UniverseLMap.iter dump_arc g
 
 (* Hash-consing *)
 
+module Hunivlevel =
+  Hashcons.Make(
+    struct
+      type t = universe_level
+      type u = Names.dir_path -> Names.dir_path
+      let hash_sub hdir = function
+	| UniverseLevel.Set -> UniverseLevel.Set
+	| UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n)
+      let equal l1 l2 = match l1,l2 with
+	| UniverseLevel.Set, UniverseLevel.Set -> true
+	| UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') ->
+	  n == n' && d == d'
+	| _ -> false
+      let hash = Hashtbl.hash
+    end)
+
 module Huniv =
   Hashcons.Make(
     struct
       type t = universe
-      type u = Names.dir_path -> Names.dir_path
-      let hash_aux hdir = function
-	| Set -> Set
-	| Level (d,n) -> Level (hdir d,n)
+      type u = universe_level -> universe_level
       let hash_sub hdir = function
-	| Atom u -> Atom (hash_aux hdir u)
-	| Max (gel,gtl) ->
-	    Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
+	| Atom u -> Atom (hdir u)
+	| Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl)
       let equal u v =
 	match u, v with
 	  | Atom u, Atom v -> u == v
@@ -641,7 +861,33 @@ module Huniv =
       let hash = Hashtbl.hash
     end)
 
-let hcons1_univ u =
-  let _,_,hdir,_,_,_ = Names.hcons_names() in
-  Hashcons.simple_hcons Huniv.f hdir u
+let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath
+let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel
+
+module Hconstraint =
+  Hashcons.Make(
+    struct
+      type t = univ_constraint
+      type u = universe_level -> universe_level
+      let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2)
+      let equal (l1,k,l2) (l1',k',l2') =
+	l1 == l1' && k = k' && l2 == l2'
+      let hash = Hashtbl.hash
+    end)
+
+module Hconstraints =
+  Hashcons.Make(
+    struct
+      type t = constraints
+      type u = univ_constraint -> univ_constraint
+      let hash_sub huc s =
+	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
+      let equal s s' =
+	list_for_all2eq (==)
+	  (Constraint.elements s)
+	  (Constraint.elements s')
+      let hash = Hashtbl.hash
+    end)
 
+let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel
+let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 4cb6dec1..8b3f6291 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -1,37 +1,43 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Universes. *)
+(** Universes. *)
 
+type universe_level
 type universe
 
-(* The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... *)
-(* Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+module UniverseLSet : Set.S with type elt = universe_level
+
+(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... 
+   Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
 
-val type0m_univ : universe  (* image of Prop in the universes hierarchy *)
-val type0_univ : universe  (* image of Set in the universes hierarchy *)
-val type1_univ : universe  (* the universe of the type of Prop/Set *)
+val type0m_univ : universe  (** image of Prop in the universes hierarchy *)
+val type0_univ : universe  (** image of Set in the universes hierarchy *)
+val type1_univ : universe  (** the universe of the type of Prop/Set *)
 
+val make_universe_level : Names.dir_path * int -> universe_level
+val make_universe : universe_level -> universe
 val make_univ : Names.dir_path * int -> universe
 
 val is_type0_univ : universe -> bool
 val is_type0m_univ : universe -> bool
 val is_univ_variable : universe -> bool
 
-(* The type of a universe *)
+val universe_level : universe -> universe_level option
+val compare_levels : universe_level -> universe_level -> int
+
+(** The type of a universe *)
 val super : universe -> universe
 
-(* The max of 2 universes *)
+(** The max of 2 universes *)
 val sup   : universe -> universe -> universe
 
-(*s Graphs of universes. *)
+(** {6 Graphs of universes. } *)
 
 type universes
 
@@ -39,32 +45,39 @@ type check_function = universes -> universe -> universe -> bool
 val check_geq : check_function
 val check_eq : check_function
 
-(* The empty graph of universes *)
+(** The empty graph of universes *)
 val initial_universes : universes
+val is_initial_universes : universes -> bool
 
-(*s Constraints. *)
+(** {6 Constraints. } *)
 
-module Constraint : Set.S
+type constraints
 
-type constraints = Constraint.t
+val empty_constraint : constraints
+val union_constraints : constraints -> constraints -> constraints
+
+val is_empty_constraint : constraints -> bool
 
 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.
+(** {6 ... } *)
+(** Merge of constraints in a universes graph.
   The function [merge_constraints] merges a set of constraints in a given
   universes graph. It raises the exception [UniverseInconsistency] if the
   constraints are not satisfiable. *)
 
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
 
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
 
 val merge_constraints : constraints -> universes -> universes
+val normalize_universes : universes -> universes
+val sort_universes : universes -> universes
 
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
 
 val fresh_local_univ : unit -> universe
 
@@ -78,14 +91,21 @@ val subst_large_constraints :
 
 val no_upper_constraints : universe -> constraints -> bool
 
-(*s Pretty-printing of universes. *)
+(** {6 Pretty-printing of universes. } *)
 
+val pr_uni_level : universe_level -> Pp.std_ppcmds
 val pr_uni : universe -> Pp.std_ppcmds
 val pr_universes : universes -> Pp.std_ppcmds
 val pr_constraints : constraints -> Pp.std_ppcmds
 
-(*s Dumping to a file *)
+(** {6 Dumping to a file } *)
+
+val dump_universes :
+  (constraint_type -> string -> string -> unit) ->
+  universes -> unit
 
-val dump_universes : out_channel -> universes -> unit
+(** {6 Hash-consing } *)
 
-val hcons1_univ : universe -> universe
+val hcons_univlevel : universe_level -> universe_level
+val hcons_univ : universe -> universe
+val hcons_constraints : constraints -> constraints
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index a35d1d88..4d0edc68 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -74,6 +74,8 @@ and conv_whd pb k whd1 whd2 cu =
       else raise NotConvertible
   | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
       conv_atom pb k a1 stk1 a2 stk2 cu
+  | Vfun _, _ | _, Vfun _ ->
+      conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
   | _, Vatom_stk(Aiddef(_,v),stk) ->
       conv_whd pb k whd1 (force_whd v stk) cu
   | Vatom_stk(Aiddef(_,v),stk), _ ->
@@ -98,7 +100,7 @@ and conv_atom pb k a1 stk1 a2 stk2 cu =
 	    conv_stack k stk1 stk2 cu
 	  else raise NotConvertible
 	with NotConvertible ->
-	  if oracle_order ik1 ik2 then
+	  if oracle_order false ik1 ik2 then
             conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
           else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
       end
@@ -219,12 +221,12 @@ and conv_eq_vect vt1 vt2 cu =
 
 let vconv pb env t1 t2 =
   let cu =
-    try conv_eq pb t1 t2 Constraint.empty
+    try conv_eq pb t1 t2 empty_constraint
     with NotConvertible ->
       infos := create_clos_infos betaiotazeta env;
       let v1 = val_of_constr env t1 in
       let v2 = val_of_constr env t2 in
-      let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
+      let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in
       cu
   in cu
 
@@ -234,8 +236,8 @@ let use_vm = ref false
 
 let set_use_vm b =
   use_vm := b;
-  if b then Reduction.set_default_conv vconv
-  else Reduction.set_default_conv Reduction.conv_cmp
+  if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb)
+  else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb)
 
 let use_vm _ = !use_vm
 
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index e23aaf79..2d65170c 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
 open Names
 open Term
 open Environ
 open Reduction
-(*i*)
 
-(***********************************************************************)
-(*s conversion functions *)
+(**********************************************************************
+  s conversion functions *)
 val use_vm : unit -> bool
 val set_use_vm : bool -> unit
 val vconv : conv_pb -> types conversion_function
diff --git a/kernel/vm.ml b/kernel/vm.ml
index c24de162..86aed5d9 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vm.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Conv_oracle
@@ -462,7 +460,7 @@ let current_cofix vcf =
       else find_cofix (pos+1)
     else raise Not_found in
   try find_cofix 0
-  with _ -> assert false
+  with Not_found -> assert false
 
 let check_cofix vcf1 vcf2 =
   (current_cofix vcf1 = current_cofix vcf2) &&
@@ -538,13 +536,8 @@ let branch_of_switch k sw =
   Array.map eval_branch sw.sw_annot.rtbl
 
 
-(* Evaluation *)
-
 
-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
+(* Evaluation *)
 
 let rec whd_stack v stk =
   match stk with
@@ -594,6 +587,55 @@ let rec force_whd v stk =
   | res -> res
 
 
+let rec eta_stack a stk v =
+  match stk with
+  | [] -> apply_vstack a [|v|]
+  | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v
+  | Zfix(f,args) :: stk ->
+      let a,stk = 
+	match stk with
+	| Zapp args' :: stk ->
+	    push_ra stop;
+	    push_arguments args';
+	    push_val a;
+	    push_arguments args;
+	    let a =
+	      interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+		(nargs args+ nargs args') in
+	    a, stk
+	| _ -> 
+	    push_ra stop;
+	    push_val a;
+	    push_arguments args;
+	    let a =
+	      interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+		(nargs args) in
+	    a, stk in
+      eta_stack a stk v
+  | Zswitch sw :: stk ->
+      eta_stack (apply_switch sw a) stk v
+
+let eta_whd k whd =
+  let v = val_of_rel k in
+  match whd with
+  | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false
+  | Vfun f -> body_of_vfun k f
+  | Vfix(f, None) -> 
+      push_ra stop;
+      push_val v;
+      interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0
+  | Vfix(f, Some args) ->
+      push_ra stop;
+      push_val v;
+      push_arguments args;
+      interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) 
+  | Vcofix(_,to_up,_) ->
+      push_ra stop;
+      push_val v;
+      interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0
+  | Vatom_stk(a,stk) ->
+      eta_stack (val_of_atom a) stk v 
 
 
-
+      
+      
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 5ecc8d99..58228eb8 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -3,15 +3,18 @@ open Term
 open Cbytecodes
 open Cemitcodes
 
+(** Efficient Virtual Machine *)
 
 val set_drawinstr : unit -> unit
 
 val transp_values : unit -> bool
 val set_transp_values : bool -> unit
-(* le code machine *)
+
+(** Machine code *)
+
 type tcode
 
-(* Les valeurs ***********)
+(** Values *)
 
 type vprod
 type vfun
@@ -26,11 +29,11 @@ type atom =
   | Aiddef of id_key * values
   | Aind of inductive
 
-(* Les zippers *)
+(** Zippers *)
 
 type zipper =
   | Zapp of arguments
-  | Zfix of vfix*arguments  (* Peut-etre vide *)
+  | Zfix of vfix * arguments  (** might be empty *)
   | Zswitch of vswitch
 
 type stack = zipper list
@@ -48,6 +51,7 @@ type whd =
   | Vatom_stk of atom * stack
 
 (** Constructors *)
+
 val val_of_str_const : structured_constant -> values
 
 val val_of_rel : int -> values
@@ -62,45 +66,56 @@ 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
 
-(* Product *)
+(** Product *)
+
 val dom : vprod -> values
 val codom : vprod -> vfun
 
-(* Function *)
+(** Function *)
+
 val body_of_vfun : int -> vfun -> values
 val decompose_vfun2  : int -> vfun -> vfun -> int * values * values
 
-(* Fix *)
+(** Fix *)
+
 val current_fix : vfix -> int
 val check_fix : vfix -> vfix -> bool
 val rec_args : vfix -> int array
 val reduce_fix : int -> vfix -> vfun array * values array
-                              (* bodies ,  types *)
+                              (** bodies ,  types *)
+
+(** CoFix *)
 
-(* CoFix *)
 val current_cofix : vcofix -> int
 val check_cofix : vcofix -> vcofix -> bool
 val reduce_cofix : int -> vcofix -> values array * values array
-                                      (* bodies , types *)
-(* Block *)
+                                      (** bodies , types *)
+
+(** Block *)
+
 val btag : vblock -> int
 val bsize : vblock -> int
 val bfield : vblock -> int -> values
 
-(* Switch *)
+(** Switch *)
+
 val check_switch : vswitch -> vswitch -> bool
 val case_info : vswitch -> case_info
 val type_of_switch : vswitch -> values
 val branch_of_switch : int -> vswitch -> (int * values) array
 
-(* Evaluation *)
+(** Evaluation *)
+
 val whd_stack : values -> stack -> whd
 val force_whd : values -> stack -> whd
 
+val eta_whd : int -> whd -> values
 
diff --git a/lib/bigint.ml b/lib/bigint.ml
index f3808f14..ed854d7a 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: bigint.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Pp
 (*i*)
diff --git a/lib/bigint.mli b/lib/bigint.mli
index 9a890570..92a97bdc 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -1,18 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: bigint.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
-(*i*)
 
-(* Arbitrary large integer numbers *)
+(** Arbitrary large integer numbers *)
 
 type bigint
 
@@ -23,7 +19,7 @@ val zero : bigint
 val one : bigint
 val two : bigint
 
-val div2_with_rest : bigint -> bigint * bool (* true=odd; false=even *)
+val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *)
 val add_1 : bigint -> bigint
 val sub_1 : bigint -> bigint
 val mult_2 : bigint -> bigint
diff --git a/lib/bstack.ml b/lib/bstack.ml
deleted file mode 100644
index 3d549427..00000000
--- a/lib/bstack.ml
+++ /dev/null
@@ -1,75 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: bstack.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Queues of a given length *)
-
-open Util
-
-(* - size  is the count of elements actually in the queue
-   - depth is the the amount of elements pushed in the queue (and not popped)
-   in particular, depth >= size always and depth > size if the queue overflowed
-   (and forgot older elements)
- *)
-
-type 'a t = {mutable pos : int;
-             mutable size : int;
-             mutable depth : int;
-             stack : 'a array}
-
-let create depth e =
-  {pos = 0;
-   size = 1;
-   depth = 1;
-   stack = Array.create depth e}
-
-(*
-let set_depth bs n = bs.depth <- n
-*)
-
-let incr_pos bs =
-  bs.pos <- if bs.pos = Array.length bs.stack - 1 then 0 else bs.pos + 1
-
-let incr_size bs =
-  if bs.size < Array.length bs.stack then bs.size <- bs.size + 1
-
-let decr_pos bs =
-  bs.pos <- if bs.pos = 0 then Array.length bs.stack - 1 else bs.pos - 1
-
-let push bs e =
-  incr_pos bs;
-  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.depth <- bs.depth - 1;
-    let oldpos = bs.pos in
-    decr_pos bs;
-    (* Release the memory at oldpos, by copying what is at new pos *)
-    bs.stack.(oldpos) <- bs.stack.(bs.pos)
-  end
-
-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)))
-
-let app_repl bs f =
-  if bs.size = 0 then error "Nothing on the stack"
-  else bs.stack.(bs.pos) <- f (bs.stack.(bs.pos))
-
-let depth bs = bs.depth
-
-let size bs = bs.size
diff --git a/lib/compat.ml4 b/lib/compat.ml4
index 096320ed..8d8483b4 100644
--- a/lib/compat.ml4
+++ b/lib/compat.ml4
@@ -1,79 +1,242 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_macro.cmo" i*)
+(** Compatibility file depending on ocaml/camlp4 version *)
 
-(* Compatibility file depending on ocaml version *)
+(** Locations *)
 
-IFDEF OCAML309 THEN DEFINE OCAML308 END
+IFDEF CAMLP5 THEN
+
+module Loc = struct
+  include Ploc
+  exception Exc_located = Exc
+  let ghost = dummy
+  let merge = encl
+end
+
+let make_loc = Loc.make_unlined
+let unloc loc = (Loc.first_pos loc, Loc.last_pos loc)
+
+ELSE
+
+module Loc = Camlp4.PreCast.Loc
+
+let make_loc (start,stop) =
+  Loc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
+let unloc loc = (Loc.start_off loc, Loc.stop_off loc)
+
+END
+
+(** Misc module emulation *)
+
+IFDEF CAMLP5 THEN
+
+module PcamlSig = struct end
+
+ELSE
+
+module PcamlSig = Camlp4.Sig
+module Ast = Camlp4.PreCast.Ast
+module Pcaml = Camlp4.PreCast.Syntax
+module MLast = Ast
+module Token = struct exception Error of string end
+
+END
+
+
+(** Grammar auxiliary types *)
+
+IFDEF CAMLP5 THEN
+type gram_assoc = Gramext.g_assoc = NonA | RightA | LeftA
+type gram_position = Gramext.position =
+  | First
+  | Last
+  | Before of string
+  | After of string
+  | Like of string (** dont use it, not in camlp4 *)
+  | Level of string
+ELSE
+type gram_assoc = PcamlSig.Grammar.assoc = NonA | RightA | LeftA
+type gram_position = PcamlSig.Grammar.position =
+  | First
+  | Last
+  | Before of string
+  | After of string
+  | Level of string
+END
+
+
+(** Signature of Lexer *)
+
+IFDEF CAMLP5 THEN
+
+module type LexerSig = sig
+  include Grammar.GLexerType with type te = Tok.t
+  module Error : sig
+    type t
+    exception E of t
+    val to_string : t -> string
+  end
+end
+
+ELSE
+
+module type LexerSig =
+  Camlp4.Sig.Lexer with module Loc = Loc and type Token.t = Tok.t
+
+END
+
+(** Signature and implementation of grammars *)
 
 IFDEF CAMLP5 THEN
-module M = struct
-type loc = Stdpp.location
-let dummy_loc = Stdpp.dummy_loc
-let make_loc = Stdpp.make_loc
-let unloc loc = Stdpp.first_pos loc, Stdpp.last_pos loc
-let join_loc loc1 loc2 =
- if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc
- else Stdpp.encl_loc loc1 loc2
-type token = string*string
-type lexer = token Token.glexer
+
+module type GrammarSig = sig
+  include Grammar.S with type te = Tok.t
+  type 'a entry = 'a Entry.e
+  type internal_entry = Tok.t Gramext.g_entry
+  type symbol = Tok.t Gramext.g_symbol
+  type action = Gramext.g_action
+  type production_rule = symbol list * action
+  type single_extend_statment =
+      string option * gram_assoc option * production_rule list
+  type extend_statment =
+      gram_position option * single_extend_statment list
+  val action : 'a -> action
+  val entry_create : string -> 'a entry
+  val entry_parse : 'a entry -> parsable -> 'a
+  val entry_print : 'a entry -> unit
+  val srules' : production_rule list -> symbol
+  val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a
 end
-ELSE IFDEF OCAML308 THEN
-module M = struct
-type loc = Token.flocation
-let dummy_loc = Token.dummy_loc
-let make_loc loc = Token.make_loc loc
-let unloc (b,e) =
-  let loc = (b.Lexing.pos_cnum,e.Lexing.pos_cnum) in
-  (* Ensure that we unpack a char location that was encoded as a line-col
-     location by make_loc *)
-(* Gram.Entry.parse may send bad loc in 3.08, see caml-bugs #2954
-  assert (dummy_loc = (b,e) or make_loc loc = (b,e));
-*)
-  loc
-let join_loc loc1 loc2 =
- if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc
- else (fst loc1, snd loc2)
-type token = Token.t
-type lexer = Token.lexer
+
+module GrammarMake (L:LexerSig) : GrammarSig = struct
+  include Grammar.GMake (L)
+  type 'a entry = 'a Entry.e
+  type internal_entry = Tok.t Gramext.g_entry
+  type symbol = Tok.t Gramext.g_symbol
+  type action = Gramext.g_action
+  type production_rule = symbol list * action
+  type single_extend_statment =
+      string option * gram_assoc option * production_rule list
+  type extend_statment =
+      gram_position option * single_extend_statment list
+  let action = Gramext.action
+  let entry_create = Entry.create
+  let entry_parse = Entry.parse
+IFDEF CAMLP5_6_02_1 THEN
+  let entry_print x = Entry.print !Pp_control.std_ft x
+ELSE
+  let entry_print = Entry.print
+END
+  let srules' = Gramext.srules
+  let parse_tokens_after_filter = Entry.parse_token
 end
+
 ELSE
-module M = struct
-type loc = int * int
-let dummy_loc = (0,0)
-let make_loc x = x
-let unloc x = x
-let join_loc loc1 loc2 =
- if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc
- else (fst loc1, snd loc2)
-type token = Token.t
-type lexer = Token.lexer
+
+module type GrammarSig = sig
+  include Camlp4.Sig.Grammar.Static
+    with module Loc = Loc and type Token.t = Tok.t
+  type 'a entry = 'a Entry.t
+  type action = Action.t
+  type parsable
+  val parsable : char Stream.t -> parsable
+  val action : 'a -> action
+  val entry_create : string -> 'a entry
+  val entry_parse : 'a entry -> parsable -> 'a
+  val entry_print : 'a entry -> unit
+  val srules' : production_rule list -> symbol
+end
+
+module GrammarMake (L:LexerSig) : GrammarSig = struct
+  include Camlp4.Struct.Grammar.Static.Make (L)
+  type 'a entry = 'a Entry.t
+  type action = Action.t
+  type parsable = char Stream.t
+  let parsable s = s
+  let action = Action.mk
+  let entry_create = Entry.mk
+  let entry_parse e s = parse e (*FIXME*)Loc.ghost s
+  let entry_print x = Entry.print !Pp_control.std_ft x
+  let srules' = srules (entry_create "dummy")
 end
+
 END
+
+
+(** Misc functional adjustments *)
+
+(** - The lexer produces streams made of pairs in camlp4 *)
+
+let get_tok = IFDEF CAMLP5 THEN fun x -> x ELSE fst END
+
+(** - Gram.extend is more currified in camlp5 than in camlp4 *)
+
+IFDEF CAMLP5 THEN
+let maybe_curry f x y = f (x,y)
+let maybe_uncurry f (x,y) = f x y
+ELSE
+let maybe_curry f = f
+let maybe_uncurry f = f
+END
+
+(** Compatibility with camlp5 strict mode *)
+IFDEF CAMLP5 THEN
+  IFDEF STRICT THEN
+    let vala x = Ploc.VaVal x
+  ELSE
+    let vala x = x
+  END
+ELSE
+  let vala x = x
 END
 
-type loc = M.loc
-let dummy_loc = M.dummy_loc
-let make_loc = M.make_loc
-let unloc = M.unloc
-let join_loc = M.join_loc
-type token = M.token
-type lexer = M.lexer
+(** Fix a quotation difference in [str_item] *)
+
+let declare_str_items loc l =
+IFDEF CAMLP5 THEN
+  MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *)
+ELSE
+  Ast.stSem_of_list l
+END
 
-IFDEF CAMLP5_6_00 THEN
+(** Quotation difference for match clauses *)
 
-let slist0sep x y = Gramext.Slist0sep (x, y, false)
-let slist1sep x y = Gramext.Slist1sep (x, y, false)
+let default_patt loc =
+  (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>)
+
+IFDEF CAMLP5 THEN
+
+let make_fun loc cl =
+  let l = cl @ [default_patt loc] in
+  MLast.ExFun (loc, vala l)  (* correspond to <:expr< fun [ $list:l$ ] >> *)
 
 ELSE
 
-let slist0sep x y = Gramext.Slist0sep (x, y)
-let slist1sep x y = Gramext.Slist1sep (x, y)
+let make_fun loc cl =
+  let mk_when = function
+    | Some w -> w
+    | None -> Ast.ExNil loc
+  in
+  let mk_clause (patt,optwhen,expr) =
+    (* correspond to <:match_case< ... when ... -> ... >> *)
+    Ast.McArr (loc, patt, mk_when optwhen, expr) in
+  let init = mk_clause (default_patt loc) in
+  let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in
+  let l = List.fold_right add_clause cl init in
+  Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *)
+
+END
+
+(** Explicit antiquotation $anti:... $ *)
 
+IFDEF CAMLP5 THEN
+let expl_anti loc e = <:expr< $anti:e$ >>
+ELSE
+let expl_anti _loc e = e (* FIXME: understand someday if we can do better *)
 END
diff --git a/lib/dnet.ml b/lib/dnet.ml
index fe20ecac..0b09a16a 100644
--- a/lib/dnet.ml
+++ b/lib/dnet.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
 (* Generic dnet implementation over non-recursive types *)
 
 module type Datatype =
diff --git a/lib/dnet.mli b/lib/dnet.mli
index eba2220b..ba0229d2 100644
--- a/lib/dnet.mli
+++ b/lib/dnet.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
-(* Generic discrimination net implementation over recursive
+(** 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
@@ -43,27 +41,27 @@
 
 *)
 
-(* datatype you want to build a dnet on *)
+(** datatype you want to build a dnet on *)
 module type Datatype =
 sig
-  (* parametric datatype. ['a] is morally the recursive argument *)
+  (** parametric datatype. ['a] is morally the recursive argument *)
   type 'a t
 
-  (* non-recursive mapping of subterms *)
+  (** 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 *)
+  (** 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 *)
+  (** comparison of constructors *)
   val compare : unit t -> unit t -> int
 
-  (* for each constructor, is it not-parametric on 'a? *)
+  (** 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 *)
+  (** [choose f w] applies f on ONE of the subterms of w *)
   val choose : ('a -> 'b) -> 'a t -> 'b
 end
 
@@ -71,19 +69,19 @@ module type S =
 sig
   type t
 
-  (* provided identifier type *)
+  (** provided identifier type *)
   type ident
 
-  (* provided metavariable type *)
+  (** provided metavariable type *)
   type meta
 
-  (* provided parametrized datastructure *)
+  (** provided parametrized datastructure *)
   type 'a structure
 
-  (* returned sets of solutions *)
+  (** returned sets of solutions *)
   module Idset : Set.S with type elt=ident
 
-  (* a pattern is a term where each node can be a unification
+  (** a pattern is a term where each node can be a unification
      variable *)
   type 'a pattern =
     | Term of 'a
@@ -93,13 +91,13 @@ sig
 
   val empty : t
 
-  (* [add t w i] adds a new association (w,i) in 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. *)
+  (** [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
+  (** [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).
@@ -107,15 +105,15 @@ sig
   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
+  (** [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 *)
+  (** 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 *)
+  (** apply a function on each identifier and node of terms in a dnet *)
   val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
 end
 
diff --git a/lib/dyn.ml b/lib/dyn.ml
index 2748422a..a0109b60 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dyn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 
 (* Dynamics, programmed with DANGER !!! *)
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 0d36dbef..577d17d5 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dyn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Dynamics. Use with extreme care. Not for kids. *)
+(** Dynamics. Use with extreme care. Not for kids. *)
 
 type t
 
diff --git a/lib/edit.ml b/lib/edit.ml
deleted file mode 100644
index 882303a6..00000000
--- a/lib/edit.ml
+++ /dev/null
@@ -1,134 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: edit.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Pp
-open Util
-
-type ('a,'b,'c) t = {
-  mutable focus : 'a option;
-  mutable last_focused_stk : 'a list;
-  buf : ('a, 'b Bstack.t * 'c) Hashtbl.t }
-
-let empty () = {
-  focus = None;
-  last_focused_stk = [];
-  buf = Hashtbl.create 17 }
-
-let focus e nd =
-  if not (Hashtbl.mem e.buf nd) then invalid_arg "Edit.focus";
-  begin match e.focus with
-    | Some foc when foc <> nd ->
-        e.last_focused_stk <- foc::(list_except foc e.last_focused_stk);
-    | _ -> ()
-  end;
-  e.focus <- Some nd
-
-let unfocus e =
-  match e.focus with
-    | None -> invalid_arg "Edit.unfocus"
-    | Some foc ->
-	begin
-	  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
-    | f::_ -> Some f
-
-let restore_last_focus e =
-  match e.last_focused_stk with
-    | [] -> ()
-    | f::_ -> focus e f
-
-let focusedp e =
-  match e.focus with
-    | None -> false
-    | _    -> true
-
-let read e =
-  match e.focus with
-    | None -> None
-    | Some d ->
-	let (bs,c) = Hashtbl.find e.buf d in
-	Some(d,Bstack.top bs,c)
-
-let mutate e f =
-  match e.focus with
-    | None -> invalid_arg "Edit.mutate"
-    | Some d ->
-	let (bs,c) = Hashtbl.find e.buf d in
-	Bstack.app_push bs (f c)
-
-let rev_mutate e f =
-  match e.focus with
-    | None -> invalid_arg "Edit.rev_mutate"
-    | Some d ->
-	let (bs,c) = Hashtbl.find e.buf d in
-	Bstack.app_repl bs (f c)
-
-let undo e n =
-  match e.focus with
-    | None -> invalid_arg "Edit.undo"
-    | Some d ->
-	let (bs,_) = Hashtbl.find e.buf d in
-	if n >= Bstack.size bs then
-	  errorlabstrm "Edit.undo" (str"Undo stack exhausted");
-        repeat n Bstack.pop bs
-
-(* Return the depth of the focused proof of [e] stack, this is used to
-   put informations in coq prompt (in emacs mode). *)
-let depth e =
-  match e.focus with
-    | None -> invalid_arg "Edit.depth"
-    | Some d ->
-	let (bs,_) = Hashtbl.find e.buf d in
-	Bstack.depth bs
-
-(* Undo focused proof of [e] to reach depth [n] *)
-let undo_todepth e n =
-  match e.focus with
-    | 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 ->
-	let (bs,_) = Hashtbl.find e.buf d in
-	let ucnt = Bstack.depth bs - n in
-	if  ucnt >= Bstack.size bs then
-	  errorlabstrm "Edit.undo_todepth" (str"Undo stack would be exhausted");
-        repeat ucnt Bstack.pop bs
-
-let create e (d,b,c,usize) =
-  if Hashtbl.mem e.buf d then
-    errorlabstrm "Edit.create"
-      (str"Already editing something of that name");
-  let bs = Bstack.create usize b in
-  Hashtbl.add e.buf d (bs,c)
-
-let delete e d =
-  if not(Hashtbl.mem e.buf d) then
-    errorlabstrm "Edit.delete" (str"No such editor");
-  Hashtbl.remove e.buf d;
-  e.last_focused_stk <- (list_except d e.last_focused_stk);
-  match e.focus with
-    | Some d' -> if d = d' then (e.focus <- None ; (restore_last_focus e))
-    | None -> ()
-
-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 <- [];
-  Hashtbl.clear e.buf
diff --git a/lib/edit.mli b/lib/edit.mli
deleted file mode 100644
index d3558716..00000000
--- a/lib/edit.mli
+++ /dev/null
@@ -1,63 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: edit.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* The type of editors.
- * An editor is a finite map, ['a -> 'b], which knows how to apply
- * modification functions to the value in the range, and how to
- * focus on a member of the range.
- * It also supports the notion of a limited-depth undo, and that certain
- * modification actions do not push onto the undo stack, since they are
- * reversible. *)
-
-type ('a,'b,'c) t
-
-val empty : unit -> ('a,'b,'c) t
-
-(* sets the focus to the specified domain element *)
-val focus : ('a,'b,'c) t -> 'a -> unit
-
-(* unsets the focus which must not already be unfocused *)
-val unfocus : ('a,'b,'c) t -> unit
-
-(* gives the last focused element or [None] if none *)
-val last_focused : ('a,'b,'c) t -> 'a option
-
-(* are we focused ? *)
-val focusedp : ('a,'b,'c) t -> bool
-
-(* If we are focused, then return the current domain,range pair. *)
-val read : ('a,'b,'c) t -> ('a * 'b * 'c) option
-
-(* mutates the currently-focused range element, pushing its
- * old value onto the undo stack
- *)
-val mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit
-
-(* mutates the currently-focused range element, in place. *)
-val rev_mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit
-
-(* Pops the specified number of elements off of the undo stack, *
-  reinstating the last popped element. The undo stack is independently
-  managed for each range element. *)
-val undo : ('a,'b,'c) t -> int -> unit
-
-val create : ('a,'b,'c) t -> 'a * 'b * 'c * int -> unit
-val delete : ('a,'b,'c) t -> 'a -> unit
-
-val dom : ('a,'b,'c) t -> 'a list
-
-val clear : ('a,'b,'c) t -> unit
-
-(* [depth e] Returns the depth of the focused proof stack of [e], this
-   is used to put informations in coq prompt (in emacs mode). *)
-val depth : ('a,'b,'c) t -> int
-
-(* [undo_todepth e n] Undoes focused proof of [e] to reach depth [n] *)
-val undo_todepth : ('a,'b,'c) t -> int -> unit
diff --git a/lib/envars.ml b/lib/envars.ml
index f764576d..e5c93803 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,39 +9,75 @@
 (* This file gathers environment variables needed by Coq to run (such
    as coqlib) *)
 
-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 coqbin =
+  System.canonical_path_name (Filename.dirname Sys.executable_name)
+
+(* The following only makes sense when executables are running from
+   source tree (e.g. during build or in local mode). *)
+let coqroot = Filename.dirname coqbin
 
 (* On win32, we add coqbin to the PATH at launch-time (this used to be
    done in a .bat script). *)
 
 let _ =
   if Coq_config.arch = "win32" then
-    Unix.putenv "PATH" (coqbin() ^ ";" ^ System.getenv_else "PATH" "")
+    Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "")
+
+let reldir instdir testfile oth =
+  let rpath = if Coq_config.local then [] else instdir in
+  let out = List.fold_left Filename.concat coqroot rpath in
+  if Sys.file_exists (Filename.concat out testfile) then out else oth ()
 
 let guess_coqlib () =
   let file = "states/initial.coq" in
-    if Sys.file_exists (Filename.concat Coq_config.coqlib file)
-    then Coq_config.coqlib
-    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
-	  (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"
+    reldir (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) file
+      (fun () ->
+        let coqlib = match Coq_config.coqlib with
+          | Some coqlib -> coqlib
+          | None -> coqroot
+        in
+        if Sys.file_exists (Filename.concat coqlib file)
+        then coqlib
+        else Util.error "cannot guess a path for Coq libraries; please use -coqlib option")
 
 let coqlib () =
   if !Flags.coqlib_spec then !Flags.coqlib else
-    (if !Flags.boot then Coq_config.coqsrc else guess_coqlib ())
+    (if !Flags.boot then coqroot else guess_coqlib ())
+
+let docdir () =
+  reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir)
 
 let path_to_list p =
   let sep = if Sys.os_type = "Win32" then ';' else ':' in
     Util.split_string_at sep p
 
+let xdg_data_home =
+  Filename.concat
+    (System.getenv_else "XDG_DATA_HOME" (Filename.concat System.home ".local/share"))
+    "coq"
+
+let xdg_config_home =
+  Filename.concat
+    (System.getenv_else "XDG_CONFIG_HOME" (Filename.concat System.home ".config"))
+    "coq"
+
+let xdg_data_dirs =
+  try
+    List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+  with Not_found -> "/usr/local/share/coq" :: "/usr/share/coq"
+    :: (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir])
+
+let xdg_dirs =
+  let dirs = xdg_data_home :: xdg_data_dirs
+  in
+  List.rev (List.filter Sys.file_exists dirs)
+
+let coqpath =
+  try
+    let path = Sys.getenv "COQPATH" in
+      List.rev (List.filter Sys.file_exists (path_to_list path))
+  with Not_found -> []
+
 let rec which l f =
   match l with
     | [] -> raise Not_found
@@ -74,11 +110,12 @@ let camllib () =
     let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
     Util.strip res
 
-(* TODO : essayer aussi camlbin *)
 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
+      try guess_camlp4bin () with _ -> let cb = camlbin () in
+				       if Sys.file_exists (Filename.concat cb Coq_config.camlp4) then cb
+				       else Coq_config.camlp4bin
 
 let camlp4lib () =
   if !Flags.boot
diff --git a/lib/envars.mli b/lib/envars.mli
index 05357b32..0c80492f 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -1,13 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(** This file gathers environment variables needed by Coq to run (such
+   as coqlib) *)
+
 val coqlib : unit -> string
-val coqbin : unit -> string
+val docdir : unit -> string
+val coqbin : string
+val coqroot : string
+(* coqpath is stored in reverse order, since that is the order it
+ * gets added to the searc path *)
+val xdg_config_home : string
+val xdg_dirs : string list
+val coqpath : string list
 
 val camlbin : unit -> string
 val camlp4bin : unit -> string
diff --git a/lib/errors.ml b/lib/errors.ml
new file mode 100644
index 00000000..3b5e6770
--- /dev/null
+++ b/lib/errors.ml
@@ -0,0 +1,68 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+open Pp
+
+(* spiwack: it might be reasonable to decide and move the declarations
+   of Anomaly and so on to this module so as not to depend on Util. *)
+
+let handle_stack = ref []
+
+exception Unhandled
+
+let register_handler h = handle_stack := h::!handle_stack
+
+(** [print_gen] is a general exception printer which tries successively
+    all the handlers of a list, and finally a [bottom] handler if all
+    others have failed *)
+
+let rec print_gen bottom stk e =
+  match stk with
+  | [] -> bottom e
+  | h::stk' ->
+    try h e
+    with
+    | Unhandled -> print_gen bottom stk' e
+    | e' -> print_gen bottom stk' e'
+
+(** Only anomalies should reach the bottom of the handler stack.
+    In usual situation, the [handle_stack] is treated as it if was always
+    non-empty with [print_anomaly] as its bottom handler. *)
+
+let where s =
+  if !Flags.debug then str ("in "^s^":") ++ spc () else mt ()
+
+let raw_anomaly e = match e with
+  | Util.Anomaly (s,pps) -> where s ++ pps ++ str "."
+  | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".")
+  | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".")
+
+let print_anomaly askreport e =
+  if askreport then
+    hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.")
+  else
+    hov 0 (raw_anomaly e)
+
+(** The standard exception printer *)
+let print e = print_gen (print_anomaly true) !handle_stack e
+
+(** Same as [print], except that the "Please report" part of an anomaly
+    isn't printed (used in Ltac debugging). *)
+let print_no_report e = print_gen (print_anomaly false) !handle_stack e
+
+(** Same as [print], except that anomalies are not printed but re-raised
+    (used for the Fail command) *)
+let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e
+
+(** Predefined handlers **)
+
+let _ = register_handler begin function
+  | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps)
+  | _ -> raise Unhandled
+end
+
diff --git a/lib/errors.mli b/lib/errors.mli
new file mode 100644
index 00000000..eb7fde8e
--- /dev/null
+++ b/lib/errors.mli
@@ -0,0 +1,41 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** This modules implements basic manipulations of errors for use
+    throughout Coq's code. *)
+
+(** [register_handler h] registers [h] as a handler.
+    When an expression is printed with [print e], it
+    goes through all registered handles (the most
+    recent first) until a handle deals with it.
+
+    Handles signal that they don't deal with some exception
+    by raising [Unhandled].
+
+    Handles can raise exceptions themselves, in which
+    case, the exception is passed to the handles which
+    were registered before.
+
+    The exception that are considered anomalies should not be
+    handled by registered handlers.
+*)
+
+exception Unhandled
+
+val register_handler : (exn -> Pp.std_ppcmds) -> unit
+
+(** The standard exception printer *)
+val print : exn -> Pp.std_ppcmds
+
+(** Same as [print], except that the "Please report" part of an anomaly
+    isn't printed (used in Ltac debugging). *)
+val print_no_report : exn -> Pp.std_ppcmds
+
+(** Same as [print], except that anomalies are not printed but re-raised
+    (used for the Fail command) *)
+val print_no_anomaly : exn -> Pp.std_ppcmds
diff --git a/lib/explore.ml b/lib/explore.ml
index c40362c8..407bf1e9 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Format
 
 (*s Definition of a search problem. *)
diff --git a/lib/explore.mli b/lib/explore.mli
index e01f851c..e64459f1 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -1,16 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** {6 Search strategies. } *)
 
-(*s Search strategies. *)
-
-(*s A search problem implements the following signature [SearchProblem].
+(** {6 ... } *)
+(** 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
     empty list, then search from [s] is aborted; successors of [s] are
@@ -32,7 +31,8 @@ module type SearchProblem = sig
 
 end
 
-(*s Functor [Make] returns some search functions given a search problem.
+(** {6 ... } *)
+(** Functor [Make] returns some search functions given a search problem.
     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).
diff --git a/lib/flags.ml b/lib/flags.ml
index 6b68a8f2..470cf81f 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: flags.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 let with_option o f x =
   let old = !o in o:=true;
   try let r = f x in o := old; r
@@ -25,19 +23,22 @@ let batch_mode = ref false
 let debug = ref false
 
 let print_emacs = ref false
-let print_emacs_safechar = ref false
 
 let term_quality = ref false
 
 let xml_export = ref false
 
-let dont_load_proofs = ref false
+type load_proofs = Force | Lazy | Dont
+
+let load_proofs = ref Lazy
 
 let raw_print = ref false
 
+let record_print = ref true
+
 (* Compatibility mode *)
 
-type compat_version = V8_2
+type compat_version = V8_2 | V8_3
 let compat_version = ref None
 let version_strictly_greater v =
   match !compat_version with None -> true | Some v' -> v'>v
@@ -86,12 +87,6 @@ let unsafe_set = ref Stringset.empty
 let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set
 let is_unsafe s = Stringset.mem s !unsafe_set
 
-(* Flags for the virtual machine *)
-
-let boxed_definitions = ref true
-let set_boxed_definitions b = boxed_definitions := b
-let boxed_definitions _ = !boxed_definitions
-
 (* Flags for external tools *)
 
 let subst_command_placeholder s t =
@@ -120,9 +115,21 @@ let is_standard_doc_url url =
   url = Coq_config.wwwrefman ||
   url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n)
 
+(* same as in System, but copied here because of dependencies *)
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  Sys.chdir p;
+  let result = Sys.getcwd () in
+  Sys.chdir current;
+  result
+
 (* Options for changing coqlib *)
 let coqlib_spec = ref false
-let coqlib = ref Coq_config.coqlib
+let coqlib = ref (
+  (* same as Envars.coqroot, but copied here because of dependencies *)
+  Filename.dirname
+    (canonical_path_name (Filename.dirname Sys.executable_name))
+)
 
 (* Options for changing camlbin (used by coqmktop) *)
 let camlbin_spec = ref false
@@ -132,3 +139,9 @@ let camlbin = ref Coq_config.camlbin
 let camlp4bin_spec = ref false
 let camlp4bin = ref Coq_config.camlp4bin
 
+(* Level of inlining during a functor application *)
+
+let default_inline_level = 100
+let inline_level = ref default_inline_level
+let set_inline_level = (:=) inline_level
+let get_inline_level () = !inline_level
diff --git a/lib/flags.mli b/lib/flags.mli
index f4325ce2..da43c867 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: flags.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Global options of the system. *)
+(** Global options of the system. *)
 
 val boot : bool ref
 
@@ -17,17 +15,18 @@ val batch_mode : bool ref
 val debug : bool ref
 
 val print_emacs : bool ref
-val print_emacs_safechar : bool ref
 
 val term_quality : bool ref
 
 val xml_export : bool ref
 
-val dont_load_proofs : bool ref
+type load_proofs = Force | Lazy | Dont
+val load_proofs : load_proofs ref
 
 val raw_print : bool ref
+val record_print : bool ref
 
-type compat_version = V8_2
+type compat_version = V8_2 | V8_3
 val compat_version : compat_version option ref
 val version_strictly_greater : compat_version -> bool
 val version_less_or_equal : compat_version -> bool
@@ -53,41 +52,41 @@ val if_warn : ('a -> unit) -> 'a -> unit
 
 val hash_cons_proofs : bool ref
 
-(* Temporary activate an option (to activate option [o] on [f x y z],
+(** Temporary activate an option (to activate option [o] on [f x y z],
    use [with_option o (f x y) z]) *)
 val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
-(* Temporary deactivate an option *)
+(** Temporary deactivate an option *)
 val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
-(* If [None], no limit *)
+(** If [None], no limit *)
 val set_print_hyps_limit : int option -> unit
 val print_hyps_limit : unit -> int option
 
 val add_unsafe : string -> unit
 val is_unsafe : string -> bool
 
-(* Options for the virtual machine *)
-
-val set_boxed_definitions : bool -> unit
-val boxed_definitions : unit -> bool
+(** Options for external tools *)
 
-(* Options for external tools *)
-
-(* Returns string format for default browser to use from Coq or CoqIDE *)
+(** 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 *)
+(** Substitute %s in the first chain by the second chain *)
 val subst_command_placeholder : string -> string -> string
 
-(* Options for specifying where coq librairies reside *)
+(** Options for specifying where coq librairies reside *)
 val coqlib_spec : bool ref
 val coqlib : string ref
 
-(* Options for specifying where OCaml binaries reside *)
+(** Options for specifying where OCaml binaries reside *)
 val camlbin_spec : bool ref
 val camlbin : string ref
 val camlp4bin_spec : bool ref
 val camlp4bin : string ref
+
+(** Level of inlining during a functor application *)
+val set_inline_level : int -> unit
+val get_inline_level : unit -> int
+val default_inline_level : int
diff --git a/lib/fmap.mli b/lib/fmap.mli
index c323b055..2c8dedd7 100644
--- a/lib/fmap.mli
+++ b/lib/fmap.mli
@@ -14,7 +14,7 @@ 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. *)
+(** Additions with respect to ocaml standard library. *)
 
 val dom : 'a t -> key list
 val rng : 'a t -> 'a list
diff --git a/lib/gmap.ml b/lib/gmap.ml
index 3f979074..bc60a7fc 100644
--- a/lib/gmap.ml
+++ b/lib/gmap.ml
@@ -1,11 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: gmap.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
 
 (* 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 6da223d5..cdd6547c 100644
--- a/lib/gmap.mli
+++ b/lib/gmap.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmap.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Maps using the generic comparison function of ocaml. Same interface as
+(** Maps using the generic comparison function of ocaml. Same interface as
    the module [Map] from the ocaml standard library. *)
 
 type ('a,'b) t
@@ -23,7 +21,7 @@ val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
 val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
 val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
 
-(* Additions with respect to ocaml standard library. *)
+(** Additions with respect to ocaml standard library. *)
 
 val dom : ('a,'b) t -> 'a list
 val rng : ('a,'b) t -> 'b list
diff --git a/lib/gmapl.ml b/lib/gmapl.ml
index e8dc6295..a0040742 100644
--- a/lib/gmapl.ml
+++ b/lib/gmapl.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gmapl.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 
 type ('a,'b) t = ('a,'b list) Gmap.t
diff --git a/lib/gmapl.mli b/lib/gmapl.mli
index f60aed5d..53a5d96f 100644
--- a/lib/gmapl.mli
+++ b/lib/gmapl.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmapl.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Maps from ['a] to lists of ['b]. *)
+(** Maps from ['a] to lists of ['b]. *)
 
 type ('a,'b) t
 
diff --git a/lib/gset.ml b/lib/gset.ml
deleted file mode 100644
index 28b769af..00000000
--- a/lib/gset.ml
+++ /dev/null
@@ -1,242 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: gset.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Sets using the generic comparison function of ocaml. Code borrowed from
-   the ocaml standard library. *)
-
-    type 'a t = Empty | Node of 'a t * 'a * 'a 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 = Pervasives.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 = Pervasives.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 = Pervasives.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 = Pervasives.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 = Pervasives.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
diff --git a/lib/gset.mli b/lib/gset.mli
deleted file mode 100644
index 25e607f7..00000000
--- a/lib/gset.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: gset.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Sets using the generic comparison function of ocaml. Same interface as
-   the module [Set] from the ocaml standard library. *)
-
-type 'a t
-
-val empty : 'a t
-val is_empty : 'a t -> bool
-val mem : 'a -> 'a t -> bool
-val add : 'a -> 'a t -> 'a t
-val singleton : 'a -> 'a t
-val remove : 'a -> 'a t -> 'a t
-val union : 'a t -> 'a t -> 'a t
-val inter : 'a t -> 'a t -> 'a t
-val diff : 'a t -> 'a t -> 'a t
-val compare : 'a t -> 'a t -> int
-val equal : 'a t -> 'a t -> bool
-val subset : 'a t -> 'a t -> bool
-val iter : ('a -> unit) -> 'a t -> unit
-val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-val cardinal : 'a t -> int
-val elements : 'a t -> 'a list
-val min_elt : 'a t -> 'a
-val max_elt : 'a t -> 'a
-val choose : 'a t -> 'a
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index 542ecde9..8ab718d5 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hashcons.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Hash consing of datastructures *)
 
 (* The generic hash-consing functions (does not use Obj) *)
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index 81c74aef..65b1e0e9 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hashcons.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Generic hash-consing. *)
+(** Generic hash-consing. *)
 
 module type Comp =
   sig
@@ -37,7 +35,7 @@ val recursive2_hcons :
     (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) ->
       'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2)
 
-(* Declaring and reinitializing global hash-consing functions *)
+(** Declaring and reinitializing global hash-consing functions *)
 
 val init : unit -> unit
 val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't)
diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml
new file mode 100644
index 00000000..9e0f0dec
--- /dev/null
+++ b/lib/hashtbl_alt.ml
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The following module is a specialized version of [Hashtbl] that is
+   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
+   with [constr] used both as a key and as an image.  Thus, in each
+   cell of the internal bucketlist, there are two representations of
+   the same value. In this implementation, there is only one.
+
+   Besides, the responsibility of computing the hash function is now
+   given to the caller, which makes possible the interleaving of the
+   hash key computation and the hash-consing. *)
+
+module type Hashtype = sig
+  type t
+  val equals : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  (* [may_add_and_get key constr] uses [key] to look for [constr]
+     in the hash table [H]. If [constr] is in [H], returns the
+     specific representation that is stored in [H]. Otherwise,
+     [constr] is stored in [H] and will be used as the canonical
+     representation of this value in the future. *)
+  val may_add_and_get : int -> elt -> elt
+end
+
+module Make (E : Hashtype) =
+  struct
+
+    type elt = E.t
+
+    type bucketlist = Empty | Cons of elt * int * bucketlist
+
+    let initial_size = 19991
+    let table_data = ref (Array.make initial_size Empty)
+    let table_size = ref 0
+
+    let resize () =
+      let odata = !table_data in
+      let osize = Array.length odata in
+    let nsize = min (2 * osize + 1) Sys.max_array_length in
+    if nsize <> osize then begin
+      let ndata = Array.create nsize Empty in
+      let rec insert_bucket = function
+	| Empty -> ()
+	| Cons (key, hash, rest) ->
+          let nidx = hash mod nsize in
+          ndata.(nidx) <- Cons (key, hash, ndata.(nidx));
+          insert_bucket rest
+      in
+      for i = 0 to osize - 1 do insert_bucket odata.(i) done;
+      table_data := ndata
+    end
+
+  let add hash key =
+    let odata = !table_data in
+    let osize = Array.length odata in
+    let i = hash mod osize in
+    odata.(i) <- Cons (key, hash, odata.(i));
+    incr table_size;
+    if !table_size > osize lsl 1 then resize ()
+
+  let find_rec hash key bucket =
+    let rec aux = function
+      | Empty ->
+	add hash key; key
+      | Cons (k, h, rest) ->
+	if hash == h && E.equals key k then k else aux rest
+    in
+    aux bucket
+
+  let may_add_and_get hash key =
+    let odata = !table_data in
+    match odata.(hash mod (Array.length odata)) with
+      |	Empty -> add hash key; key
+      | Cons (k1, h1, rest1) ->
+	if hash == h1 && E.equals key k1 then k1 else
+	  match rest1 with
+            | Empty -> add hash key; key
+	    | Cons (k2, h2, rest2) ->
+              if hash == h2 && E.equals key k2 then k2 else
+		match rest2 with
+		  | Empty -> add hash key; key
+		  | Cons (k3, h3, rest3) ->
+		    if hash == h2 && E.equals key k3 then k3
+		    else find_rec hash key rest3
+
+end
+
+module Combine = struct
+    (* These are helper functions to combine the hash keys in a similar
+       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
+       be prime numbers. There were chosen empirically. Notice that the
+       problem of hashing trees is hard and there are plenty of study on
+       this topic. Therefore, there must be room for improvement here. *)
+    let alpha = 65599
+    let beta  = 7
+    let combine x y     = x * alpha + y
+    let combine3 x y z   = combine x (combine y z)
+    let combine4 x y z t = combine x (combine3 y z t)
+    let combinesmall x y = beta * x + y
+end
diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli
new file mode 100644
index 00000000..a22dbc28
--- /dev/null
+++ b/lib/hashtbl_alt.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The following module is a specialized version of [Hashtbl] that is
+   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
+   with [constr] used both as a key and as an image.  Thus, in each
+   cell of the internal bucketlist, there are two representations of
+   the same value. In this implementation, there is only one.
+
+   Besides, the responsibility of computing the hash function is now
+   given to the caller, which makes possible the interleaving of the
+   hash key computation and the hash-consing. *)
+
+module type Hashtype = sig
+  type t
+  val equals : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  (* [may_add_and_get key constr] uses [key] to look for [constr]
+     in the hash table [H]. If [constr] is in [H], returns the
+     specific representation that is stored in [H]. Otherwise,
+     [constr] is stored in [H] and will be used as the canonical
+     representation of this value in the future. *)
+  val may_add_and_get : int -> elt -> elt
+end
+
+module Make (E : Hashtype) : S with type elt = E.t
+
+module Combine : sig
+  val combine : int -> int -> int
+  val combinesmall : int -> int -> int
+  val combine3 : int -> int -> int -> int
+  val combine4 : int -> int -> int -> int -> int
+end
diff --git a/lib/heap.ml b/lib/heap.ml
index c61bccb9..f3326749 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heap.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*s Heaps *)
 
 module type Ordered = sig
diff --git a/lib/heap.mli b/lib/heap.mli
index 3183e0ec..9cf23dd3 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: heap.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Heaps *)
+(** Heaps *)
 
 module type Ordered = sig
   type t
@@ -17,29 +15,29 @@ end
 
 module type S =sig
 
-  (* Type of functional heaps *)
+  (** Type of functional heaps *)
   type t
 
-  (* Type of elements *)
+  (** Type of elements *)
   type elt
 
-  (* The empty heap *)
+  (** The empty heap *)
   val empty : t
 
-  (* [add x h] returns a new heap containing the elements of [h], plus [x];
-     complexity $O(log(n))$ *)
+  (** [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)$ *)
+  (** [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
+  (** [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))$ *)
+     complexity {% $ %}O(log(n)){% $ %} *)
   val remove : t -> t
 
-  (* usual iterators and combinators; elements are presented in
+  (** usual iterators and combinators; elements are presented in
      arbitrary order *)
   val iter : (elt -> unit) -> t -> unit
 
@@ -49,6 +47,6 @@ end
 
 exception EmptyHeap
 
-(*S Functional implementation. *)
+(** {6 Functional implementation. } *)
 
 module Functional(X: Ordered) : S with type elt=X.t
diff --git a/lib/lib.mllib b/lib/lib.mllib
index 1743ce26..db79b5c2 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -1,3 +1,6 @@
+Xml_lexer
+Xml_parser
+Xml_utils
 Pp_control
 Pp
 Compat
@@ -5,19 +8,16 @@ Flags
 Segmenttree
 Unicodetable
 Util
+Errors
 Bigint
 Hashcons
 Dyn
 System
 Envars
-Bstack
-Edit
-Gset
 Gmap
 Fset
 Fmap
-Tlm
-tries
+Tries
 Gmapl
 Profile
 Explore
@@ -26,4 +26,6 @@ Rtree
 Heap
 Option
 Dnet
-
+Store
+Unionfind
+Hashtbl_alt
diff --git a/lib/option.ml b/lib/option.ml
index f4b1604f..c3fe9ce4 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: option.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Module implementing basic combinators for OCaml option type.
    It tries follow closely the style of OCaml standard library.
 
diff --git a/lib/option.mli b/lib/option.mli
index 1dc721fe..b9fd7d2f 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: option.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Module implementing basic combinators for OCaml option type.
    It tries follow closely the style of OCaml standard library.
 
diff --git a/lib/pp.ml4 b/lib/pp.ml4
index d02b5c4d..c602b403 100644
--- a/lib/pp.ml4
+++ b/lib/pp.ml4
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp_control
 
 (* This should not be used outside of this file. Use
@@ -275,11 +273,6 @@ let pp_dirs ft =
 
 (* pretty print on stdout and stderr *)
 
-let pp_std_dirs = pp_dirs !std_ft
-let pp_err_dirs = pp_dirs !err_ft
-
-let ppcmds x = Ppdir_ppcmds x
-
 (* Special chars for emacs, to detect warnings inside goal output *)
 let emacs_warning_start_string = String.make 1 (Char.chr 254)
 let emacs_warning_end_string = String.make 1 (Char.chr 255)
@@ -339,3 +332,7 @@ let msgnl x = msgnl_with !std_ft x
 let msgerr x = msg_with !err_ft x
 let msgerrnl x = msgnl_with !err_ft x
 let msg_warning x = msg_warning_with !err_ft x
+
+let string_of_ppcmds c =
+  msg_with Format.str_formatter c;
+  Format.flush_str_formatter ()
diff --git a/lib/pp.mli b/lib/pp.mli
index 61b544e3..7070e3f5 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp_control
-(*i*)
 
-(* Modify pretty printing functions behavior for emacs ouput (special
+(** Modify pretty printing functions behavior for emacs ouput (special
    chars inserted at some places). This function should called once in
    module [Options], that's all. *)
 val make_pp_emacs:unit -> unit
 val make_pp_nonemacs:unit -> unit
 
-(* Pretty-printers. *)
+(** Pretty-printers. *)
 
 type ppcmd
 
 type std_ppcmds = ppcmd Stream.t
 
-(*s Formatting commands. *)
+(** {6 Formatting commands. } *)
 
 val str  : string -> std_ppcmds
 val stras : int * string -> std_ppcmds
@@ -40,11 +36,11 @@ val ismt : std_ppcmds -> bool
 val comment : int -> std_ppcmds
 val comments : ((int * int) * string) list ref
 
-(*s Concatenation. *)
+(** {6 Concatenation. } *)
 
 val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
 
-(*s Derived commands. *)
+(** {6 Derived commands. } *)
 
 val spc : unit -> std_ppcmds
 val cut : unit -> std_ppcmds
@@ -59,7 +55,7 @@ val strbrk : string -> std_ppcmds
 
 val xmlescape : ppcmd -> ppcmd
 
-(*s Boxing commands. *)
+(** {6 Boxing commands. } *)
 
 val h : int -> std_ppcmds -> std_ppcmds
 val v : int -> std_ppcmds -> std_ppcmds
@@ -67,7 +63,7 @@ val hv : int -> std_ppcmds -> std_ppcmds
 val hov : int -> std_ppcmds -> std_ppcmds
 val t : std_ppcmds -> std_ppcmds
 
-(*s Opening and closing of boxes. *)
+(** {6 Opening and closing of boxes. } *)
 
 val hb : int -> std_ppcmds
 val vb : int -> std_ppcmds
@@ -77,7 +73,7 @@ val tb : unit -> std_ppcmds
 val close : unit -> std_ppcmds
 val tclose : unit -> std_ppcmds
 
-(*s Pretty-printing functions \emph{without flush}. *)
+(** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *)
 
 val pp_with : Format.formatter -> std_ppcmds -> unit
 val ppnl_with : Format.formatter -> std_ppcmds -> unit
@@ -87,31 +83,34 @@ val pp_flush_with : Format.formatter -> unit -> unit
 
 val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit
 
-(*s Pretty-printing functions \emph{with flush}. *)
+(** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *)
 
 val msg_with : Format.formatter -> std_ppcmds -> unit
 val msgnl_with : Format.formatter -> std_ppcmds -> unit
 
 
-(*s The following functions are instances of the previous ones on
+(** {6 ... } *)
+(** The following functions are instances of the previous ones on
   [std_ft] and [err_ft]. *)
 
-(*s Pretty-printing functions \emph{without flush} on [stdout] and [stderr]. *)
+(** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *)
 
 val pp : std_ppcmds -> unit
 val ppnl : std_ppcmds -> unit
 val pperr : std_ppcmds -> unit
 val pperrnl : std_ppcmds -> unit
-val message : string -> unit       (* = pPNL *)
+val message : string -> unit       (** = pPNL *)
 val warning : string -> unit
 val warn : std_ppcmds -> unit
 val pp_flush : unit -> unit
 val flush_all: unit -> unit
 
-(*s Pretty-printing functions \emph{with flush} on [stdout] and [stderr]. *)
+(** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *)
 
 val msg : std_ppcmds -> unit
 val msgnl : std_ppcmds -> unit
 val msgerr : std_ppcmds -> unit
 val msgerrnl : std_ppcmds -> unit
 val msg_warning : std_ppcmds -> unit
+
+val string_of_ppcmds : std_ppcmds -> string
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index a7ad553b..cefd08c5 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp_control.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Parameters of pretty-printing *)
 
 type pp_global_params = {
@@ -49,40 +47,18 @@ let get_gp ft =
     max_depth = Format.pp_get_max_boxes ft ();
     ellipsis = Format.pp_get_ellipsis_text ft () }
 
-
-(* Output functions of pretty-printing *)
-
-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 = {
-  fp_output = stdout ;
-  fp_output_function = output stdout;
-  fp_flush_function = (fun () -> flush stdout) }
-
-let err_fp = {
-  fp_output = stderr ;
-  fp_output_function = output stderr;
-  fp_flush_function = (fun () -> flush stderr) }
-
 (* with_fp : 'a pp_formatter_params -> Format.formatter
  * returns of formatter for given formatter functions *)
 
-let with_fp fp =
-  let ft = Format.make_formatter fp.fp_output_function fp.fp_flush_function in
-  Format.pp_set_formatter_out_channel ft fp.fp_output;
+let with_fp chan out_function flush_function =
+  let ft = Format.make_formatter out_function flush_function in
+  Format.pp_set_formatter_out_channel ft chan;
   ft
 
 (* Output on a channel ch *)
 
 let with_output_to ch =
-  let ft = with_fp { fp_output = ch ;
-      	             fp_output_function = (output ch) ;
-	             fp_flush_function = (fun () -> flush ch) } in
+  let ft = with_fp ch (output ch) (fun () -> flush ch) in
   set_gp ft deep_gp;
   ft
 
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index bbc771d5..c66255f9 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp_control.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Parameters of pretty-printing. *)
+(** Parameters of pretty-printing. *)
 
 type pp_global_params = {
   margin : int;
@@ -23,24 +21,15 @@ val set_dflt_gp : Format.formatter -> unit
 val get_gp : Format.formatter -> pp_global_params
 
 
-(*s Output functions of pretty-printing. *)
-
-type 'a pp_formatter_params = {
-  fp_output : out_channel;
-  fp_output_function : string -> int -> int -> unit;
-  fp_flush_function : unit -> unit }
-
-val std_fp : (int*string) pp_formatter_params
-val err_fp : (int*string) pp_formatter_params
+(** {6 Output functions of pretty-printing. } *)
 
-val with_fp : 'a pp_formatter_params -> Format.formatter
 val with_output_to : out_channel -> Format.formatter
 
 val std_ft : Format.formatter ref
 val err_ft : Format.formatter ref
 val deep_ft : Format.formatter ref
 
-(*s For parametrization through vernacular. *)
+(** {6 For parametrization through vernacular. } *)
 
 val set_depth_boxes : int option -> unit
 val get_depth_boxes : unit -> int option
diff --git a/lib/predicate.ml b/lib/predicate.ml
index 506a87c9..e419aa6e 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (************************************************************************)
 
-(* $Id: predicate.ml 12337 2009-09-17 15:58:14Z glondu $ *)
-
 (* Sets over ordered types *)
 
 module type OrderedType =
diff --git a/lib/predicate.mli b/lib/predicate.mli
index 85596fea..bcc89e72 100644
--- a/lib/predicate.mli
+++ b/lib/predicate.mli
@@ -1,9 +1,7 @@
 
-(*i $Id: predicate.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(** Module [Pred]: sets over infinite ordered types with complement. *)
 
-(* Module [Pred]: sets over infinite ordered types with complement. *)
-
-(* This module implements the set data structure, given a total ordering
+(** This module implements the set data structure, given a total ordering
    function over the set elements. All operations over sets
    are purely applicative (no side-effects).
    The implementation uses the Set library. *)
@@ -13,7 +11,7 @@ module type OrderedType =
     type t
     val compare: t -> t -> int
   end
-          (* The input signature of the functor [Pred.Make].
+          (** The input signature of the functor [Pred.Make].
              [t] is the type of the set elements.
              [compare] is a total ordering function over the set elements.
              This is a two-argument function [f] such that
@@ -26,44 +24,44 @@ module type OrderedType =
 module type S =
   sig
     type elt
-          (* The type of the set elements. *)
+          (** The type of the set elements. *)
     type t
-          (* The type of sets. *)
+          (** The type of sets. *)
     val empty: t
-          (* The empty set. *)
+          (** The empty set. *)
     val full: t
-          (* The whole type. *)
+          (** The whole type. *)
     val is_empty: t -> bool
-        (* Test whether a set is empty or not. *)
+        (** Test whether a set is empty or not. *)
     val is_full: t -> bool
-        (* Test whether a set contains the whole type or not. *)
+        (** Test whether a set contains the whole type or not. *)
     val mem: elt -> t -> bool
-        (* [mem x s] tests whether [x] belongs to the set [s]. *)
+        (** [mem x s] tests whether [x] belongs to the set [s]. *)
     val singleton: elt -> t
-        (* [singleton x] returns the one-element set containing only [x]. *)
+        (** [singleton x] returns the one-element set containing only [x]. *)
     val add: elt -> t -> t
-        (* [add x s] returns a set containing all elements of [s],
+        (** [add x s] returns a set containing all elements of [s],
            plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
     val remove: elt -> t -> t
-        (* [remove x s] returns a set containing all elements of [s],
+        (** [remove x s] returns a set containing all elements of [s],
            except [x]. If [x] was not in [s], [s] is returned unchanged. *)
     val union: t -> t -> t
     val inter: t -> t -> t
     val diff: t -> t -> t
     val complement: t -> t
-        (* Union, intersection, difference and set complement. *)
+        (** Union, intersection, difference and set complement. *)
     val equal: t -> t -> bool
-        (* [equal s1 s2] tests whether the sets [s1] and [s2] are
+        (** [equal s1 s2] tests whether the sets [s1] and [s2] are
            equal, that is, contain equal elements. *)
     val subset: t -> t -> bool
-        (* [subset s1 s2] tests whether the set [s1] is a subset of
+        (** [subset s1 s2] tests whether the set [s1] is a subset of
            the set [s2]. *)
     val elements: t -> bool * elt list
-        (* Gives a finite representation of the predicate: if the
+        (** Gives a finite representation of the predicate: if the
            boolean is false, then the predicate is given in extension.
            if it is true, then the complement is given *)
   end
 
 module Make(Ord: OrderedType): (S with type elt = Ord.t)
-        (* Functor building an implementation of the set structure
+        (** Functor building an implementation of the set structure
            given a totally ordered type. *)
diff --git a/lib/profile.ml b/lib/profile.ml
index 95163a27..a6e2faa4 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -1,17 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: profile.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Gc
-
 let word_length = Sys.word_size / 8
-let int_size = Sys.word_size - 1
 
 let float_of_time t = float_of_int t /. 100.
 let time_of_float f = int_of_float (f *. 100.)
@@ -354,7 +349,6 @@ let close_profile print =
 	end
     | _ -> failwith "Inconsistency"
 
-let append_profile () = close_profile false
 let print_profile () = close_profile true
 
 let declare_profile name =
diff --git a/lib/profile.mli b/lib/profile.mli
index 208238e7..bd113687 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: profile.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** {6 This program is a small time and allocation profiler for Objective Caml } *)
 
-(*s This program is a small time and allocation profiler for Objective Caml *)
+(** Adapted from Christophe Raffalli *)
 
-(*i It requires the UNIX library *)
-
-(* Adapted from Christophe Raffalli *)
-
-(* To use it, link it with the program you want to profile.
+(** 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 :
 
@@ -106,23 +102,23 @@ val profile7 :
     -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
 
 
-(* Some utilities to compute the logical and physical sizes and depth
+(** Some utilities to compute the logical and physical sizes and depth
    of ML objects *)
 
-(* Print logical size (in words) and depth of its argument *)
-(* This function does not disturb the heap *)
+(** Print logical size (in words) and depth of its argument 
+   This function does not disturb the heap *)
 val print_logical_stats : 'a -> unit
 
-(* Print physical size, logical size (in words) and depth of its argument *)
-(* This function allocates itself a lot (the same order of magnitude
+(** Print physical size, logical size (in words) and depth of its argument 
+   This function allocates itself a lot (the same order of magnitude
    as the physical size of its argument) *)
 val print_stats : 'a -> unit
 
-(* Return logical size (first for strings, then for not strings),
-   (in words) and depth of its argument *)
-(* This function allocates itself a lot *)
+(** Return logical size (first for strings, then for not strings),
+   (in words) and depth of its argument 
+   This function allocates itself a lot *)
 val obj_stats : 'a -> int * int * int
 
-(* Return physical size of its argument (string part and rest) *)
-(* This function allocates itself a lot *)
+(** Return physical size of its argument (string part and rest) 
+   This function allocates itself a lot *)
 val obj_shared_size : 'a -> int * int
diff --git a/lib/refutpat.ml4 b/lib/refutpat.ml4
deleted file mode 100644
index db25ce73..00000000
--- a/lib/refutpat.ml4
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 991ed25c..22d3d72b 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 
 
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 01fff68a..6695fc82 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -1,24 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Type of regular tree with nodes labelled by values of type 'a *)
-(* The implementation uses de Bruijn indices, so binding capture
+(** 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
 
-(* Building trees *)
+(** Building trees *)
 
-(* build a node given a label and the vector of sons *)
+(** build a node given a label and the vector of sons *)
 val mk_node  : 'a -> 'a t array -> 'a t
 
-(* Build mutually recursive trees:
+(** Build mutually recursive trees:
     X_1 = f_1(X_1,..,X_n) ... X_n = f_n(X_1,..,X_n)
    is obtained by the following pseudo-code
    let vx = mk_rec_calls n in
@@ -32,27 +30,29 @@ val mk_node  : 'a -> 'a t array -> 'a t
   Another example: nested recursive trees rec Y = b(rec X = a(X,Y),Y,Y)
   let [|vy|] = mk_rec_calls 1 in
   let [|vx|] = mk_rec_calls 1 in
-  let [|x|] = mk_rec[|mk_node a [|vx;lift 1 vy|]
-  let [|y|] = mk_rec[|mk_node b [|x;vy;vy|]|]
+  let [|x|] = mk_rec[|mk_node a vx;lift 1 vy|]
+  let [|y|] = mk_rec[|mk_node b x;vy;vy|]
   (note the lift to avoid
  *)
 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
+(** [lift k t] increases of [k] the free parameters of [t]. Needed
    to avoid captures when a tree appears under [mk_rec] *)
 val lift : int -> 'a t -> 'a t
 
 val is_node : 'a t -> bool
-(* Destructors (recursive calls are expanded) *)
+
+(** Destructors (recursive calls are expanded) *)
 val dest_node  : 'a t -> 'a * 'a t array
-(* dest_param is not needed for closed trees (i.e. with no free variable) *)
+
+(** dest_param is not needed for closed trees (i.e. with no free variable) *)
 val dest_param : 'a t -> int * int
 
-(* Tells if a tree has an infinite branch *)
+(** Tells if a tree has an infinite branch *)
 val is_infinite : 'a t -> bool
 
-(* [compare_rtree f t1 t2] compares t1 t2 (top-down).
+(** [compare_rtree f t1 t2] compares t1 t2 (top-down).
    f is called on each node: if the result is negative then the
    traversal ends on false, it is is positive then deeper nodes are
    not examined, and the traversal continues on respective siblings,
@@ -66,14 +66,15 @@ val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool
 
 val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
 
-(* Iterators *)
+(** Iterators *)
 
 val map : ('a -> 'b) -> 'a t -> 'b t
-(* [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
+
+(** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
 val smartmap : ('a -> 'a) -> 'a t -> 'a t
 val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b
 val fold2 :
   (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c
 
-(* A rather simple minded pretty-printer *)
+(** A rather simple minded pretty-printer *)
 val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
diff --git a/lib/segmenttree.ml b/lib/segmenttree.ml
index 2a7f9df0..9ce348a0 100644
--- a/lib/segmenttree.ml
+++ b/lib/segmenttree.ml
@@ -40,7 +40,6 @@ type domain =
 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
diff --git a/lib/segmenttree.mli b/lib/segmenttree.mli
index 4aea13e9..3258537b 100644
--- a/lib/segmenttree.mli
+++ b/lib/segmenttree.mli
@@ -7,7 +7,7 @@
 (** 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
+(** [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. *)
diff --git a/lib/store.ml b/lib/store.ml
new file mode 100644
index 00000000..bc1b335f
--- /dev/null
+++ b/lib/store.ml
@@ -0,0 +1,61 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*** This module implements an "untyped store", in this particular case we
+        see it as an extensible record whose fields are left unspecified. ***)
+
+(* We give a short implementation of a universal type. This is mostly equivalent
+    to what is proposed by module Dyn.ml, except that it requires no explicit tag. *)
+module type Universal = sig
+  type t
+  
+  type 'a etype = {
+     put : 'a -> t ;
+     get : t -> 'a option
+  }
+
+  val embed : unit -> 'a etype
+end
+
+(* We use a dynamic "name" allocator. But if we needed to serialise stores, we
+might want something static to avoid troubles with plugins order. *)
+
+let next =
+  let count = ref 0 in fun () ->
+  let n = !count in
+  incr count;
+  n
+
+type t = Obj.t Util.Intmap.t
+
+module Field = struct
+  type 'a field = {
+    set : 'a -> t -> t ;
+    get : t -> 'a option ;
+    remove : t -> t 
+  }
+  type 'a t = 'a field
+end
+
+open Field
+
+let empty = Util.Intmap.empty
+
+let field () =
+  let fid = next () in
+  let set a s =
+    Util.Intmap.add fid (Obj.repr a) s
+  in
+  let get s =
+    try Some (Obj.obj (Util.Intmap.find fid s))
+    with _ -> None
+  in
+  let remove s =
+    Util.Intmap.remove fid s
+  in
+  { set = set ; get = get ; remove = remove }
diff --git a/lib/store.mli b/lib/store.mli
new file mode 100644
index 00000000..5df0c99a
--- /dev/null
+++ b/lib/store.mli
@@ -0,0 +1,25 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*** This module implements an "untyped store", in this particular case we
+        see it as an extensible record whose fields are left unspecified. ***)
+
+type t
+
+module Field : sig
+  type 'a field = {
+    set : 'a -> t -> t ;
+    get : t -> 'a option ;
+    remove : t -> t 
+  }
+  type 'a t = 'a field
+end
+
+val empty : t
+
+val field : unit -> 'a Field.field
diff --git a/lib/system.ml b/lib/system.ml
index 94a57792..7d54e2c3 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: system.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -33,7 +33,7 @@ let home =
       try Sys.getenv "USERPROFILE" with Not_found ->
 	warning ("Cannot determine user home directory, using '.' .");
 	flush_all ();
-	"."
+	Filename.current_dir_name
 
 let safe_getenv n = safe_getenv_def n ("$"^n)
 
@@ -72,20 +72,49 @@ type load_path = physical_path list
 let physical_path_of_string s = s
 let string_of_physical_path p = p
 
+(* 
+ * Split a path into a list of directories. A one-liner with Str, but Coq
+ * doesn't seem to use this library at all, so here is a slighly longer version.
+ *)
+
+let lpath_from_path path path_separator =
+  let n = String.length path in
+  let rec aux i l =
+    if i < n then
+      let j =
+        try String.index_from path i path_separator
+        with Not_found -> n
+      in
+      let dir = String.sub path i (j-i) in
+      aux (j+1) (dir::l)
+    else
+      l
+  in List.rev (aux 0 [])
+
 (* Hints to partially detects if two paths refer to the same repertory *)
 let rec remove_path_dot p =
   let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
   let n = String.length curdir in
-  if String.length p > n && String.sub p 0 n = curdir then
-    remove_path_dot (String.sub p n (String.length p - n))
+  let l = String.length p in
+  if l > n && String.sub p 0 n = curdir then
+    let n' =
+      let sl = String.length Filename.dir_sep in
+      let i = ref n in
+	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
+    remove_path_dot (String.sub p n' (l - n'))
   else
     p
 
 let strip_path p =
   let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
   let n = String.length cwd in
-  if String.length p > n && String.sub p 0 n = cwd then
-    remove_path_dot (String.sub p n (String.length p - n))
+  let l = String.length p in
+  if l > n && String.sub p 0 n = cwd then
+    let n' =
+      let sl = String.length Filename.dir_sep in
+      let i = ref n in
+	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
+    remove_path_dot (String.sub p n' (l - n'))
   else
     remove_path_dot p
 
@@ -179,6 +208,14 @@ let is_in_path lpath filename =
   try ignore (where_in_path ~warn:false lpath filename); true
   with Not_found -> false
 
+let path_separator = if Sys.os_type = "Unix" then ':' else ';'
+
+let is_in_system_path filename =
+  let path = try Sys.getenv "PATH" 
+             with Not_found -> error "system variable PATH not found" in
+  let lpath = lpath_from_path path path_separator in
+  is_in_path lpath filename
+
 let make_suffix name suffix =
   if Filename.check_suffix name suffix then name else (name ^ suffix)
 
@@ -300,34 +337,10 @@ let run_command converter f c =
   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 t = times ()  in
-  (t.tms_utime, t.tms_stime)
-
 let get_time () =
   let t = times ()  in
   (time(), t.tms_utime, t.tms_stime)
diff --git a/lib/system.mli b/lib/system.mli
index 6998085c..fae7fd1e 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -1,18 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: system.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** System utilities *)
 
-(*s Files and load paths. Load path entries remember the original root
+(** {6 Files and load paths} *)
+
+(** Load path entries remember the original root
     given by the user. For efficiency, we keep the full path (field
     [directory]), the root path and the path relative to the root. *)
 
-
 type physical_path = string
 type load_path = physical_path list
 
@@ -22,6 +23,7 @@ val exclude_search_in_dirname : string -> unit
 
 val all_subdirs : unix_path:string -> (physical_path * string list) list
 val is_in_path : load_path -> string -> bool
+val is_in_system_path : string -> bool
 val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string
 
 val physical_path_of_string : string -> physical_path
@@ -39,7 +41,8 @@ val exists_dir : string -> bool
 val find_file_in_path :
   ?warn:bool -> load_path -> string -> physical_path * string
 
-(*s Generic input and output functions, parameterized by a magic number
+(** {6 I/O functions } *)
+(** Generic input and output functions, parameterized by a magic number
   and a suffix. The intern functions raise the exception [Bad_magic_number]
   when the check fails, with the full file name. *)
 
@@ -56,11 +59,12 @@ val extern_intern : ?warn:bool -> int -> string ->
 
 val with_magic_number_check : ('a -> 'b) -> 'a -> 'b
 
-(*s Sending/receiving once with external executable *)
+(** {6 Sending/receiving once with external executable } *)
 
 val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
 
-(*s [run_command converter f com] launches command [com], and returns
+(** {6 Executing commands } *)
+(** [run_command converter f com] launches command [com], and returns
     the contents of stdout and stderr that have been processed with
     [converter]; the processed contents of stdout and stderr is also
     passed to [f] *)
@@ -68,13 +72,10 @@ val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
 val run_command : (string -> string) -> (string -> unit) -> string ->
   Unix.process_status * string
 
-val search_exe_in_path : string -> string option
-
-(*s Time stamps. *)
+(** {6 Time stamps.} *)
 
 type time
 
-val process_time : unit -> float * float
 val get_time : unit -> time
-val time_difference : time -> time -> float (* in seconds *)
+val time_difference : time -> time -> float (** in seconds *)
 val fmt_time_difference : time -> time -> Pp.std_ppcmds
diff --git a/lib/tlm.ml b/lib/tlm.ml
deleted file mode 100644
index 17d337c8..00000000
--- a/lib/tlm.ml
+++ /dev/null
@@ -1,63 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: tlm.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t
-
-let empty = Node (Gset.empty, Gmap.empty)
-
-let map (Node (_,m)) lbl = Gmap.find lbl m
-
-let xtract (Node (hereset,_)) = Gset.elements hereset
-
-let dom (Node (_,m)) = Gmap.dom m
-
-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
-    m
-  else
-    Gmap.add lbl (Node (Gset.empty,Gmap.empty)) m
-
-let cleanse_arcs (Node (hereset,m)) =
-  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
-      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 rec apprec pfx (Node(hereset,m)) =
-    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
-  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)) (Gset.elements hereset))::
-		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (Gmap.to_list m)))
-  in
-  torec [] tlm
diff --git a/lib/tlm.mli b/lib/tlm.mli
deleted file mode 100644
index 9042281f..00000000
--- a/lib/tlm.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: tlm.mli 14641 2011-11-06 11:59:10Z herbelin $ 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]. *)
-
-type ('a,'b) t
-
-val empty : ('a,'b) t
-
-(* Work on labels, not on paths. *)
-
-val map : ('a,'b) t -> 'a -> ('a,'b) t
-val xtract : ('a,'b) t -> 'b list
-val dom : ('a,'b) t -> 'a list
-val in_dom : ('a,'b) t -> 'a -> bool
-
-(* Work on paths, not on labels. *)
-
-val add : ('a,'b) t -> 'a list * 'b -> ('a,'b) t
-val rmv : ('a,'b) t -> ('a list * 'b) -> ('a,'b) t
-
-val app : (('a list * 'b) -> unit) -> ('a,'b) t -> unit
-val to_list : ('a,'b) t -> ('a list * 'b) list
-
diff --git a/lib/tries.ml b/lib/tries.ml
index 2540bd1e..e7fe8a66 100644
--- a/lib/tries.ml
+++ b/lib/tries.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/lib/tries.mli b/lib/tries.mli
index 342c81ec..8e837677 100644
--- a/lib/tries.mli
+++ b/lib/tries.mli
@@ -12,7 +12,7 @@ sig
     
   val empty : t
       
-  (* Work on labels, not on paths. *)
+  (** Work on labels, not on paths. *)
 
   val map : t -> Y.t -> t
 
@@ -22,7 +22,7 @@ sig
 
   val in_dom : t -> Y.t -> bool
 
-  (* Work on paths, not on labels. *)
+  (** Work on paths, not on labels. *)
 
   val add : t -> Y.t list * X.t -> t
   
diff --git a/lib/unionfind.ml b/lib/unionfind.ml
new file mode 100644
index 00000000..b05f8de0
--- /dev/null
+++ b/lib/unionfind.ml
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** An imperative implementation of partitions via Union-Find *)
+
+(** Paths are compressed imperatively at each lookup of a
+    canonical representative. Each union also modifies in-place
+    the partition structure.
+
+    Nota: For the moment we use Pervasive's comparison for
+    choosing the smallest object as representative. This could
+    be made more generic.
+*)
+
+
+
+module type PartitionSig = sig
+
+  (** The type of elements in the partition *)
+  type elt
+
+  (** A set structure over elements *)
+  type set
+
+  (** The type of partitions *)
+  type t
+
+  (** Initialise an empty partition *)
+  val create : unit -> t
+
+  (** Add (in place) an element in the partition, or do nothing
+      if the element is already in the partition. *)
+  val add : elt -> t -> unit
+
+  (** Find the canonical representative of an element.
+      Raise [not_found] if the element isn't known yet. *)
+  val find : elt -> t -> elt
+
+  (** Merge (in place) the equivalence classes of two elements.
+      This will add the elements in the partition if necessary. *)
+  val union : elt -> elt -> t -> unit
+
+  (** Merge (in place) the equivalence classes of many elements. *)
+  val union_set : set -> t -> unit
+
+  (** Listing the different components of the partition *)
+  val partition : t -> set list
+
+end
+
+module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
+
+  type elt = S.elt
+  type set = S.t
+
+  type node =
+    | Canon of set
+    | Equiv of elt
+
+  type t = node ref M.t ref
+
+  let create () = ref (M.empty : node ref M.t)
+
+  let fresh x p =
+    let node = ref (Canon (S.singleton x)) in
+    p := M.add x node !p;
+    x, node
+
+  let rec lookup x p =
+    let node = M.find x !p in
+    match !node with
+      | Canon _ -> x, node
+      | Equiv y ->
+	let ((z,_) as res) = lookup y p in
+	if not (z == y) then node := Equiv z;
+	res
+
+  let add x p = if not (M.mem x !p) then ignore (fresh x p)
+
+  let find x p = fst (lookup x p)
+
+  let canonical x p = try lookup x p with Not_found -> fresh x p
+
+  let union x y p =
+    let ((x,_) as xcan) = canonical x p in
+    let ((y,_) as ycan) = canonical y p in
+    if x = y then ()
+    else
+      let xcan, ycan = if x < y then xcan, ycan else ycan, xcan in
+      let x,xnode = xcan and y,ynode = ycan in
+      match !xnode, !ynode with
+	| Canon lx, Canon ly ->
+	  xnode := Canon (S.union lx ly);
+	  ynode := Equiv x;
+	| _ -> assert false
+
+  let union_set s p =
+    try
+      let x = S.min_elt s in
+      S.iter (fun y -> union x y p) s
+    with Not_found -> ()
+
+  let partition p =
+    List.rev (M.fold
+		(fun x node acc -> match !node with
+		  | Equiv _ -> acc
+		  | Canon lx -> lx::acc)
+		!p [])
+
+end
diff --git a/lib/unionfind.mli b/lib/unionfind.mli
new file mode 100644
index 00000000..07ee7c2b
--- /dev/null
+++ b/lib/unionfind.mli
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** An imperative implementation of partitions via Union-Find *)
+
+(** Paths are compressed imperatively at each lookup of a
+    canonical representative. Each union also modifies in-place
+    the partition structure.
+
+    Nota: for the moment we use Pervasive's comparison for
+    choosing the smallest object as representative. This could
+    be made more generic.
+*)
+
+module type PartitionSig = sig
+
+  (** The type of elements in the partition *)
+  type elt
+
+  (** A set structure over elements *)
+  type set
+
+  (** The type of partitions *)
+  type t
+
+  (** Initialise an empty partition *)
+  val create : unit -> t
+
+  (** Add (in place) an element in the partition, or do nothing
+      if the element is already in the partition. *)
+  val add : elt -> t -> unit
+
+  (** Find the canonical representative of an element.
+      Raise [not_found] if the element isn't known yet. *)
+  val find : elt -> t -> elt
+
+  (** Merge (in place) the equivalence classes of two elements.
+      This will add the elements in the partition if necessary. *)
+  val union : elt -> elt -> t -> unit
+
+  (** Merge (in place) the equivalence classes of many elements. *)
+  val union_set : set -> t -> unit
+
+  (** Listing the different components of the partition *)
+  val partition : t -> set list
+
+end
+
+module Make :
+  functor (S:Set.S) ->
+    functor (M:Map.S with type key = S.elt) ->
+      PartitionSig with type elt = S.elt and type set = S.t
diff --git a/lib/util.ml b/lib/util.ml
index 9a8c724f..287dd371 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,9 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: util.ml 13492 2010-10-04 21:20:01Z herbelin $ *)
-
 open Pp
+open Compat
 
 (* Errors *)
 
@@ -17,11 +16,9 @@ let anomaly string = raise (Anomaly(string, str string))
 let anomalylabstrm string pps = raise (Anomaly(string,pps))
 
 exception UserError of string * std_ppcmds (* User errors *)
-let error string = raise (UserError(string, str string))
+let error string = raise (UserError("_", 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))
 
@@ -29,17 +26,17 @@ let todo s = prerr_string ("TODO: "^s^"\n")
 
 exception Timeout
 
-type loc = Compat.loc
-let dummy_loc = Compat.dummy_loc
-let unloc = Compat.unloc
-let make_loc = Compat.make_loc
-let join_loc = Compat.join_loc
+type loc = Loc.t
+let dummy_loc = Loc.ghost
+let join_loc = Loc.merge
+let make_loc = make_loc
+let unloc = unloc
 
 (* raising located exceptions *)
 type 'a located = loc * 'a
-let anomaly_loc (loc,s,strm) = 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 anomaly_loc (loc,s,strm) = Loc.raise loc (Anomaly (s,strm))
+let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
+let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
 
 let located_fold_left f x (_,a) = f x a
 let located_iter2 f (_,a) (_,b) = f a b
@@ -54,6 +51,7 @@ 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)
+let map_pair f (a,b) = (f a,f b)
 
 (* Mapping under pairs *)
 
@@ -402,6 +400,13 @@ let rec list_compare cmp l1 l2 =
 	   | 0 -> list_compare cmp l1 l2
 	   | c -> c)
 
+let rec list_equal cmp l1 l2 =
+  match l1, l2 with
+    | [], [] -> true
+    | x1 :: l1, x2 :: l2 ->
+      cmp x1 x2 && list_equal cmp l1 l2
+    | _ -> false
+
 let list_intersect l1 l2 =
   List.filter (fun x -> List.mem x l2) l1
 
@@ -425,24 +430,21 @@ let list_subtract 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 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
-  chop_aux [] (n,l)
-
 let list_tabulate f len =
   let rec tabrec n =
     if n = len then [] else (f n)::(tabrec (n+1))
   in
   tabrec 0
 
-let rec list_make n v =
-  if n = 0 then []
-  else if n < 0 then invalid_arg "list_make"
-  else v::list_make (n-1) v
+let list_addn n v =
+  let rec aux n l =
+    if n = 0 then l
+    else aux (pred n) (v::l)
+  in
+    if n < 0 then invalid_arg "list_addn"
+    else aux n
+
+let list_make n v = list_addn n v []
 
 let list_assign l n e =
   let rec assrec stk = function
@@ -497,6 +499,24 @@ let list_map4 f l1 l2 l3 l4 =
   in
   map (l1,l2,l3,l4)
 
+let rec list_smartfilter f l = match l with
+    [] -> l
+  | h::tl ->
+      let tl' = list_smartfilter f tl in
+	if f h then
+	  if tl' == tl then l
+	  else h :: tl'
+	else tl'
+	  
+let list_index_f f x =
+  let rec index_x n = function
+    | y::l -> if f x y then n else index_x (succ n) l
+    | [] -> raise Not_found
+  in
+  index_x 1
+
+let list_index0_f f x l = list_index_f f x l - 1
+
 let list_index x =
   let rec index_x n = function
     | y::l -> if x = y then n else index_x (succ n) l
@@ -584,6 +604,10 @@ let rec list_remove_assoc_in_triple x = function
   | [] -> []
   | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l
 
+let rec list_assoc_snd_in_triple x = function
+    [] -> raise Not_found
+  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l
+
 let list_add_set x l = if List.mem x l then l else x::l
 
 let list_eq_set l1 l2 =
@@ -676,6 +700,14 @@ let rec list_map_filter f = function
       let l' = list_map_filter f l in
       match f x with None -> l' | Some y -> y::l'
 
+let list_map_filter_i f =
+  let rec aux i = function
+    | [] -> []
+    | x::l ->
+      let l' = aux (succ i) l in
+	match f i x with None -> l' | Some y -> y::l'
+  in aux 0
+
 let list_subset l1 l2 =
   let t2 = Hashtbl.create 151 in
   List.iter (fun x -> Hashtbl.add t2 x ()) l2;
@@ -685,15 +717,17 @@ let list_subset l1 l2 =
   in
   look l1
 
-(* [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_chop i l] splits [l] into two lists [(l1,l2)] such that
+   [l1++l2=l] and [l1] has length [i].
+   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+
+let list_chop n l =
+  let rec chop_aux i acc = function
+    | tl when i=0 -> (List.rev acc, tl)
+    | h::t -> chop_aux (pred i) (h::acc) t
+    | [] -> failwith "list_chop"
+  in
+  chop_aux n [] l
 
 (* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
     [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
@@ -757,9 +791,6 @@ let rec list_skipn n l = match n,l with
 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 rec prefrec = function
     | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
@@ -815,6 +846,10 @@ let list_fold_map' f l e =
 
 let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
 
+let rec list_assoc_f f a = function
+  | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs
+  | [] -> raise Not_found
+
 (* Specification:
    - =p= is set equality (double inclusion)
    - f such that \forall l acc, (f l acc) =p= append (f l []) acc
@@ -878,6 +913,12 @@ let array_compare item_cmp v1 v2 =
 	  else cmp (i-1) in
     cmp (Array.length v1 - 1)
 
+let array_equal cmp t1 t2 =
+  Array.length t1 = Array.length t2 &&
+  let rec aux i =
+    (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1))
+  in aux 0
+
 let array_exists f v =
   let rec exrec = function
     | -1 -> false
@@ -998,6 +1039,15 @@ let array_fold_left2_i f a v1 v2 =
   if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
   fold a 0
 
+let array_fold_left3 f a v1 v2 v3 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n)
+  in
+  if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
+    invalid_arg "array_fold_left2";
+  fold a 0
+
 let array_fold_left_from n f a v =
   let rec fold a n =
     if n >= Array.length v then a else fold (f a v.(n)) (succ n)
@@ -1167,6 +1217,15 @@ let array_rev_to_list a =
     if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
   tolist 0 []
 
+(* Stream *)
+
+let stream_nth n st =
+  try List.nth (Stream.npeek (n+1) st) n
+  with Failure _ -> raise Stream.Failure
+
+let stream_njunk n st =
+  for i = 1 to n do Stream.junk st done
+
 (* Matrices *)
 
 let matrix_transpose mat =
diff --git a/lib/util.mli b/lib/util.mli
index e5b5f8c6..1fec2295 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -1,21 +1,19 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
 
-(*i $Id: util.mli 13492 2010-10-04 21:20:01Z herbelin $ i*)
-
-(*i*)
 open Pp
-(*i*)
+open Compat
 
-(* This module contains numerous utility functions on strings, lists,
+(** This module contains numerous utility functions on strings, lists,
    arrays, etc. *)
 
-(*s Errors. [Anomaly] is used for system errors and [UserError] for the
+(** {6 ... } *)
+(** Errors. [Anomaly] is used for system errors and [UserError] for the
    user's ones. *)
 
 exception Anomaly of string * std_ppcmds
@@ -29,9 +27,7 @@ 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
+(** [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 *)
 
@@ -39,57 +35,59 @@ val todo : string -> unit
 
 exception Timeout
 
-type loc = Compat.loc
+type loc = Loc.t
 
 type 'a located = loc * 'a
 
 val unloc : loc -> int * int
 val make_loc : int * int -> loc
 val dummy_loc : loc
+val join_loc : loc -> loc -> loc
+
 val anomaly_loc : loc * string * std_ppcmds -> 'a
 val user_err_loc : loc * string * std_ppcmds -> 'a
 val invalid_arg_loc : loc * string -> 'a
-val join_loc : loc -> loc -> loc
 val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
 val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
 val down_located : ('a -> 'b) -> 'a located -> 'b
 
-(* Like [Exc_located], but specifies the outermost file read, the
+(** Like [Exc_located], but specifies the outermost file read, the
    input buffer associated to the location of the error (or the module name
    if boolean is true), and the error itself. *)
 
 exception Error_in_file of string * (bool * string * loc) * exn
 
-(* Mapping under pairs *)
+(** Mapping under pairs *)
 
 val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
 val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
+val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b
 
-(* Going down pairs *)
+(** Going down pairs *)
 
 val down_fst : ('a -> 'b) -> 'a * 'c -> 'b
 val down_snd : ('a -> 'b) -> 'c * 'a -> 'b
 
-(* Mapping under triple *)
+(** 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 *)
+(** {6 Projections from triplets } *)
 
 val pi1 : 'a * 'b * 'c -> 'a
 val pi2 : 'a * 'b * 'c -> 'b
 val pi3 : 'a * 'b * 'c -> 'c
 
-(*s Chars. *)
+(** {6 Chars. } *)
 
 val is_letter : char -> bool
 val is_digit : char -> bool
 val is_ident_tail : char -> bool
 val is_blank : char -> bool
 
-(*s Strings. *)
+(** {6 Strings. } *)
 
 val explode : string -> string list
 val implode : string list -> string
@@ -116,9 +114,10 @@ val check_ident_soft : string -> unit
 val lowercase_first_char_utf8 : string -> string
 val ascii_of_ident : string -> string
 
-(*s Lists. *)
+(** {6 Lists. } *)
 
 val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
+val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
 val list_add_set : 'a -> 'a list -> 'a list
 val list_eq_set : 'a list -> 'a list -> bool
 val list_intersect : 'a list -> 'a list -> 'a list
@@ -126,8 +125,8 @@ val list_union : 'a list -> 'a list -> 'a list
 val list_unionq : 'a list -> 'a list -> 'a list
 val list_subtract : 'a list -> 'a list -> 'a list
 val list_subtractq : 'a list -> 'a list -> 'a list
-val list_chop : int -> 'a list -> 'a list * 'a list
-(* [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
+
+(** [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
 val list_tabulate : (int -> 'a) -> int -> 'a list
 val list_make : int -> 'a -> 'a list
 val list_assign : 'a list -> int -> 'a -> 'a list
@@ -135,7 +134,9 @@ val list_distinct : 'a list -> bool
 val list_duplicates : 'a list -> 'a list
 val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
 val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
-(* [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
+val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
    [ f ai == ai], then [list_smartmap f l==l] *)
 val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
 val list_map_left : ('a -> 'b) -> 'a list -> 'b list
@@ -148,12 +149,21 @@ 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) *)
+
+(** [list_smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
+   [f ai = true], then [list_smartfilter f l==l] *)
+val list_smartfilter : ('a -> bool) -> 'a list -> 'a list
+
+(** [list_index] returns the 1st index of an element in a list (counting from 1) *)
 val list_index : 'a -> 'a list -> int
-(* [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
+val list_index_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
+
+(** [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
 val list_unique_index : 'a -> 'a list -> int
-(* [list_index0] behaves as [list_index] except that it starts counting at 0 *)
+
+(** [list_index0] behaves as [list_index] except that it starts counting at 0 *)
 val list_index0 : 'a -> 'a list -> int
+val list_index0_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
 val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit
 val list_iter_i :  (int -> 'a -> unit) -> 'a list -> unit
 val list_fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
@@ -166,15 +176,18 @@ val list_except : 'a -> 'a list -> 'a list
 val list_remove : 'a -> 'a list -> 'a list
 val list_remove_first : 'a -> 'a list -> 'a list
 val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list
+val list_assoc_snd_in_triple : 'a -> ('a * 'b * 'c) list -> 'b
 val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
 val list_sep_last : 'a list -> 'a * 'a list
 val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b
 val list_try_find : ('a -> 'b) -> 'a list -> 'b
 val list_uniquize : 'a list -> 'a list
-(* merges two sorted lists and preserves the uniqueness property: *)
+
+(** 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 : int -> 'a list -> 'a list*'a list
+val list_chop : int -> 'a list -> 'a list * 'a list
+(* former [list_split_at] was a duplicate of [list_chop] *)
 val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
 val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
 val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
@@ -186,28 +199,36 @@ 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] *)
+
+(** [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)] *)
+
+(** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
 val list_map_append : ('a -> 'b list) -> 'a list -> 'b list
 val list_join_map : ('a -> 'b list) -> 'a list -> 'b list
-(* raises [Invalid_argument] if the two lists don't have the same length *)
+
+(** raises [Invalid_argument] if the two lists don't have the same length *)
 val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
 val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
-(* [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
+
+(** [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
    where [(e_i,k_i)=f e_{i-1} l_i] *)
 val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
 val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
 val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
-(* A generic cartesian product: for any operator (**),
+val list_assoc_f : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
+
+(** A generic cartesian product: for any operator (**),
    [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
    and so on if there are more elements in the lists. *)
 val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-(* [list_cartesians] is an n-ary cartesian product: it iterates
+
+(** [list_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]] *)
+
+(** list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
 val list_combinations : 'a list list -> 'a list list
 val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
 
@@ -219,9 +240,10 @@ val list_cartesians_filter :
 
 val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
 
-(*s Arrays. *)
+(** {6 Arrays. } *)
 
 val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+val array_equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
 val array_exists : ('a -> bool) -> 'a array -> bool
 val array_for_all : ('a -> bool) -> 'a array -> bool
 val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
@@ -243,6 +265,8 @@ val array_fold_right2 :
   ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
 val array_fold_left2 :
   ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+val array_fold_left3 :
+  ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
 val array_fold_left2_i :
   (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
 val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
@@ -268,11 +292,16 @@ 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 *)
+(** {6 Streams. } *)
+
+val stream_nth : int -> 'a Stream.t -> 'a
+val stream_njunk : int -> 'a Stream.t -> unit
+
+(** {6 Matrices. } *)
 
 val matrix_transpose : 'a list list -> 'a list list
 
-(*s Functions. *)
+(** {6 Functions. } *)
 
 val identity : 'a -> 'a
 val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
@@ -302,12 +331,12 @@ val intmap_inv : 'a Intmap.t -> 'a -> int list
 val interval : int -> int -> int list
 
 
-(* In [map_succeed f l] an element [a] is removed if [f a] raises *)
-(* [Failure _] otherwise behaves as [List.map f l] *)
+(** In [map_succeed f l] an element [a] is removed if [f a] raises 
+   [Failure _] otherwise behaves as [List.map f l] *)
 
 val map_succeed : ('a -> 'b) -> 'a list -> 'b list
 
-(*s Pretty-printing. *)
+(** {6 Pretty-printing. } *)
 
 val pr_spc : unit -> std_ppcmds
 val pr_fnl : unit -> std_ppcmds
@@ -322,7 +351,8 @@ val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
 val nth : int -> std_ppcmds
 
 val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-(* unlike all other functions below, [prlist] works lazily.
+
+(** unlike all other functions below, [prlist] works lazily.
    if a strict behavior is needed, use [prlist_strict] instead. *)
 val prlist_strict :  ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 val prlist_with_sep :
@@ -339,34 +369,36 @@ val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
 val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 val surround : std_ppcmds -> std_ppcmds
 
-(*s Memoization. *)
+(** {6 Memoization. } *)
 
-(* General comments on memoization:
+(** General comments on memoization:
    - cache is created whenever the function is supplied (because of
       ML's polymorphic value restriction).
    - cache is never flushed (unless the memoized fun is GC'd)
- *)
-(* One cell memory: memorizes only the last call *)
+ 
+   One cell memory: memorizes only the last call *)
 val memo1_1 : ('a -> 'b) -> ('a -> 'b)
 val memo1_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
-(* with custom equality (used to deal with various arities) *)
+
+(** with custom equality (used to deal with various arities) *)
 val memo1_eq : ('a -> 'a -> bool) -> ('a -> 'b) -> ('a -> 'b)
 
-(* Memorizes the last [n] distinct calls. Efficient only for small [n]. *)
+(** Memorizes the last [n] distinct calls. Efficient only for small [n]. *)
 val memon_eq : ('a -> 'a -> bool) -> int -> ('a -> 'b) -> ('a -> 'b)
 
-(*s Size of an ocaml value (in words, bytes and kilobytes). *)
+(** {6 Size of an ocaml value (in words, bytes and kilobytes). } *)
 
 val size_w : 'a -> int
 val size_b : 'a -> int
 val size_kb : 'a -> int
 
-(*s Total size of the allocated ocaml heap. *)
+(** {6 Total size of the allocated ocaml heap. } *)
 
 val heap_size : unit -> int
 val heap_size_kb : unit -> int
 
-(*s Coq interruption: set the following boolean reference to interrupt Coq
+(** {6 ... } *)
+(** Coq interruption: set the following boolean reference to interrupt Coq
     (it eventually raises [Break], simulating a Ctrl-C) *)
 
 val interrupt : bool ref
diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli
new file mode 100644
index 00000000..a1ca0576
--- /dev/null
+++ b/lib/xml_lexer.mli
@@ -0,0 +1,44 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type error =
+	| EUnterminatedComment
+	| EUnterminatedString
+	| EIdentExpected
+	| ECloseExpected
+	| ENodeExpected
+	| EAttributeNameExpected
+	| EAttributeValueExpected
+	| EUnterminatedEntity
+
+exception Error of error
+
+type token =
+	| Tag of string * (string * string) list * bool
+	| PCData of string
+	| Endtag of string
+	| Eof
+
+type pos = int * int * int * int
+
+val init : Lexing.lexbuf -> unit 
+val close : Lexing.lexbuf -> unit
+val token : Lexing.lexbuf -> token
+val pos : Lexing.lexbuf -> pos
+val restore : pos -> unit
\ No newline at end of file
diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll
new file mode 100644
index 00000000..2be4bf98
--- /dev/null
+++ b/lib/xml_lexer.mll
@@ -0,0 +1,299 @@
+{(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+open Lexing
+
+type error =
+	| EUnterminatedComment
+	| EUnterminatedString
+	| EIdentExpected
+	| ECloseExpected
+	| ENodeExpected
+	| EAttributeNameExpected
+	| EAttributeValueExpected
+	| EUnterminatedEntity
+
+exception Error of error
+
+type pos = int * int * int * int
+
+type token =
+	| Tag of string * (string * string) list * bool
+	| PCData of string
+	| Endtag of string
+	| Eof
+
+let last_pos = ref 0
+and current_line = ref 0
+and current_line_start = ref 0
+
+let tmp = Buffer.create 200
+
+let idents = Hashtbl.create 0
+
+let _ = begin
+	Hashtbl.add idents "gt;" ">";
+	Hashtbl.add idents "lt;" "<";
+	Hashtbl.add idents "amp;" "&";
+	Hashtbl.add idents "apos;" "'";
+	Hashtbl.add idents "quot;" "\"";
+end
+
+let init lexbuf =
+	current_line := 1;
+	current_line_start := lexeme_start lexbuf;
+	last_pos := !current_line_start
+
+let close lexbuf =
+	Buffer.reset tmp
+
+let pos lexbuf =
+	!current_line ,	!current_line_start ,
+	!last_pos ,
+	lexeme_start lexbuf
+
+let restore (cl,cls,lp,_) =
+	current_line := cl;
+	current_line_start := cls;
+	last_pos := lp
+
+let newline lexbuf =
+	incr current_line;
+	last_pos := lexeme_end lexbuf;
+	current_line_start := !last_pos
+
+let error lexbuf e =
+	last_pos := lexeme_start lexbuf;
+	raise (Error e)
+
+}
+
+let newline = ['\n']
+let break = ['\r']
+let space = [' ' '\t']
+let identchar =  ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-']
+let entitychar = ['A'-'Z' 'a'-'z']
+let pcchar = [^ '\r' '\n' '<' '>' '&']
+
+rule token = parse
+	| newline | (newline break) | break
+		{
+			newline lexbuf;
+                        PCData "\n"
+		}
+	| "<!--"
+		{
+			last_pos := lexeme_start lexbuf;
+			comment lexbuf;
+			token lexbuf
+		}
+	| "<?"
+		{
+			last_pos := lexeme_start lexbuf;
+			header lexbuf;
+			token lexbuf;
+		}
+	| '<' space* '/' space*
+		{
+			last_pos := lexeme_start lexbuf;
+			let tag = ident_name lexbuf in
+			ignore_spaces lexbuf;
+			close_tag lexbuf;
+			Endtag tag
+		}
+	| '<' space*
+		{
+			last_pos := lexeme_start lexbuf;
+			let tag = ident_name lexbuf in
+			ignore_spaces lexbuf;
+			let attribs, closed = attributes lexbuf in
+			Tag(tag, attribs, closed)
+		}
+	| "&#"
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (lexeme lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| '&'
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (entity lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| pcchar+
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (lexeme lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| eof { Eof }
+	| _
+		{ error lexbuf ENodeExpected }
+
+and ignore_spaces = parse
+        | newline | (newline break) | break
+		{
+			newline lexbuf;
+			ignore_spaces lexbuf
+		}
+	| space +
+		{ ignore_spaces lexbuf }
+	| ""
+		{ () }
+
+and comment = parse
+        | newline | (newline break) | break
+		{
+			newline lexbuf;
+			comment lexbuf
+		}
+	| "-->"
+		{ () }
+	| eof
+		{ raise (Error EUnterminatedComment) }
+	| _
+		{ comment lexbuf }
+
+and header = parse
+        | newline | (newline break) | break
+		{
+			newline lexbuf;
+			header lexbuf
+		}
+	| "?>"
+		{ () }
+	| eof
+		{ error lexbuf ECloseExpected }
+	| _
+		{ header lexbuf }
+
+and pcdata = parse
+	| pcchar+
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf
+		}
+	| "&#"
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf;
+		}
+	| '&'
+		{
+			Buffer.add_string tmp (entity lexbuf);
+			pcdata lexbuf
+		}
+	| ""
+		{ Buffer.contents tmp }
+
+and entity = parse
+	| entitychar+ ';'
+		{
+			let ident = lexeme lexbuf in
+			try
+				Hashtbl.find idents (String.lowercase ident)
+			with
+				Not_found -> "&" ^ ident
+		}
+	| _ | eof
+		{ raise (Error EUnterminatedEntity) }
+
+and ident_name = parse
+	| identchar+
+		{ lexeme lexbuf }
+	| _ | eof
+		{ error lexbuf EIdentExpected }
+
+and close_tag = parse
+	| '>'
+		{ () }
+	| _ | eof
+		{ error lexbuf ECloseExpected }
+
+and attributes = parse
+	| '>'
+		{ [], false }
+	| "/>"
+		{ [], true }
+	| "" (* do not read a char ! *)
+		{
+			let key = attribute lexbuf in
+			let data = attribute_data lexbuf in
+			ignore_spaces lexbuf;
+			let others, closed = attributes lexbuf in
+			(key, data) :: others, closed
+		}
+
+and attribute = parse
+	| identchar+
+		{ lexeme lexbuf }
+	| _ | eof
+		{ error lexbuf EAttributeNameExpected }
+
+and attribute_data = parse
+	| space* '=' space* '"'
+		{
+			Buffer.reset tmp;
+			last_pos := lexeme_end lexbuf;
+			dq_string lexbuf
+		}
+	| space* '=' space* '\''
+		{
+			Buffer.reset tmp;
+			last_pos := lexeme_end lexbuf;
+			q_string lexbuf
+		}
+	| _ | eof
+		{ error lexbuf EAttributeValueExpected }
+
+and dq_string = parse
+	| '"'
+		{ Buffer.contents tmp }
+	| '\\' [ '"' '\\' ]
+		{
+			Buffer.add_char tmp (lexeme_char lexbuf 1);
+			dq_string lexbuf
+		}
+	| eof
+		{ raise (Error EUnterminatedString) }
+	| _
+		{ 
+			Buffer.add_char tmp (lexeme_char lexbuf 0);
+			dq_string lexbuf
+		}
+
+and q_string = parse
+	| '\''
+		{ Buffer.contents tmp }
+	| '\\' [ '\'' '\\' ]
+		{
+			Buffer.add_char tmp (lexeme_char lexbuf 1);
+			q_string lexbuf
+		}
+	| eof
+		{ raise (Error EUnterminatedString) }
+	| _
+		{ 
+			Buffer.add_char tmp (lexeme_char lexbuf 0);
+			q_string lexbuf
+		}
diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml
new file mode 100644
index 00000000..bf931d75
--- /dev/null
+++ b/lib/xml_parser.ml
@@ -0,0 +1,238 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ * Copyright (C) 2003 Jacques Garrigue
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+open Printf
+
+type xml = 
+        | Element of (string * (string * string) list * xml list)
+        | PCData of string
+
+type error_pos = {
+        eline : int;
+        eline_start : int;
+        emin : int;
+        emax : int;
+}
+
+type error_msg =
+        | UnterminatedComment
+        | UnterminatedString
+        | UnterminatedEntity
+        | IdentExpected
+        | CloseExpected
+        | NodeExpected
+        | AttributeNameExpected
+        | AttributeValueExpected
+        | EndOfTagExpected of string
+        | EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+type t = {
+	mutable check_eof : bool;
+	mutable concat_pcdata : bool;
+}
+
+type source = 
+	| SFile of string
+	| SChannel of in_channel
+	| SString of string
+	| SLexbuf of Lexing.lexbuf
+
+type state = {
+	source : Lexing.lexbuf;
+	stack : Xml_lexer.token Stack.t;
+	xparser : t;
+}
+
+exception Internal_error of error_msg
+exception NoMoreData
+
+let xml_error = ref (fun _ -> assert false)
+let file_not_found = ref (fun _ -> assert false)
+
+let is_blank s =
+  let len = String.length s in
+  let break = ref true in
+  let i = ref 0 in
+  while !break && !i < len do
+    let c = s.[!i] in
+    (* no '\r' because we replaced them in the lexer *)
+    if c = ' ' || c = '\n' || c = '\t' then incr i
+    else break := false
+  done;
+  !i = len
+
+let _raises e f =
+	xml_error := e;
+	file_not_found := f
+
+let make () =
+	{
+		check_eof = true;
+		concat_pcdata = true;
+	}
+
+let check_eof p v = p.check_eof <- v
+let concat_pcdata p v = p.concat_pcdata <- v
+
+let pop s =
+	try
+		Stack.pop s.stack
+	with
+		Stack.Empty ->
+			Xml_lexer.token s.source
+
+let push t s =
+	Stack.push t s.stack
+
+let canonicalize l =
+  let has_elt = List.exists (function Element _ -> true | _ -> false) l in
+  if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l
+  else l
+
+let rec read_node s =
+	match pop s with
+	| Xml_lexer.PCData s -> PCData s
+	| Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+	| Xml_lexer.Tag (tag, attr, false) ->
+          let elements = read_elems ~tag s in
+          Element (tag, attr, canonicalize elements)
+	| t ->
+		push t s;
+		raise NoMoreData
+and
+	read_elems ?tag s =
+		let elems = ref [] in
+		(try
+                  while true do
+                    let node = read_node s in
+                    match node, !elems with
+                    | PCData c , (PCData c2) :: q ->
+                      elems := PCData (c2 ^ c) :: q
+                    | _, l ->
+                      elems := node :: l
+                  done
+		with
+			NoMoreData -> ());
+		match pop s with
+		| Xml_lexer.Endtag s when Some s = tag -> List.rev !elems
+		| Xml_lexer.Eof when tag = None -> List.rev !elems
+		| t ->
+			match tag with
+			| None -> raise (Internal_error EOFExpected)
+			| Some s -> raise (Internal_error (EndOfTagExpected s))
+
+let rec read_xml s =
+  let node = read_node s in
+  match node with
+  | Element _ -> node
+  | PCData c ->
+    if is_blank c then read_xml s
+    else raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+
+let convert = function
+	| Xml_lexer.EUnterminatedComment -> UnterminatedComment
+	| Xml_lexer.EUnterminatedString -> UnterminatedString
+	| Xml_lexer.EIdentExpected -> IdentExpected
+	| Xml_lexer.ECloseExpected -> CloseExpected
+	| Xml_lexer.ENodeExpected -> NodeExpected
+	| Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+	| Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+	| Xml_lexer.EUnterminatedEntity -> 	UnterminatedEntity
+
+let do_parse xparser source =
+	try
+		Xml_lexer.init source;
+		let s = { source = source; xparser = xparser; stack = Stack.create(); } in
+		let x = read_xml s in
+		if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+		Xml_lexer.close source;
+		x
+	with
+		| NoMoreData ->
+			Xml_lexer.close source;
+			raise (!xml_error NodeExpected source)
+		| Internal_error e ->
+			Xml_lexer.close source;
+			raise (!xml_error e source)
+		| Xml_lexer.Error e ->
+			Xml_lexer.close source;
+			raise (!xml_error (convert e) source)
+
+let parse p = function
+	| SChannel ch -> do_parse p (Lexing.from_channel ch)
+	| SString str -> do_parse p (Lexing.from_string str)
+	| SLexbuf lex -> do_parse p lex
+	| SFile fname ->
+		let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
+		try
+			let x = do_parse p (Lexing.from_channel ch) in
+			close_in ch;
+			x
+		with
+			e ->
+				close_in ch;
+				raise e
+
+
+let error_msg = function
+        | UnterminatedComment -> "Unterminated comment"
+        | UnterminatedString -> "Unterminated string"
+        | UnterminatedEntity -> "Unterminated entity"
+        | IdentExpected -> "Ident expected"
+        | CloseExpected -> "Element close expected"
+        | NodeExpected -> "Xml node expected"
+        | AttributeNameExpected -> "Attribute name expected"
+        | AttributeValueExpected -> "Attribute value expected"
+        | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+        | EOFExpected -> "End of file expected"
+
+let error (msg,pos) =
+        if pos.emin = pos.emax then
+                sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
+        else
+                sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+        
+let line e = e.eline
+
+let range e = 
+        e.emin - e.eline_start , e.emax - e.eline_start
+
+let abs_range e =
+        e.emin , e.emax
+
+let pos source =
+        let line, lstart, min, max = Xml_lexer.pos source in
+        {
+                eline = line;
+                eline_start = lstart;
+                emin = min;
+                emax = max;
+        }
+
+let () = _raises (fun x p -> 
+        (* local cast : Xml.error_msg -> error_msg *)
+        Error (x, pos p))
+        (fun f -> File_not_found f)
diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli
new file mode 100644
index 00000000..a3e8aa4a
--- /dev/null
+++ b/lib/xml_parser.mli
@@ -0,0 +1,104 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Xml Light Parser
+
+ While basic parsing functions can be used in the {!Xml} module, this module
+ is providing a way to create, configure and run an Xml parser.
+
+*)
+
+
+(** An Xml node is either
+        [Element (tag-name, attributes, children)] or [PCData text] *)
+type xml = 
+        | Element of (string * (string * string) list * xml list)
+        | PCData of string
+
+(** Abstract type for an Xml parser. *)
+type t
+
+(** {6:exc Xml Exceptions} *)
+
+(** Several exceptions can be raised when parsing an Xml document : {ul
+        {li {!Xml.Error} is raised when an xml parsing error occurs. the
+                {!Xml.error_msg} tells you which error occured during parsing
+                and the {!Xml.error_pos} can be used to retreive the document
+                location where the error occured at.}
+        {li {!Xml.File_not_found} is raised when and error occured while
+                opening a file with the {!Xml.parse_file} function.
+        }
+ *)
+
+type error_pos
+
+type error_msg =
+        | UnterminatedComment
+        | UnterminatedString
+        | UnterminatedEntity
+        | IdentExpected
+        | CloseExpected
+        | NodeExpected
+        | AttributeNameExpected
+        | AttributeValueExpected
+        | EndOfTagExpected of string
+        | EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+(** Get a full error message from an Xml error. *)
+val error : error -> string
+
+(** Get the Xml error message as a string. *)
+val error_msg : error_msg -> string 
+
+(** Get the line the error occured at. *)
+val line : error_pos -> int
+
+(** Get the relative character range (in current line) the error occured at.*)
+val range : error_pos -> int * int
+
+(** Get the absolute character range the error occured at. *)
+val abs_range : error_pos -> int * int
+
+val pos : Lexing.lexbuf -> error_pos
+
+(** Several kind of resources can contain Xml documents. *)
+type source = 
+	| SFile of string
+	| SChannel of in_channel
+	| SString of string
+	| SLexbuf of Lexing.lexbuf
+
+(** This function returns a new parser with default options. *)
+val make : unit -> t
+
+(** When a Xml document is parsed, the parser will check that the end of the
+ document is reached, so for example parsing ["<A/><B/>"] will fail instead
+ of returning only the A element. You can turn off this check by setting
+ [check_eof] to [false] {i (by default, check_eof is true)}. *)
+val check_eof : t -> bool -> unit
+
+(** Once the parser is configurated, you can run the parser on a any kind
+ of xml document source to parse its contents into an Xml data structure. *)
+val parse :  t -> source -> xml
diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml
new file mode 100644
index 00000000..31003586
--- /dev/null
+++ b/lib/xml_utils.ml
@@ -0,0 +1,223 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+open Printf
+open Xml_parser
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+let default_parser = Xml_parser.make()
+
+let parse (p:Xml_parser.t) (source:Xml_parser.source) =
+	(* local cast Xml.xml -> xml *)
+	(Obj.magic Xml_parser.parse p source : xml)
+
+let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
+let parse_string str = parse default_parser (Xml_parser.SString str)
+
+let parse_file f = parse default_parser (Xml_parser.SFile f)
+
+let tag = function
+	| Element (tag,_,_) -> tag
+	| x -> raise (Not_element x)
+
+let pcdata = function 
+	| PCData text -> text
+	| x -> raise (Not_pcdata x)
+
+let attribs = function 
+	| Element (_,attr,_) -> attr
+	| x -> raise (Not_element x)
+
+let attrib x att =
+	match x with
+	| Element (_,attr,_) ->
+		(try
+			let att = String.lowercase att in
+			snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
+		with
+			Not_found ->
+				raise (No_attribute att))
+	| x ->
+		raise (Not_element x)
+
+let children = function
+	| Element (_,_,clist) -> clist
+	| x -> raise (Not_element x)
+
+(*let enum = function
+	| Element (_,_,clist) -> List.to_enum clist
+	| x -> raise (Not_element x)
+*)
+
+let iter f = function
+	| Element (_,_,clist) -> List.iter f clist
+	| x -> raise (Not_element x)
+
+let map f = function
+	| Element (_,_,clist) -> List.map f clist
+	| x -> raise (Not_element x)
+
+let fold f v = function
+	| Element (_,_,clist) -> List.fold_left f v clist
+	| x -> raise (Not_element x)
+
+let tmp = Buffer.create 200
+
+let buffer_pcdata text =
+	let l = String.length text in
+	for p = 0 to l-1 do 
+		match text.[p] with
+		| '>' -> Buffer.add_string tmp "&gt;"
+		| '<' -> Buffer.add_string tmp "&lt;"
+		| '&' ->
+			if p < l-1 && text.[p+1] = '#' then
+				Buffer.add_char tmp '&'
+			else
+				Buffer.add_string tmp "&amp;"
+		| '\'' -> Buffer.add_string tmp "&apos;"
+		| '"' -> Buffer.add_string tmp "&quot;"
+		| c -> Buffer.add_char tmp c
+	done
+
+let print_pcdata chan text =
+  let l = String.length text in
+  for p = 0 to l-1 do 
+    match text.[p] with
+    | '>' -> Printf.fprintf chan "&gt;"
+    | '<' -> Printf.fprintf chan "&lt;"
+    | '&' ->
+            if p < l-1 && text.[p+1] = '#' then
+                    Printf.fprintf chan "&"
+            else
+                    Printf.fprintf chan "&amp;"
+    | '\'' -> Printf.fprintf chan "&apos;"
+    | '"' -> Printf.fprintf chan "&quot;"
+    | c -> Printf.fprintf chan "%c" c
+  done
+
+let buffer_attr (n,v) =
+	Buffer.add_char tmp ' ';
+	Buffer.add_string tmp n;
+	Buffer.add_string tmp "=\"";
+	let l = String.length v in
+	for p = 0 to l-1 do
+		match v.[p] with
+		| '\\' -> Buffer.add_string tmp "\\\\"
+		| '"' -> Buffer.add_string tmp "\\\""
+		| c -> Buffer.add_char tmp c
+	done;
+	Buffer.add_char tmp '"'
+
+let rec print_attr chan (n, v) =
+  Printf.fprintf chan " %s=\"" n;
+  let l = String.length v in
+  for p = 0 to l-1 do
+          match v.[p] with
+          | '\\' -> Printf.fprintf chan "\\\\"
+          | '"' -> Printf.fprintf chan  "\\\""
+          | c -> Printf.fprintf chan "%c" c
+  done;
+  Printf.fprintf chan "\""
+
+let print_attrs chan l = List.iter (print_attr chan) l
+
+let rec print_xml chan = function
+| Element (tag, alist, []) ->
+  Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
+| Element (tag, alist, l) ->
+  Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
+  (fun chan -> List.iter (print_xml chan)) l tag
+| PCData text ->
+  print_pcdata chan text
+
+let to_string x = 
+	let pcdata = ref false in
+	let rec loop = function
+		| Element (tag,alist,[]) ->
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp "/>";
+			pcdata := false;
+		| Element (tag,alist,l) ->
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_char tmp '>';
+			pcdata := false;
+			List.iter loop l;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			pcdata := false;
+		| PCData text ->
+			if !pcdata then Buffer.add_char tmp ' ';
+			buffer_pcdata text;
+			pcdata := true;
+	in
+	Buffer.reset tmp;
+	loop x;
+	let s = Buffer.contents tmp in
+	Buffer.reset tmp;
+	s
+
+let to_string_fmt x =
+	let rec loop ?(newl=false) tab = function
+		| Element (tag,alist,[]) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp "/>";
+			if newl then Buffer.add_char tmp '\n';
+		| Element (tag,alist,[PCData text]) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp ">";
+			buffer_pcdata text;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			if newl then Buffer.add_char tmp '\n';
+		| Element (tag,alist,l) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp ">\n";
+			List.iter (loop ~newl:true (tab^"  ")) l;
+			Buffer.add_string tmp tab;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			if newl then Buffer.add_char tmp '\n';
+		| PCData text ->
+			buffer_pcdata text;
+			if newl then Buffer.add_char tmp '\n';
+	in
+	Buffer.reset tmp;
+	loop "" x;
+	let s = Buffer.contents tmp in
+	Buffer.reset tmp;
+	s
diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli
new file mode 100644
index 00000000..4a4a1309
--- /dev/null
+++ b/lib/xml_utils.mli
@@ -0,0 +1,93 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Xml Light
+ 
+  Xml Light is a minimal Xml parser & printer for OCaml.
+  It provide few functions to parse a basic Xml document into
+  an OCaml data structure and to print back the data structures
+  to an Xml document.
+
+  Xml Light has also support for {b DTD} (Document Type Definition).
+
+  {i (c)Copyright 2002-2003 Nicolas Cannasse}
+*)
+
+open Xml_parser
+
+(** {6 Xml Functions} *)
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+(** [tag xdata] returns the tag value of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val tag : xml -> string
+
+(** [pcdata xdata] returns the PCData value of the xml node.
+ Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
+val pcdata : xml -> string
+
+(** [attribs xdata] returns the attribute list of the xml node.
+ First string if the attribute name, second string is attribute value.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attribs : xml -> (string * string) list 
+
+(** [attrib xdata "href"] returns the value of the ["href"]
+ attribute of the xml node (attribute matching is case-insensitive).
+ Raise {!Xml.No_attribute} if the attribute does not exists in the node's
+ attribute list 
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attrib : xml -> string -> string
+
+(** [children xdata] returns the children list of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val children : xml -> xml list
+
+(*** [enum xdata] returns the children enumeration of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+(* val enum : xml -> xml Enum.t *)
+
+(** [iter f xdata] calls f on all children of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val iter : (xml -> unit) -> xml -> unit
+
+(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val map : (xml -> 'a) -> xml -> 'a list
+
+(** [fold f init xdata] is equivalent to
+ [List.fold_left f init (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
+
+(** {6 Xml Printing} *)
+
+(** Print the xml data structure to a channel into a compact xml string (without
+ any user-readable formating ). *)
+val print_xml : out_channel -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
diff --git a/library/assumptions.ml b/library/assumptions.ml
index 9ce22b09..adc7f8ed 100644
--- a/library/assumptions.ml
+++ b/library/assumptions.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -22,6 +22,8 @@ open Term
 open Declarations
 open Mod_subst
 
+let cst_ord k1 k2 = kn_ord (canonical_con k1) (canonical_con k2)
+
 type context_object =
   | Variable of identifier (* A section variable or a Let definition *)
   | Axiom of constant      (* An axiom or a constant. *)
@@ -34,10 +36,8 @@ struct
   let compare x y =
       match x , y with
       | Variable i1 , Variable i2 -> id_ord i1 i2
-      | Axiom k1 , Axiom k2 -> Pervasives.compare k1 k2
-	          (* spiwack: it would probably be cleaner
-		     to provide a [kn_ord] function *)
-      | Opaque k1 , Opaque k2 -> Pervasives.compare k1 k2
+      | Axiom k1 , Axiom k2 -> cst_ord k1 k2
+      | Opaque k1 , Opaque k2 -> cst_ord k1 k2
       | Variable _ , Axiom _ -> -1
       | Axiom _ , Variable _ -> 1
       | Opaque _ , _ -> -1
@@ -142,7 +142,7 @@ let lookup_constant_in_impl cst fallback =
 let lookup_constant cst =
   try
     let cb = Global.lookup_constant cst in
-    if cb.const_body <> None then cb
+    if constant_has_body cb then cb
     else lookup_constant_in_impl cst (Some cb)
   with Not_found -> lookup_constant_in_impl cst None
 
@@ -211,20 +211,20 @@ let assumptions ?(add_opaque=false) st (* t *) =
     let cb = lookup_constant kn in
     let do_type cst =
       let ctype =
-	match cb.const_type with
+	match cb.Declarations.const_type with
 	| PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level)
 	| NonPolymorphicType t -> t
       in
 	(s,ContextObjectMap.add cst ctype acc)
     in
     let (s,acc) =
-      if add_opaque && cb.const_body <> None
-	&& (cb.const_opaque || not (Cpred.mem kn knst))
+      if add_opaque && Declarations.constant_has_body cb
+	&& (Declarations.is_opaque cb || not (Cpred.mem kn knst))
       then
 	do_type (Opaque kn)
       else (s,acc)
     in
-      match cb.const_body with
+      match Declarations.body_of_constant cb with
       | None -> do_type (Axiom kn)
       | Some body -> do_constr (Declarations.force body) s acc
 
diff --git a/library/assumptions.mli b/library/assumptions.mli
index d0c185d3..1e3e9ef8 100644
--- a/library/assumptions.mli
+++ b/library/assumptions.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
index 20690fa8..ba40f98c 100644
--- a/library/decl_kinds.ml
+++ b/library/decl_kinds.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_kinds.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Libnames
 
@@ -17,8 +15,6 @@ type locality =
   | Local
   | Global
 
-type boxed_flag = bool
-
 type theorem_kind =
   | Theorem
   | Lemma
@@ -54,7 +50,7 @@ type assumption_object_kind = Definitional | Logical | Conjectural
 *)
 type assumption_kind = locality * assumption_object_kind
 
-type definition_kind = locality * boxed_flag * definition_object_kind
+type definition_kind = locality * definition_object_kind
 
 (* Kinds used in proofs *)
 
@@ -86,12 +82,12 @@ let string_of_theorem_kind = function
   | Proposition -> "Proposition"
   | Corollary -> "Corollary"
 
-let string_of_definition_kind (l,boxed,d) =
-  match (l,d) with
+let string_of_definition_kind def =
+  match def with
   | Local, Coercion -> "Coercion Local"
   | Global, Coercion -> "Coercion"
   | Local, Definition -> "Let"
-  | Global, Definition -> if boxed then "Boxed Definition" else "Definition"
+  | Global, Definition -> "Definition"
   | Local, SubClass -> "Local SubClass"
   | Global, SubClass -> "SubClass"
   | Global, CanonicalStructure -> "Canonical Structure"
diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli
index 38e83b1e..88ef763c 100644
--- a/library/decl_kinds.mli
+++ b/library/decl_kinds.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_kinds.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Libnames
 
-(* Informal mathematical status of declarations *)
+(** Informal mathematical status of declarations *)
 
 type locality =
   | Local
   | Global
 
-type boxed_flag = bool
-
 type theorem_kind =
   | Theorem
   | Lemma
@@ -44,7 +40,7 @@ type definition_object_kind =
 
 type assumption_object_kind = Definitional | Logical | Conjectural
 
-(* [assumption_kind]
+(** [assumption_kind]
 
                 |  Local      | Global
    ------------------------------------
@@ -54,9 +50,9 @@ type assumption_object_kind = Definitional | Logical | Conjectural
 *)
 type assumption_kind = locality * assumption_object_kind
 
-type definition_kind = locality * boxed_flag * definition_object_kind
+type definition_kind = locality * definition_object_kind
 
-(* Kinds used in proofs *)
+(** Kinds used in proofs *)
 
 type goal_object_kind =
   | DefinitionBody of definition_object_kind
@@ -64,31 +60,31 @@ type goal_object_kind =
 
 type goal_kind = locality * goal_object_kind
 
-(* Kinds used in library *)
+(** Kinds used in library *)
 
 type logical_kind =
   | IsAssumption of assumption_object_kind
   | IsDefinition of definition_object_kind
   | IsProof of theorem_kind
 
-(* Utils *)
+(** Utils *)
 
 val logical_kind_of_goal_kind : goal_object_kind -> logical_kind
 val string_of_theorem_kind : theorem_kind -> string
 val string_of_definition_kind :
-  locality * boxed_flag * definition_object_kind -> string
+  locality * definition_object_kind -> string
 
-(* About locality *)
+(** About locality *)
 
 val strength_of_global : global_reference -> locality
 val string_of_strength : locality -> string
 
-(* About recursive power of type declarations *)
+(** About recursive power of type declarations *)
 
 type recursivity_kind =
-  | Finite (* = inductive *)
-  | CoFinite (* = coinductive *)
-  | BiFinite (* = non-recursive, like in "Record" definitions *)
+  | Finite (** = inductive *)
+  | CoFinite (** = coinductive *)
+  | BiFinite (** = non-recursive, like in "Record" definitions *)
 
-(* helper, converts to "finiteness flag" booleans *)
+(** helper, converts to "finiteness flag" booleans *)
 val recursivity_flag_of_kind : recursivity_kind -> bool
diff --git a/library/declare.ml b/library/declare.ml
index 14cddd6c..28858085 100644
--- a/library/declare.ml
+++ b/library/declare.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: declare.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** This module is about the low-level declaration of logical objects *)
 
 open Pp
@@ -80,7 +78,10 @@ let discharge_variable (_,o) = match o with
   | Inr (id,_) -> Some (Inl (variable_constraints id))
   | Inl _ -> Some o
 
-let (inVariable,_) =
+type variable_obj =
+    (Univ.constraints, identifier * variable_declaration) union
+
+let inVariable : variable_obj -> obj =
   declare_object { (default_object "VARIABLE") with
     cache_function = cache_variable;
     discharge_function = discharge_variable;
@@ -105,20 +106,26 @@ type constant_declaration = constant_entry * logical_kind
 let load_constant i ((sp,kn),(_,_,kind)) =
   if Nametab.exists_cci sp then
     alreadydeclared (pr_id (basename sp) ++ str " already exists");
-  let con = Global.constant_of_delta (constant_of_kn kn) in
+  let con = Global.constant_of_delta_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),_) =
-  let con = Global.constant_of_delta (constant_of_kn kn) in
+  let con = Global.constant_of_delta_kn kn in
     Nametab.push (Nametab.Exactly i) sp (ConstRef con)
 
+let exists_name id =
+  variable_exists id or Global.exists_label (label_of_id id)
+
+let check_exists sp =
+  let id = basename sp in
+  if exists_name id then alreadydeclared (pr_id id ++ str " already exists")
+
 let cache_constant ((sp,kn),(cdt,dhyps,kind)) =
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
-  if variable_exists id or Nametab.exists_cci sp then
-    alreadydeclared (pr_id id ++ str " already exists");
+  check_exists sp;
   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));
@@ -141,13 +148,16 @@ let discharge_constant ((sp,kn),(cdt,dhyps,kind)) =
   Some (GlobalRecipe recipe,(discharged_hyps kn sechyps)@dhyps,kind)
 
 (* Hack to reduce the size of .vo: we keep only what load/open needs *)
-let dummy_constant_entry = ConstantEntry (ParameterEntry (mkProp,false))
+let dummy_constant_entry = ConstantEntry (ParameterEntry (None,mkProp,None))
 
 let dummy_constant (ce,_,mk) = dummy_constant_entry,[],mk
 
 let classify_constant cst = Substitute (dummy_constant cst)
 
-let (inConstant,_) =
+type constant_obj =
+    global_declaration * Dischargedhypsmap.discharged_hyps * logical_kind
+
+let inConstant : constant_obj -> obj =
   declare_object { (default_object "CONSTANT") with
     cache_function = cache_constant;
     load_function = load_constant;
@@ -156,35 +166,19 @@ let (inConstant,_) =
     subst_function = ident_subst_function;
     discharge_function = discharge_constant }
 
-let hcons_constant_declaration = function
-  | DefinitionEntry ce when !Flags.hash_cons_proofs ->
-      let (hcons1_constr,_) = hcons_constr (hcons_names()) in
-      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_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 c = Global.constant_of_delta (constant_of_kn kn) in
+  let c = Global.constant_of_delta_kn kn in
   declare_constant_implicits c;
   Heads.declare_head (EvalConstRef c);
   Notation.declare_ref_arguments_scope (ConstRef c);
   c
 
-let declare_constant_gen internal id (cd,kind) =
-  let cd = hcons_constant_declaration cd in
+let declare_constant ?(internal = UserVerbose) id (cd,kind) =
   let kn = declare_constant_common id [] (ConstantEntry cd,kind) in
   !xml_declare_constant (internal,kn);
   kn
 
-(* 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 *)
 
 let declare_inductive_argument_scopes kn mie =
@@ -196,7 +190,7 @@ let declare_inductive_argument_scopes kn mie =
 
 let inductive_names sp kn mie =
   let (dp,_) = repr_path sp in
-  let kn = Global.mind_of_delta (mind_of_kn kn) in
+  let kn = Global.mind_of_delta_kn kn in
   let names, _ =
     List.fold_left
       (fun (names, n) ind ->
@@ -215,16 +209,8 @@ let inductive_names sp kn mie =
       ([], 0) mie.mind_entry_inds
   in names
 
-let check_exists_inductive (sp,_) =
-  (if variable_exists (basename sp) then
-    alreadydeclared (pr_id (basename sp) ++ str " already exists"));
-  if Nametab.exists_cci sp then
-    let (_,id) = repr_path sp in
-    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
 
 let open_inductive i ((sp,kn),(_,mie)) =
@@ -233,7 +219,7 @@ let open_inductive i ((sp,kn),(_,mie)) =
 
 let cache_inductive ((sp,kn),(dhyps,mie)) =
   let names = inductive_names sp kn mie in
-  List.iter check_exists_inductive names;
+  List.iter check_exists (List.map fst names);
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
   let kn' = Global.add_mind dir id mie in
@@ -245,7 +231,7 @@ let cache_inductive ((sp,kn),(dhyps,mie)) =
 
 
 let discharge_inductive ((sp,kn),(dhyps,mie)) =
-  let mind = (Global.mind_of_delta (mind_of_kn kn)) in
+  let mind = Global.mind_of_delta_kn kn in
   let mie = Global.lookup_mind mind in
   let repl = replacement_context () in
   let sechyps = section_segment_of_mutual_inductive mind in
@@ -266,7 +252,9 @@ let dummy_inductive_entry (_,m) = ([],{
   mind_entry_finite = true;
   mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds })
 
-let (inInductive,_) =
+type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry
+
+let inInductive : inductive_obj -> obj =
   declare_object {(default_object "INDUCTIVE") with
     cache_function = cache_inductive;
     load_function = load_inductive;
@@ -281,7 +269,7 @@ 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
-  let mind = (Global.mind_of_delta (mind_of_kn kn)) in
+  let mind = Global.mind_of_delta_kn kn in
   declare_mib_implicits mind;
   declare_inductive_argument_scopes mind mie;
   !xml_declare_inductive (isrecord,oname);
diff --git a/library/declare.mli b/library/declare.mli
index 1ada7cc9..61c19996 100644
--- a/library/declare.mli
+++ b/library/declare.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declare.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Libnames
 open Term
@@ -19,9 +16,8 @@ open Indtypes
 open Safe_typing
 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
@@ -30,54 +26,57 @@ open Decl_kinds
 
 open Nametab
 
-(* Declaration of local constructions (Variable/Hypothesis/Local) *)
+(** Declaration of local constructions (Variable/Hypothesis/Local) *)
 
 type section_variable_entry =
-  | SectionLocalDef of constr * types option * bool (* opacity *)
-  | SectionLocalAssum of types * bool (* Implicit status *)
+  | SectionLocalDef of constr * types option * bool (** opacity *)
+  | SectionLocalAssum of types * bool (** Implicit status *)
 
 type variable_declaration = dir_path * section_variable_entry * logical_kind
 
 val declare_variable : variable -> variable_declaration -> object_name
 
-(* Declaration of global constructions *)
-(* i.e. Definition/Theorem/Axiom/Parameter/... *)
+(** Declaration of global constructions 
+   i.e. Definition/Theorem/Axiom/Parameter/... *)
 
 type constant_declaration = constant_entry * logical_kind
 
-(* [declare_constant id cd] declares a global declaration
+(** [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 *)
+   the full path of the declaration 
+
+  internal specify if the constant has been created by the kernel or by the
+  user, and in the former case, if its errors should be silent
+   
+   *)
 type internal_flag =
   | KernelVerbose
   | KernelSilent
   | UserVerbose
 
 val declare_constant :
- identifier -> constant_declaration -> constant
-
-val declare_internal_constant :
-  identifier -> constant_declaration -> constant
+ ?internal:internal_flag -> identifier -> constant_declaration -> constant
 
-(* [declare_mind me] declares a block of inductive types with
+(** [declare_mind me] declares a block of inductive types with
    their constructors in the current section; it returns the path of
    the whole block (boolean must be true iff it is a record) *)
 val declare_mind : internal_flag -> mutual_inductive_entry -> object_name
 
-(* Hooks for XML output *)
+(** Hooks for XML output *)
 val set_xml_declare_variable : (object_name -> unit) -> unit
 val set_xml_declare_constant : (internal_flag * constant -> unit) -> unit
 val set_xml_declare_inductive : (internal_flag * object_name -> unit) -> unit
 
-(* Hook for the cache function of constants and inductives *)
+(** Hook for the cache function of constants and inductives *)
 val add_cache_hook : (full_path -> unit) -> unit
 
-(* Declaration messages *)
+(** 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 *) ->
+val recursive_message : bool (** true = fixpoint *) ->
   int array option -> identifier list -> unit
 
+val exists_name : identifier -> bool
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 7d996a66..90d4245a 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 open Names
@@ -19,8 +17,55 @@ open Lib
 open Nametab
 open Mod_subst
 
-(* modules and components *)
+(** Rigid / flexible signature *)
+
+type 'a module_signature =
+  | Enforce of 'a (** ... : T *)
+  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
+
+(** Should we adapt a few scopes during functor application ? *)
+
+type scope_subst = (string * string) list
+
+let scope_subst = ref (Stringmap.empty : string Stringmap.t)
+
+let add_scope_subst sc sc' =
+  scope_subst := Stringmap.add sc sc' !scope_subst
+
+let register_scope_subst scl =
+  List.iter (fun (sc1,sc2) -> add_scope_subst sc1 sc2) scl
+
+let subst_scope sc =
+ try Stringmap.find sc !scope_subst with Not_found -> sc
+
+let reset_scope_subst () =
+  scope_subst := Stringmap.empty
+
+(** Which inline annotations should we honor, either None or the ones
+    whose level is less or equal to the given integer *)
+
+type inline =
+  | NoInline
+  | DefaultInline
+  | InlineAt of int
+
+let default_inline () = Some (Flags.get_inline_level ())
+
+let inl2intopt = function
+  | NoInline -> None
+  | InlineAt i -> Some i
+  | DefaultInline -> default_inline ()
+
+type funct_app_annot =
+  { ann_inline : inline;
+    ann_scope_subst : scope_subst }
 
+let inline_annot a = inl2intopt a.ann_inline
+
+type 'a annotated = ('a * funct_app_annot)
+
+
+(* modules and components *)
 
 (* OBSOLETE This type is a functional closure of substitutive lib_objects.
 
@@ -80,7 +125,8 @@ let modtab_objects =
 let openmod_info =
   ref ((MPfile(initial_dir),[],None,[])
 	 : module_path *  mod_bound_id list *
-           (module_struct_entry * bool) option * module_type_body list)
+           (module_struct_entry * int option) option *
+	   module_type_body list)
 
 (* The library_cache here is needed to avoid recalculations of
    substituted modules object during "reloading" of libraries *)
@@ -133,15 +179,21 @@ let check_sub mtb sub_mtb_l =
    environment. *)
 
 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
+  let mb =
+    try Global.lookup_module mp
+    with Not_found -> assert false
+  in
+  let mtb = Modops.module_type_of_module None mb in
   check_sub mtb sub_mtb_l
 
 (* Same for module type [mp] *)
 
 let check_subtypes_mt mp sub_mtb_l =
-  check_sub (Environ.lookup_modtype mp (Global.env())) sub_mtb_l
+  let mtb =
+    try Global.lookup_modtype mp
+    with Not_found -> assert false
+  in
+  check_sub mtb sub_mtb_l
 
 (* Create a functor type entry *)
 
@@ -154,7 +206,8 @@ let funct_entry args m =
 
 let build_subtypes interp_modtype mp args mtys =
   List.map
-    (fun (m,inl) ->
+    (fun (m,ann) ->
+       let inl = inline_annot ann in
        let mte = interp_modtype (Global.env()) m in
        let mtb = Mod_typing.translate_module_type (Global.env()) mp inl mte in
        let funct_mtb =
@@ -228,43 +281,27 @@ let conv_names_do_module exists what iter_objects i
    functions can be called only once (and "end_mod*" set the flag to
    false then)
 *)
-let cache_module ((sp,kn),(entry,substobjs)) =
+let cache_module ((sp,kn),substobjs) =
   let dir,mp = dir_of_sp sp, mp_of_kn kn in
     do_module false "cache" load_objects 1 dir mp substobjs []
-    
-(* TODO: This check is not essential *)
-let check_empty s = function
-     | None -> ()
-     | 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)) =
-  (* TODO: This check is not essential *)
-  check_empty "load_module" entry;
+let load_module i (oname,substobjs) =
   conv_names_do_module false "load" load_objects i oname substobjs
 
-
-let open_module i (oname,(entry,substobjs)) =
-  (* TODO: This check is not essential *)
-  check_empty "open_module" entry;
+let open_module i (oname,substobjs) =
   conv_names_do_module true "open" open_objects i oname substobjs
 
+let subst_module (subst,(mbids,mp,objs)) =
+  (mbids,subst_mp subst mp, subst_objects subst objs)
 
+let classify_module substobjs = Substitute substobjs
 
-let subst_module (subst,(entry,(mbids,mp,objs))) =
-  check_empty "subst_module" entry;
-    (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
+let (in_module : substitutive_objects -> obj),
+    (out_module : obj -> substitutive_objects) =
+  declare_object_full {(default_object "MODULE") with
     cache_function = cache_module;
     load_function = load_module;
     open_function = open_module;
@@ -291,7 +328,7 @@ 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,_) =
+let in_modkeep : lib_objects -> obj =
   declare_object {(default_object "MODULE KEEP OBJECTS") with
     cache_function = cache_keep;
     load_function = load_keep;
@@ -323,6 +360,7 @@ let _ = Summary.declare_summary "MODTYPE-INFO"
 let cache_modtype ((sp,kn),(entry,modtypeobjs,sub_mty_l)) =
   let mp = mp_of_kn kn in
 
+  (* We enrich the global environment *)
   let _ =
     match entry with
       | None ->
@@ -346,7 +384,7 @@ let cache_modtype ((sp,kn),(entry,modtypeobjs,sub_mty_l)) =
 
 
 let load_modtype i ((sp,kn),(entry,modtypeobjs,_)) =
-  check_empty "load_modtype" entry;
+  assert (entry = None);
 
   if Nametab.exists_modtype sp then
     errorlabstrm "cache_modtype"
@@ -358,7 +396,7 @@ let load_modtype i ((sp,kn),(entry,modtypeobjs,_)) =
 
 
 let open_modtype i ((sp,kn),(entry,_,_)) =
-  check_empty "open_modtype" entry;
+  assert (entry = None);
 
   if
     try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn)
@@ -370,15 +408,18 @@ let open_modtype i ((sp,kn),(entry,_,_)) =
   Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn)
 
 let subst_modtype (subst,(entry,(mbids,mp,objs),_)) =
-  check_empty "subst_modtype" entry;
+  assert (entry = None);
   (entry,(mbids,subst_mp subst mp,subst_objects subst objs),[])
 
-
 let classify_modtype (_,substobjs,_) =
   Substitute (None,substobjs,[])
 
+type modtype_obj =
+    (module_struct_entry * Entries.inline) option (* will be None in vo *)
+    * substitutive_objects
+    * module_type_body list
 
-let (in_modtype,_) =
+let in_modtype : modtype_obj -> obj =
     declare_object {(default_object "MODULE TYPE") with
       cache_function = cache_modtype;
       open_function = open_modtype;
@@ -386,36 +427,27 @@ let (in_modtype,_) =
       subst_function = subst_modtype;
       classify_function = classify_modtype }
 
+let rec replace_module_object idl (mbids,mp,lib_stack) (mbids2,mp2,objs) mp1 =
+  if mbids<>[] then anomaly "Unexpected functor objects";
+  let rec replace_idl = function
+    | _,[] -> []
+    | id::idl,(id',obj)::tail when id = id' ->
+      if object_tag obj <> "MODULE" then anomaly "MODULE expected!";
+      let substobjs =
+	if idl = [] then
+	  let mp' = MPdot(mp, label_of_id id) in
+	  mbids, mp', subst_objects (map_mp mp1 mp' empty_delta_resolver) objs
+	else
+	  replace_module_object idl (out_module obj) (mbids2,mp2,objs) mp
+      in
+      (id, in_module substobjs)::tail
+    | idl,lobj::tail -> lobj::replace_idl (idl,tail)
+  in
+  (mbids, mp, replace_idl (idl,lib_stack))
 
-let 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' ->
-	  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
+let discr_resolver mb = match mb.mod_type with
+  | SEBstruct _ -> Some mb.mod_delta
+  | _ -> None (* when mp is a functor *)
 
 (* Small function to avoid module typing during substobjs retrivial  *)
 let rec get_objs_modtype_application env = function
@@ -428,24 +460,20 @@ let rec get_objs_modtype_application env = function
     Modops.error_application_to_not_path mexpr
 | _ -> error "Application of a non-functor."
 
-let rec compute_subst env mbids sign mp_l inline =
+let rec compute_subst env mbids sign mp_l inl =
   match mbids,mp_l with
     | _,[] -> mbids,empty_subst
     | [],r -> error "Application of a functor with too few arguments."
     | mbid::mbids,mp::mp_l ->
 	let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in
 	let 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
+	let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in
+	let resolver = match discr_resolver mb with
+	  | None -> empty_delta_resolver
 	  | Some mp_delta ->
-	      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
+	      Modops.inline_delta_resolver env inl mp farg_id farg_b mp_delta
+	in
+	mbid_left,join (map_mbid mbid mp resolver) subst
 
 let rec get_modtype_substobjs env mp_from inline = function
     MSEident ln -> 
@@ -472,20 +500,39 @@ let rec get_modtype_substobjs env mp_from inline = function
 (* 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,inl)) =
+  let process_arg id (mbid,(mty,ann)) =
     let dir = make_dirpath [id] in
     let mp = MPbound mbid in
     let (mbids,mp_from,objs) =
-      get_modtype_substobjs (Global.env()) mp inl mty in
+      get_modtype_substobjs (Global.env()) mp (inline_annot ann) mty in
     let substobjs = (mbids,mp,subst_objects
 		       (map_mp mp_from mp empty_delta_resolver) objs)in
       do_module false "start" load_objects 1 dir mp substobjs []
     in
       List.iter2 process_arg argids args
 
-let intern_args interp_modtype (idl,(arg,inl)) =
+(* Same with module_type_body *)
+
+let rec seb2mse = function
+  | SEBident mp -> MSEident mp
+  | SEBapply (s,s',_) -> MSEapply(seb2mse s, seb2mse s')
+  | SEBwith (s,With_module_body (l,mp)) -> MSEwith(seb2mse s,With_Module(l,mp))
+  | SEBwith (s,With_definition_body(l,cb)) ->
+      (match cb.const_body with
+	| Def c -> MSEwith(seb2mse s,With_Definition(l,Declarations.force c))
+	| _ -> assert false)
+  | _ -> failwith "seb2mse: received a non-atomic seb"
+
+let process_module_seb_binding mbid seb =
+  process_module_bindings [id_of_mbid mbid]
+    [mbid,
+     (seb2mse seb,
+      { ann_inline = DefaultInline; ann_scope_subst = [] })]
+
+let intern_args interp_modtype (idl,(arg,ann)) =
+  let inl = inline_annot ann in
   let lib_dir = Lib.library_dp() in
-  let mbids = List.map (fun (_,id) -> make_mbid lib_dir (string_of_id id)) idl in
+  let mbids = List.map (fun (_,id) -> make_mbid lib_dir id) idl in
   let mty = interp_modtype (Global.env()) arg in
   let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in
   let (mbi,mp_from,objs) = get_modtype_substobjs (Global.env())
@@ -504,11 +551,12 @@ let start_module_ interp_modtype export id args res fs =
   let mp = Global.start_module id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
   let res_entry_o, sub_body_l = match res with
-    | Topconstr.Enforce (res,inl) ->
+    | Enforce (res,ann) ->
+        let inl = inline_annot ann in
 	let mte = interp_modtype (Global.env()) res in
 	let _ = Mod_typing.translate_struct_type_entry (Global.env()) inl mte in
 	Some (mte,inl), []
-    | Topconstr.Check resl ->
+    | Check resl ->
 	None, build_subtypes interp_modtype mp arg_entries resl
   in
   let mbids = List.map fst arg_entries in
@@ -561,7 +609,7 @@ let end_module () =
     | 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 node = in_module substobjs in
   let objects =
     if keep = [] || mbids <> [] then
       special@[node]   (* no keep objects or we are defining a functor *)
@@ -652,7 +700,7 @@ let subst_import (subst,(export,mp as obj)) =
     if mp'==mp then obj else
       (export,mp')
 
-let (in_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);
@@ -698,7 +746,8 @@ let end_modtype () =
   mp
 
 
-let declare_modtype_ interp_modtype id args mtys (mty,inl) fs =
+let declare_modtype_ interp_modtype id args mtys (mty,ann) fs =
+  let inl = inline_annot ann in
   let mmp = Global.start_modtype id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
   let entry = funct_entry arg_entries (interp_modtype (Global.env()) mty) in
@@ -708,9 +757,11 @@ let declare_modtype_ interp_modtype id args mtys (mty,inl) fs =
   (* Undo the simulated interactive building of the module type *)
   (* and declare the module type as a whole *)
 
+  register_scope_subst ann.ann_scope_subst;
   let substobjs = (mbids,mmp,
 		   subst_objects (map_mp mp_from mmp empty_delta_resolver) objs)
   in
+  reset_scope_subst ();
   Summary.unfreeze_summaries fs;
   ignore (add_leaf id (in_modtype (Some (entry,inl), substobjs, sub_mty_l)));
   mmp
@@ -744,6 +795,60 @@ let rec get_module_substobjs env mp_from inl = function
   | MSEwith (mty, With_Definition _) -> get_module_substobjs env mp_from inl mty
   | MSEwith (mty, With_Module (idl,mp)) -> assert false
 
+
+let declare_module_ interp_modtype interp_modexpr id args res mexpr_o fs =
+  let mmp = Global.start_module id in
+  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
+
+  let funct f m = funct_entry arg_entries (f (Global.env ()) m) in
+  let env = Global.env() in
+  let mty_entry_o, subs, inl_res = match res with
+    | Enforce (mty,ann) ->
+        Some (funct interp_modtype mty), [], inline_annot ann
+    | Check mtys ->
+	None, build_subtypes interp_modtype mmp arg_entries mtys,
+        default_inline ()
+  in
+ 
+  (*let subs = List.map (Mod_typing.translate_module_type env mmp) mty_sub_l in  *)
+  let mexpr_entry_o, inl_expr, scl = match mexpr_o with
+    | None -> None, default_inline (), []
+    | Some (mexpr,ann) ->
+      Some (funct interp_modexpr mexpr), inline_annot ann, ann.ann_scope_subst
+
+  in
+  let entry =
+    {mod_entry_type = mty_entry_o;
+     mod_entry_expr = mexpr_entry_o }
+  in
+
+  let substobjs =
+    match entry with
+      | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp inl_res mte
+      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp inl_expr mexpr
+      | _ -> anomaly "declare_module: No type, no body ..."
+  in
+  let (mbids,mp_from,objs) = substobjs in
+  (* Undo the simulated interactive building of the module *)
+  (* and declare the module as a whole *)
+  Summary.unfreeze_summaries fs;
+  let mp = mp_of_kn (Lib.make_kn id) in
+  let inl = if inl_expr = None then None else inl_res in (*PLTODO *)
+  let mp_env,resolver = Global.add_module id entry inl in
+
+  if mp_env <> mp then anomaly "Kernel and Library names do not match";
+
+  
+  check_subtypes mp subs;
+  register_scope_subst scl;
+  let substobjs = (mbids,mp_env,
+		   subst_objects(map_mp mp_from mp_env resolver) objs) in
+  reset_scope_subst ();
+  ignore (add_leaf
+	    id
+	    (in_module substobjs));
+  mmp
+
 (* Include *)
 
 let rec subst_inc_expr subst me =
@@ -769,95 +874,48 @@ let lift_oname (sp,kn) =
   let dir,_ = Libnames.repr_path sp in
     (dir,mp)
 
-let cache_include (oname,((me,is_mod),(mbis,mp1,objs))) =
+let cache_include (oname,(me,(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
     load_objects 1 prefix objs;
-    open_objects 1 prefix objs 
-    
-let load_include  i (oname,((me,is_mod),(mbis,mp1,objs))) =
+    open_objects 1 prefix objs
+
+let load_include  i (oname,(me,(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
     load_objects i prefix objs
-      
-      
-let open_include i (oname,((me,is_mod),(mbis,mp1,objs))) =
+
+let open_include i (oname,(me,(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
     open_objects i prefix objs
-      
-let subst_include (subst,((me,is_mod),substobj)) =
+
+let subst_include (subst,(me,substobj)) =
   let (mbids,mp,objs) = substobj in
   let substobjs = (mbids,subst_mp subst mp,subst_objects subst objs) in
-    ((subst_inc_expr subst me,is_mod),substobjs)
-      
-let classify_include ((me,is_mod),substobjs) =
-  Substitute ((me,is_mod),substobjs)
+    (subst_inc_expr subst me,substobjs)
+
+let classify_include (me,substobjs) = Substitute (me,substobjs)
 
-let (in_include,out_include) =
-  declare_object {(default_object "INCLUDE") with
+type include_obj = module_struct_entry * substitutive_objects
+
+let (in_include : include_obj -> obj),
+    (out_include : obj -> include_obj) =
+  declare_object_full {(default_object "INCLUDE") with
     cache_function = cache_include;
     load_function = load_include;
     open_function = open_include;
     subst_function = subst_include;
     classify_function = classify_include }
 
-
-let declare_module_ interp_modtype interp_modexpr id args res mexpr_o fs =
-  let mmp = Global.start_module id in
-  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-
-  let funct f m = funct_entry arg_entries (f (Global.env ()) m) in
-  let env = Global.env() in
-  let mty_entry_o, subs, inl_res = match res with
-    | 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 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;
-     mod_entry_expr = mexpr_entry_o }
-  in
-
-  let(mbids,mp_from,objs) =
-    match entry with
-      | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp inl_res mte
-      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp inl_expr mexpr
-      | _ -> anomaly "declare_module: No type, no body ..."
-  in
-  (* 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
+	let mp_delta =
+	  Modops.inline_delta_resolver env inline mb.mod_mp
 	    farg_id farg_b mb.mod_delta
 	in
 	join (map_mbid mbid mb.mod_mp mp_delta) subst
@@ -894,9 +952,13 @@ let get_includeself_substobjs env objs me is_mod inline =
     ([],mp_self,subst_objects subst objects)
   with NothingToDo -> objs
 
-let declare_one_include_inner inl (me,is_mod) =
+
+
+
+let declare_one_include_inner annot (me,is_mod) =
   let env = Global.env() in
   let mp1,_ = current_prefix () in
+  let inl = inline_annot annot in
   let (mbids,mp,objs)=
     if is_mod then
       get_module_substobjs env mp1 inl me
@@ -909,14 +971,15 @@ let declare_one_include_inner inl (me,is_mod) =
       (mbids,mp,objs) in
   let id = current_mod_id() in
   let resolver =  Global.add_include me is_mod inl in
+  register_scope_subst annot.ann_scope_subst;
   let substobjs = (mbids,mp1,
 		   subst_objects (map_mp mp mp1 resolver) objs) in
-  ignore (add_leaf id
-	    (in_include ((me,is_mod), substobjs)))
+  reset_scope_subst ();
+  ignore (add_leaf id (in_include (me, 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_one_include interp_struct (me_ast,annot) =
+  declare_one_include_inner annot
+    (interp_struct (Global.env()) me_ast)
 
 let declare_include_ interp_struct me_asts =
   List.iter (declare_one_include interp_struct) me_asts
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 46b7f411..9d44ba97 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Entries
@@ -16,15 +13,41 @@ open Environ
 open Libnames
 open Libobject
 open Lib
-   (*i*)
 
-(*s This modules provides official functions to declare modules and
+(** This modules provides official functions to declare modules and
   module types *)
 
+(** Rigid / flexible signature *)
+
+type 'a module_signature =
+  | Enforce of 'a (** ... : T *)
+  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
+
+(** Should we adapt a few scopes during functor application ? *)
+
+type scope_subst = (string * string) list
+
+val subst_scope : string -> string
+
+(** Which inline annotations should we honor, either None or the ones
+   whose level is less or equal to the given integer *)
 
-(*s Modules *)
+type inline =
+  | NoInline
+  | DefaultInline
+  | InlineAt of int
 
-(* [declare_module interp_modtype interp_modexpr id fargs typ expr]
+(** The type of annotations for functor applications *)
+
+type funct_app_annot =
+  { ann_inline : inline;
+    ann_scope_subst : scope_subst }
+
+type 'a annotated = ('a * funct_app_annot)
+
+(** {6 Modules } *)
+
+(** [declare_module interp_modtype interp_modexpr id fargs typ expr]
    declares module [id], with type constructed by [interp_modtype]
    from functor arguments [fargs] and [typ] and with module body
    constructed by [interp_modtype] from functor arguments [fargs] and
@@ -41,39 +64,44 @@ val declare_module :
   (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
+  (identifier located list * ('modast annotated)) list ->
+  ('modast annotated) module_signature ->
+  ('modast annotated) list -> module_path
 
 val start_module : (env -> 'modast -> module_struct_entry) ->
-  bool option -> identifier -> (identifier located list * ('modast * bool)) list ->
-  ('modast * bool) Topconstr.module_signature -> module_path
+  bool option -> identifier ->
+  (identifier located list * ('modast annotated)) list ->
+  ('modast annotated) module_signature -> module_path
 
 val end_module : unit -> module_path
 
 
 
-(*s Module types *)
+(** {6 Module types } *)
 
 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
+  identifier ->
+  (identifier located list * ('modast annotated)) list ->
+  ('modast annotated) list ->
+  ('modast annotated) list ->
+  module_path
 
 val start_modtype : (env -> 'modast -> module_struct_entry) ->
-  identifier -> (identifier located list * ('modast * bool)) list ->
-  ('modast * bool) list -> module_path
+  identifier -> (identifier located list * ('modast annotated)) list ->
+  ('modast annotated) list -> module_path
 
 val end_modtype : unit -> module_path
 
 
-(*s Objects of a module. They come in two lists: the substitutive ones
+(** {6 ... } *)
+(** Objects of a module. They come in two lists: the substitutive ones
   and the other *)
 
 val module_objects : module_path -> library_segment
 
 
-(*s Libraries i.e. modules on disk *)
+(** {6 Libraries i.e. modules on disk } *)
 
 type library_name = dir_path
 
@@ -88,27 +116,28 @@ 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 *)
+(** 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).
+(** [really_import_module mp] opens the module [mp] (in a Caml sense).
    It modifies Nametab and performs the [open_object] function for
    every object of the module. *)
 
 val really_import_module : module_path -> unit
 
-(* [import_module export mp] is a synchronous version of
+(** [import_module export mp] is a synchronous version of
    [really_import_module]. If [export] is [true], the module is also
    opened every time the module containing it is. *)
 
 val import_module : bool -> module_path -> unit
 
-(* Include  *)
+(** Include  *)
 
 val declare_include : (env -> 'struct_expr -> module_struct_entry * bool) ->
-  ('struct_expr * bool) list -> unit
+  ('struct_expr annotated) list -> unit
 
-(*s [iter_all_segments] iterate over all segments, the modules'
+(** {6 ... } *)
+(** [iter_all_segments] iterate over all segments, the modules'
     segments first and then the current segment. Modules are presented
     in an arbitrary order. The given function is applied to all leaves
     (together with their section path). *)
@@ -120,7 +149,10 @@ val debug_print_modtab : unit -> Pp.std_ppcmds
 
 (*i val debug_print_modtypetab : unit -> Pp.std_ppcmds i*)
 
-(* For translator *)
+(** For translator *)
 val process_module_bindings : module_ident list ->
-  (mod_bound_id * (module_struct_entry * bool)) list -> unit
+  (mod_bound_id * (module_struct_entry annotated)) list -> unit
 
+(** For Printer *)
+val process_module_seb_binding :
+  mod_bound_id -> Declarations.struct_expr_body -> unit
diff --git a/library/decls.ml b/library/decls.ml
index 425fe798..74a5f7ef 100644
--- a/library/decls.ml
+++ b/library/decls.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decls.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** This module registers tables for some non-logical informations
      associated declarations *)
 
@@ -57,7 +55,8 @@ let constant_kind kn = Cmap.find kn !csttab
 
 (** Miscellaneous functions. *)
 
-let clear_proofs sign =
+let initialize_named_context_for_proof () =
+  let sign = Global.named_context () in
   List.fold_right
     (fun (id,c,t as d) signv ->
       let d = if variable_opacity id then (id,None,t) else d in
diff --git a/library/decls.mli b/library/decls.mli
index 7a8e138b..73f1745b 100644
--- a/library/decls.mli
+++ b/library/decls.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decls.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Sign
 open Libnames
@@ -20,7 +18,7 @@ open Decl_kinds
 (** Registration and access to the table of variable *)
 
 type variable_data =
-    dir_path * bool (* opacity *) * Univ.constraints * logical_kind
+    dir_path * bool (** opacity *) * Univ.constraints * logical_kind
 
 val add_variable_data : variable -> variable_data -> unit
 val variable_path : variable -> dir_path
@@ -35,7 +33,11 @@ val variable_exists : variable -> bool
 val add_constant_kind : constant -> logical_kind -> unit
 val constant_kind : constant -> logical_kind
 
+(* Prepare global named context for proof session: remove proofs of
+   opaque section definitions and remove vm-compiled code *)
+
+val initialize_named_context_for_proof : unit -> Environ.named_context_val
+
 (** Miscellaneous functions *)
 
 val last_section_hyps : dir_path -> identifier list
-val clear_proofs : named_context -> Environ.named_context_val
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
index 2a4d5494..ec92f679 100644
--- a/library/dischargedhypsmap.ml
+++ b/library/dischargedhypsmap.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dischargedhypsmap.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Libnames
 open Names
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
index 59dcdf24..fda071a7 100644
--- a/library/dischargedhypsmap.mli
+++ b/library/dischargedhypsmap.mli
@@ -1,24 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dischargedhypsmap.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Libnames
 open Term
 open Environ
 open Nametab
-(*i*)
 
 type discharged_hyps = full_path list
 
-(*s Discharged hypothesis. Here we store the discharged hypothesis of each *)
-(*  constant or inductive type declaration.                                *)
+(** Discharged hypothesis. Here we store the discharged hypothesis of each 
+    constant or inductive type declaration.                                *)
 
 val set_discharged_hyps : full_path -> discharged_hyps -> unit
 val get_discharged_hyps : full_path -> discharged_hyps
diff --git a/library/global.ml b/library/global.ml
index 72429c76..ab70bb7c 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: global.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
@@ -121,16 +119,22 @@ 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 constant_of_delta con = 
+let constant_of_delta_kn kn =
   let resolver,resolver_param = (delta_of_senv !global_env) in
+  (* TODO : are resolver and resolver_param orthogonal ?
+     the effect of resolver is lost if resolver_param isn't
+     trivial at that spot. *)
     Mod_subst.constant_of_delta resolver_param
-      (Mod_subst.constant_of_delta resolver con)
+      (Mod_subst.constant_of_delta_kn resolver kn)
 
-let mind_of_delta mind = 
+let mind_of_delta_kn kn =
   let resolver,resolver_param = (delta_of_senv !global_env) in
+  (* TODO idem *)
     Mod_subst.mind_of_delta resolver_param
-      (Mod_subst.mind_of_delta resolver mind)
-	
+      (Mod_subst.mind_of_delta_kn resolver kn)
+
+let exists_label id = exists_label id !global_env
+
 let start_library dir =
   let mp,newenv = start_library dir !global_env in
     global_env := newenv;
diff --git a/library/global.mli b/library/global.mli
index cdcf5801..1a0fabdc 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: global.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Univ
 open Term
@@ -17,9 +14,8 @@ open Entries
 open Indtypes
 open Mod_subst
 open Safe_typing
-   (*i*)
 
-(* This module defines the global environment of Coq.  The functions
+(** This module defines the global environment of Coq.  The functions
    below are exactly the same as the ones in [Safe_typing], operating on
    that global environment. [add_*] functions perform name verification,
    i.e. check that the name given as argument match those provided by
@@ -38,11 +34,12 @@ val named_context : unit -> Sign.named_context
 
 val env_is_empty : unit -> bool
 
-(*s Extending env with variables and local definitions *)
+(** {6 Extending env with variables and local definitions } *)
 val push_named_assum : (identifier * types) -> Univ.constraints
 val push_named_def   : (identifier * constr * types option) -> Univ.constraints
 
-(*s Adding constants, inductives, modules and module types.  All these
+(** {6 ... } *)
+(** Adding constants, inductives, modules and module types.  All these
   functions verify that given names match those generated by kernel *)
 
 val add_constant :
@@ -51,57 +48,59 @@ val add_mind        :
   dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive
 
 val add_module      :
- identifier -> module_entry -> bool -> module_path * delta_resolver
+ identifier -> module_entry -> inline -> module_path * delta_resolver
 val add_modtype     :
- identifier -> module_struct_entry -> bool -> module_path
+ identifier -> module_struct_entry -> inline -> module_path
 val add_include :
- module_struct_entry -> bool -> bool -> delta_resolver
+ module_struct_entry -> bool -> inline -> 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
+(** {6 Interactive modules and module types }
+   Both [start_*] functions take the [dir_path] argument to create a
    [mod_self_id]. This should be the name of the compilation unit. *)
 
-(* [start_*] functions return the [module_path] valid for components
+(** [start_*] functions return the [module_path] valid for components
    of the started module / module type *)
 
 val start_module : identifier -> module_path
 
 val end_module : Summary.frozen ->identifier ->
-  (module_struct_entry * bool) option -> module_path * delta_resolver
+  (module_struct_entry * inline) option -> module_path * delta_resolver
 
 val add_module_parameter :
- mod_bound_id -> module_struct_entry -> bool -> delta_resolver
+ mod_bound_id -> module_struct_entry -> inline -> delta_resolver
 
 val start_modtype : identifier -> module_path
 val end_modtype : Summary.frozen -> identifier -> module_path
 val pack_module : unit -> module_body
 
 
-(* Queries *)
+(** Queries *)
 val lookup_named     : variable -> named_declaration
 val lookup_constant  : constant -> constant_body
 val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body
 val lookup_mind      : mutual_inductive -> mutual_inductive_body
 val lookup_module    : module_path -> module_body
 val lookup_modtype   : module_path -> module_type_body
-val constant_of_delta : constant -> constant
-val mind_of_delta : mutual_inductive -> mutual_inductive
+val constant_of_delta_kn : kernel_name -> constant
+val mind_of_delta_kn : kernel_name -> mutual_inductive
+val exists_label     : label -> bool
 
-(* Compiled modules *)
+(** Compiled modules *)
 val start_library : dir_path -> module_path
 val export : dir_path -> module_path * compiled_library
 val import : compiled_library -> Digest.t -> module_path
 
-(*s Function to get an environment from the constants part of the global
+(** {6 ... } *)
+(** Function to get an environment from the constants part of the global
  * environment and a given context. *)
 
 val type_of_global : Libnames.global_reference -> types
 val env_of_context : Environ.named_context_val -> Environ.env
 
 
-(* spiwack: register/unregister function for retroknowledge *)
+(** spiwack: register/unregister function for retroknowledge *)
 val register : Retroknowledge.field -> constr -> constr -> unit
diff --git a/library/goptions.ml b/library/goptions.ml
index 178c436d..90c8728c 100644
--- a/library/goptions.ml
+++ b/library/goptions.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: goptions.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* This module manages customization parameters at the vernacular level     *)
 
 open Pp
@@ -19,22 +17,18 @@ open Term
 open Nametab
 open Mod_subst
 
+open Goptionstyp
+
+type option_name = Goptionstyp.option_name
+
 (****************************************************************************)
 (* 0- Common things                                                         *)
 
-type option_name = string list
-
 let nickname table = String.concat " " table
 
 let error_undeclared_key key =
   error ((nickname key)^": no table or option of this type")
 
-type value =
-  | BoolValue   of bool
-  | IntValue    of int option
-  | StringValue of string
-  | IdentValue  of global_reference
-
 (****************************************************************************)
 (* 1- Tables                                                                *)
 
@@ -96,7 +90,7 @@ module MakeTable =
 	    if p' == p then obj else
 	      (f,p')
 	in
-        let (inGo,outGo) =
+        let inGo : option_mark * A.t -> obj =
           Libobject.declare_object {(Libobject.default_object nick) with
                 Libobject.load_function = load_options;
 		Libobject.open_function = load_options;
@@ -201,12 +195,13 @@ module MakeRefTable =
 
 type 'a option_sig = {
   optsync  : bool;
+  optdepr  : bool;
   optname  : string;
   optkey   : option_name;
   optread  : unit -> 'a;
   optwrite : 'a -> unit }
 
-type option_type = bool * (unit -> value) -> (value -> unit)
+type option_type = bool * (unit -> option_value) -> (option_value -> unit)
 
 module OptionMap =
   Map.Make (struct  type t = option_name let compare = compare end)
@@ -230,25 +225,25 @@ open Libobject
 open Lib
 
 let declare_option cast uncast
-  { optsync=sync; optname=name; optkey=key; optread=read; optwrite=write } =
+  { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } =
   check_key key;
   let default = read() in
   (* spiwack: I use two spaces in the nicknames of "local" and "global" objects.
       That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are
        lists of strings *without* spaces. *)
   let (write,lwrite,gwrite) = if sync then
-    let (ldecl_obj,_) = (* "Local": doesn't survive section or modules. *)
+    let ldecl_obj = (* "Local": doesn't survive section or modules. *)
       declare_object {(default_object ("L  "^nickname key)) with
 		       cache_function = (fun (_,v) -> write v);
 		       classify_function = (fun _ -> Dispose)}
     in
-    let (decl_obj,_) = (* default locality: survives sections but not modules. *)
+    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. *)
+    let gdecl_obj = (* "Global": survives section and modules. *)
       declare_object {(default_object ("G  "^nickname key)) with
 		       cache_function = (fun (_,v) -> write v);
 		       classify_function = (fun v -> Substitute v);
@@ -269,7 +264,7 @@ let declare_option cast uncast
   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;
+  value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab;
   write
 
 type 'a write_function = 'a -> unit
@@ -292,7 +287,7 @@ let declare_string_option =
 (* Setting values of options *)
 
 let set_option_value locality check_and_cast key v =
-  let (name,(_,read,write,lwrite,gwrite)) =
+  let (name, depr, (_,read,write,lwrite,gwrite)) =
     try get_option key
     with Not_found -> error ("There is no option "^(nickname key)^".")
   in
@@ -330,12 +325,12 @@ let set_int_option_value_gen locality =
   set_option_value locality check_int_value
 let set_bool_option_value_gen locality key v =
   try set_option_value locality check_bool_value key v
-  with UserError (_,s) -> Flags.if_verbose msg_warning s
+  with UserError (_,s) -> Flags.if_warn msg_warning s
 let set_string_option_value_gen locality =
   set_option_value locality check_string_value
 let unset_option_value_gen locality key =
   try set_option_value locality check_unset_value key ()
-  with UserError (_,s) -> Flags.if_verbose msg_warning s
+  with UserError (_,s) -> Flags.if_warn msg_warning s
 
 let set_int_option_value = set_int_option_value_gen None
 let set_bool_option_value = set_bool_option_value_gen None
@@ -350,10 +345,10 @@ let msg_option_value (name,v) =
     | IntValue (Some n) -> int n
     | IntValue None   -> str "undefined"
     | StringValue s   -> str s
-    | IdentValue r    -> pr_global_env Idset.empty r
+(*     | IdentValue r    -> pr_global_env Idset.empty r *)
 
 let print_option_value key =
-  let (name,(_,read,_,_,_)) = get_option key in
+  let (name, depr, (_,read,_,_,_)) = get_option key in
   let s = read () in
   match s with
     | BoolValue b ->
@@ -364,25 +359,37 @@ let print_option_value key =
 	     msg_option_value (name,s) ++ fnl ())
 
 
+let get_tables () =
+  let tables = !value_tab in
+  let fold key (name, depr, (sync,read,_,_,_)) accu =
+    let state = {
+      opt_sync = sync;
+      opt_name = name;
+      opt_depr = depr;
+      opt_value = read ();
+    } in
+    OptionMap.add key state accu
+  in
+  OptionMap.fold fold tables OptionMap.empty
+
 let print_tables () =
+  let print_option key name value depr =
+    let msg = str ("  "^(nickname key)^": ") ++ msg_option_value (name, value) in
+    if depr then msg ++ str " [DEPRECATED]" ++ fnl ()
+    else msg ++ fnl ()
+  in
   msg
     (str "Synchronous options:" ++ fnl () ++
      OptionMap.fold
-       (fun key (name,(sync,read,_,_,_)) p ->
-	  if sync then
-	    p ++ str ("  "^(nickname key)^": ") ++
-	    msg_option_value (name,read()) ++ fnl ()
-	  else
-	    p)
+       (fun key (name, depr, (sync,read,_,_,_)) p ->
+	  if sync then p ++ print_option key name (read ()) depr
+	  else p)
        !value_tab (mt ()) ++
      str "Asynchronous options:" ++ fnl () ++
      OptionMap.fold
-       (fun key (name,(sync,read,_,_,_)) p ->
-	  if sync then
-	    p
-	  else
-	    p ++ str ("  "^(nickname key)^": ") ++
-            msg_option_value (name,read()) ++ fnl ())
+       (fun key (name, depr, (sync,read,_,_,_)) p ->
+	  if sync then p
+	  else p ++ print_option key name (read ()) depr)
        !value_tab (mt ()) ++
      str "Tables:" ++ fnl () ++
      List.fold_right
diff --git a/library/goptions.mli b/library/goptions.mli
index 78c4d8e6..d25c1202 100644
--- a/library/goptions.mli
+++ b/library/goptions.mli
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: goptions.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** This module manages customization parameters at the vernacular level     *)
 
-(* This module manages customization parameters at the vernacular level     *)
-
-(* Two kinds of things are managed : tables and options value
+(** Two kinds of things are managed : tables and options value
    - Tables are created by applying the [MakeTable] functor.
    - Variables storing options value are created by applying one of the
    [declare_int_option], [declare_bool_option], ... functions.
@@ -40,12 +38,11 @@
 
        Set Tata Tutu Titi.
        Unset Tata Tutu Titi.
-       Print Table Tata Tutu Titi. (* synonym: Test Table 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)                   *)
 
-(*i*)
 open Pp
 open Util
 open Names
@@ -53,18 +50,12 @@ open Libnames
 open Term
 open Nametab
 open Mod_subst
-(*i*)
-
-(*s Things common to tables and options. *)
-
-(* The type of table/option keys *)
-type option_name = string list
 
-val error_undeclared_key : option_name -> 'a
+type option_name = Goptionstyp.option_name
 
-(*s Tables. *)
+(** {6 Tables. } *)
 
-(* The functor [MakeStringTable] declares a table containing objects
+(** The functor [MakeStringTable] declares a table containing objects
    of type [string]; the function [member_message] say what to print
    when invoking the "Test Toto Titi foo." command; at the end [title]
    is the table name printed when invoking the "Print Toto Titi."
@@ -85,7 +76,7 @@ sig
   val elements : unit -> string list
 end
 
-(* The functor [MakeRefTable] declares a new table of objects of type
+(** The functor [MakeRefTable] declares a new table of objects of type
    [A.t] practically denoted by [reference]; the encoding function
    [encode : reference -> A.t] is typically a globalization function,
    possibly with some restriction checks; the function
@@ -113,21 +104,26 @@ module MakeRefTable :
     end
 
 
-(*s Options. *)
+(** {6 Options. } *)
 
-(* These types and function are for declaring a new option of name [key]
+(** 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
    used when printing the option value (command "Print Toto Titi." *)
 
 type 'a option_sig = {
   optsync    : bool;
+  (** whether the option is synchronous w.r.t to the section/module system. *)
+  optdepr    : bool;
+  (** whether the option is DEPRECATED *)
   optname    : string;
+  (** a short string describing the option *)
   optkey     : option_name;
+  (** the low-level name of this option *)
   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
@@ -137,7 +133,9 @@ val declare_bool_option  : bool option_sig   -> bool write_function
 val declare_string_option: string option_sig -> string write_function
 
 
-(*s Special functions supposed to be used only in vernacentries.ml *)
+(** {6 Special functions supposed to be used only in vernacentries.ml } *)
+
+module OptionMap : Map.S with type key = option_name
 
 val get_string_table :
   option_name ->
@@ -153,7 +151,8 @@ val get_ref_table :
       mem : reference -> unit;
       print : unit >
 
-(* The first argument is a locality flag. [Some true] = "Local", [Some false]="Global". *)
+(** 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
@@ -165,5 +164,7 @@ val set_string_option_value : option_name -> string -> unit
 
 val print_option_value : option_name -> unit
 
+val get_tables : unit -> Goptionstyp.option_state OptionMap.t
 val print_tables : unit -> unit
 
+val error_undeclared_key : option_name -> 'a
diff --git a/library/goptionstyp.mli b/library/goptionstyp.mli
new file mode 100644
index 00000000..541a1470
--- /dev/null
+++ b/library/goptionstyp.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Some types used in the generic option mechanism (Goption) *)
+
+(** Placing them here in a pure interface avoid some dependency issues
+    when compiling CoqIDE *)
+
+type option_name = string list
+
+type option_value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
+
+type option_state = {
+  opt_sync  : bool;
+  opt_depr  : bool;
+  opt_name  : string;
+  opt_value : option_value;
+}
diff --git a/library/heads.ml b/library/heads.ml
index 8244761d..9f9f1ca2 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heads.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -150,7 +148,7 @@ let cache_head o =
 let subst_head_approximation subst = function
   | RigidHead (RigidParameter cst) as k ->
       let cst,c = subst_con subst cst in
-      if c = mkConst cst then
+      if isConst c && eq_constant (destConst c) cst then
         (* A change of the prefix of the constant *)
         k
       else
@@ -169,7 +167,9 @@ let discharge_head (_,(ref,k)) =
 let rebuild_head (ref,k) =
   (ref, compute_head ref)
 
-let (inHead, _) =
+type head_obj = evaluable_global_reference * head_approximation
+
+let inHead : head_obj -> obj =
   declare_object {(default_object "HEAD") with
     cache_function = cache_head;
     load_function = load_head;
diff --git a/library/heads.mli b/library/heads.mli
index e13b171f..9e80c173 100644
--- a/library/heads.mli
+++ b/library/heads.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heads.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Environ
@@ -17,12 +15,12 @@ open Environ
     provides the function to compute the head symbols and a table to
     store the heads *)
 
-(* [declared_head] computes and registers the head symbol of a
+(** [declared_head] computes and registers the head symbol of a
    possibly evaluable constant or variable *)
 
 val declare_head : evaluable_global_reference -> unit
 
-(* [is_rigid] tells if some term is known to ultimately reduce to a term
+(** [is_rigid] tells if some term is known to ultimately reduce to a term
     with a rigid head symbol *)
 
 val is_rigid : env -> constr -> bool
diff --git a/library/impargs.ml b/library/impargs.ml
index 1c2b5afe..ef7f5921 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: impargs.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Libnames
@@ -159,7 +157,7 @@ let is_flexible_reference env bound depth f =
     | Rel n -> (* since local definitions have been expanded *) false
     | Const kn ->
         let cb = Environ.lookup_constant kn env in
-        cb.const_body <> None & not cb.const_opaque
+	(match cb.const_body with Def _ -> true | _ -> false)
     | Var id ->
         let (_,value,_) = Environ.lookup_named id env in value <> None
     | Ind _ | Construct _ -> false
@@ -248,6 +246,10 @@ let compute_auto_implicits env flags enriching t =
   if enriching then compute_implicits_flags env flags true t
   else compute_implicits_gen false false false true true env t
 
+let compute_implicits_names env t =
+  let _, impls = compute_implicits_gen false false false false true env t in
+  List.map fst impls
+
 (* Extra information about implicit arguments *)
 
 type maximal_insertion = bool (* true = maximal contextual insertion *)
@@ -439,9 +441,6 @@ let merge_impls (cond,oldimpls) (_,newimpls) =
     | Some (_, Manual, _) -> orig
     | _ -> ni) oldimpls newimpls)@usersuffiximpls
 
-let merge_impls_list oldimpls newimpls =
-  merge_impls oldimpls newimpls
-
 (* Caching implicits *)
 
 type implicit_interactive_request =
@@ -458,7 +457,18 @@ type implicit_discharge_request =
 let implicits_table = ref Refmap.empty
 
 let implicits_of_global ref =
-  try Refmap.find ref !implicits_table with Not_found -> [DefaultImpArgs,[]]
+  try
+    let l = Refmap.find ref !implicits_table in
+    try
+      let rename_l = Arguments_renaming.arguments_names ref in
+      let rename imp name = match imp, name with
+       | Some (_, x,y), Name id -> Some (id, x,y)
+       | _ -> imp in
+      List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l
+    with Not_found -> l
+    | Invalid_argument _ ->
+        anomaly "renamings list and implicits list have different lenghts"
+  with Not_found -> [DefaultImpArgs,[]]
 
 let cache_implicits_decl (ref,imps) =
   implicits_table := Refmap.add ref imps !implicits_table
@@ -496,18 +506,23 @@ let discharge_implicits (_,(req,l)) =
   match req with
   | ImplLocal -> None
   | ImplInteractive (ref,flags,exp) ->
+    (try
       let vars = section_segment_of_reference ref in
       let ref' = if isVarRef ref then ref else pop_global_reference ref in
       let extra_impls = impls_of_context vars in
       let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in
       Some (ImplInteractive (ref',flags,exp),l')
+    with Not_found -> (* ref not defined in this section *) Some (req,l))
   | ImplConstant (con,flags) ->
+    (try
       let con' = pop_con con in
       let vars = section_segment_of_constant con in
       let extra_impls = impls_of_context vars in
       let l' = [ConstRef con',List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in
 	Some (ImplConstant (con',flags),l')
+    with Not_found -> (* con not defined in this section *) Some (req,l))
   | ImplMutualInductive (kn,flags) ->
+    (try
       let l' = List.map (fun (gr, l) ->
 	let vars = section_segment_of_reference gr in
 	let extra_impls = impls_of_context vars in
@@ -515,6 +530,7 @@ let discharge_implicits (_,(req,l)) =
 	 List.map (add_section_impls vars extra_impls) l)) l
       in
 	Some (ImplMutualInductive (pop_kn kn,flags),l')
+    with Not_found -> (* ref not defined in this section *) Some (req,l))
 
 let rebuild_implicits (req,l) =
   match req with
@@ -553,7 +569,11 @@ let rebuild_implicits (req,l) =
 let classify_implicits (req,_ as obj) =
   if req = ImplLocal then Dispose else Substitute obj
 
-let (inImplicits, _) =
+type implicits_obj =
+    implicit_discharge_request *
+      (global_reference * implicits_list list) list
+
+let inImplicits : implicits_obj -> obj =
   declare_object {(default_object "IMPLICITS") with
     cache_function = cache_implicits;
     load_function = load_implicits;
@@ -593,6 +613,8 @@ let declare_mib_implicits kn =
 (* Declare manual implicits *)
 type manual_explicitation = Topconstr.explicitation * (bool * bool * bool)
 
+type manual_implicits = manual_explicitation list
+
 let compute_implicits_with_manual env typ enriching l =
   let _,autoimpls = compute_auto_implicits env !implicit_args enriching typ in
   set_manual_implicits env !implicit_args enriching autoimpls l
diff --git a/library/impargs.mli b/library/impargs.mli
index 7ec7767b..04251f33 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -1,22 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: impargs.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Libnames
 open Term
 open Environ
 open Nametab
-(*i*)
 
-(*s Implicit arguments. Here we store the implicit arguments. Notice that we
+(** {6 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
@@ -36,7 +33,8 @@ val is_maximal_implicit_args : unit -> bool
 type implicits_flags
 val with_implicits : implicits_flags -> ('a -> 'b) -> 'a -> 'b
 
-(*s An [implicits_list] is a list of positions telling which arguments
+(** {6 ... } *)
+(** An [implicits_list] is a list of positions telling which arguments
     of a reference can be automatically infered *)
 
 
@@ -44,13 +42,35 @@ type argument_position =
   | Conclusion
   | Hyp of int
 
+(** We remember various information about why an argument is
+   inferable as implicit *)
 type implicit_explanation =
   | DepRigid of argument_position
+      (** means that the implicit argument can be found by
+	  unification along a rigid path (we do not print the arguments of
+	  this kind if there is enough arguments to infer them) *)
   | DepFlex of argument_position
+      (** means that the implicit argument can be found by unification
+	  along a collapsable path only (e.g. as x in (P x) where P is another
+	  argument) (we do (defensively) print the arguments of this kind) *)
   | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position
+      (** means that the least argument from which the
+	  implicit argument can be inferred is following a collapsable path
+	  but there is a greater argument from where the implicit argument is
+	  inferable following a rigid path (useful to know how to print a
+	  partial application) *)
   | Manual
+      (** means the argument has been explicitely set as implicit. *)
+      
+(**  We also consider arguments inferable from the conclusion but it is
+     operational only if [conclusion_matters] is true. *)
+
+type maximal_insertion = bool (** true = maximal contextual insertion *)
+type force_inference = bool (** true = always infer, never turn into evar/subgoal *)
 
-type implicit_status = (identifier * implicit_explanation * (bool * bool)) option
+type implicit_status = (identifier * implicit_explanation * 
+			  (maximal_insertion * force_inference)) option
+    (** [None] = Not implicit *)
 
 type implicit_side_condition
 
@@ -64,19 +84,20 @@ val force_inference_of : implicit_status -> bool
 
 val positions_of_implicits : implicits_list -> int list
 
-(* Computation of the positions of arguments automatically inferable
-   for an object of the given type in the given env *)
-val compute_implicits : env -> types -> implicits_list list
-
-(* A [manual_explicitation] is a tuple of a positional or named explicitation with
+(** A [manual_explicitation] is a tuple of a positional or named explicitation with
    maximal insertion, force inference and force usage flags. Forcing usage makes
    the argument implicit even if the automatic inference considers it not inferable. *)
-type manual_explicitation = Topconstr.explicitation * (bool * bool * bool)
+type manual_explicitation = Topconstr.explicitation * 
+    (maximal_insertion * force_inference * bool)
+
+type manual_implicits = manual_explicitation list
 
 val compute_implicits_with_manual : env -> types -> bool ->
-  manual_explicitation list -> implicit_status list
+  manual_implicits -> implicit_status list
+
+val compute_implicits_names : env -> types -> name list
 
-(*s Computation of implicits (done using the global environment). *)
+(** {6 Computation of implicits (done using the global environment). } *)
 
 val declare_var_implicits : variable -> unit
 val declare_constant_implicits : constant -> unit
@@ -84,28 +105,26 @@ val declare_mib_implicits : mutual_inductive -> unit
 
 val declare_implicits : bool -> global_reference -> unit
 
-(* [declare_manual_implicits local ref enriching l]
+(** [declare_manual_implicits local ref enriching l]
    Manual declaration of which arguments are expected implicit.
    If not set, we decide if it should enrich by automatically inferd
    implicits depending on the current state.
    Unsets implicits if [l] is empty. *)
 
 val declare_manual_implicits : bool -> global_reference -> ?enriching:bool ->
-  manual_explicitation list list -> unit
+  manual_implicits list -> unit
 
-(* If the list is empty, do nothing, otherwise declare the implicits. *)
+(** If the list is empty, do nothing, otherwise declare the implicits. *)
 
 val maybe_declare_manual_implicits : bool -> global_reference -> ?enriching:bool ->
-  manual_explicitation list -> unit
+  manual_implicits -> unit
 
 val implicits_of_global : global_reference -> implicits_list list
 
 val extract_impargs_data :
   implicits_list list -> ((int * int) option * implicit_status list) list
 
-val lift_implicits : int -> manual_explicitation list -> manual_explicitation list
-
-val merge_impls : implicits_list -> implicits_list -> implicits_list
+val lift_implicits : int -> manual_implicits -> manual_implicits
 
 val make_implicits_list : implicit_status list -> implicits_list list
 
@@ -115,9 +134,7 @@ val select_impargs_size : int -> implicits_list list -> implicit_status list
 
 val select_stronger_impargs : implicits_list list -> implicit_status list
 
-type implicit_interactive_request =
-  | ImplAuto
-  | ImplManual of int
+type implicit_interactive_request
 
 type implicit_discharge_request =
   | ImplLocal
diff --git a/library/lib.ml b/library/lib.ml
index 6f8655d3..7554fd0b 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -1,26 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: lib.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Libnames
 open Nameops
 open Libobject
 open Summary
+
+type is_type = bool (* Module Type or just Module *)
+type export = bool option (* None for a Module Type *)
+
 type node =
   | Leaf of obj
   | CompilingLibrary of object_prefix
-  | OpenedModule of bool option * object_prefix * Summary.frozen
+  | OpenedModule of is_type * export * object_prefix * Summary.frozen
   | ClosedModule  of library_segment
-  | OpenedModtype of object_prefix * Summary.frozen
-  | ClosedModtype of library_segment
   | OpenedSection of object_prefix * Summary.frozen
   | ClosedSection of library_segment
   | FrozenState of Summary.frozen
@@ -31,6 +31,9 @@ and library_segment = library_entry list
 
 type lib_objects =  (Names.identifier * obj) list
 
+let module_kind is_type =
+  if is_type then "module type" else "module"
+
 let iter_objects f i prefix =
   List.iter (fun (id,obj) -> f i (make_oname prefix id, obj))
 
@@ -69,10 +72,9 @@ let classify_segment seg =
     (* LEM; TODO: Understand what this does and see if what I do is the
                   correct thing for ClosedMod(ule|type) *)
     | (_,ClosedModule _) :: stk -> clean acc stk
-    | (_,ClosedModtype _) :: stk -> clean acc stk
     | (_,OpenedSection _) :: _ -> error "there are still opened sections"
-    | (_,OpenedModule _) :: _ -> error "there are still opened modules"
-    | (_,OpenedModtype _) :: _ -> error "there are still opened module types"
+    | (_,OpenedModule (ty,_,_,_)) :: _ ->
+      error ("there are still opened " ^ module_kind ty ^"s")
     | (_,FrozenState _) :: stk -> clean acc stk
   in
     clean ([],[],[]) (List.rev seg)
@@ -144,8 +146,7 @@ let make_oname id = make_path id, make_kn id
 let recalc_path_prefix () =
   let rec recalc = function
     | (sp, OpenedSection (dir,_)) :: _ -> dir
-    | (sp, OpenedModule (_,dir,_)) :: _ -> dir
-    | (sp, OpenedModtype (dir,_)) :: _ -> dir
+    | (sp, OpenedModule (_,_,dir,_)) :: _ -> dir
     | (sp, CompilingLibrary dir) :: _ -> dir
     | _::l -> recalc l
     | [] -> initial_prefix
@@ -181,7 +182,6 @@ let split_lib_gen test =
 	then Some (collect after [hd] before)
 	else (match hd with
 		| (sp,ClosedModule  seg)
-		| (sp,ClosedModtype seg)
 		| (sp,ClosedSection seg) ->
 		    (match findeq after seg with
 		       | None -> findeq (hd::after) before
@@ -197,11 +197,11 @@ let split_lib_gen test =
 let split_lib sp = split_lib_gen (fun x -> fst x = sp)
 
 let split_lib_at_opening sp =
-  let a,s,b = split_lib_gen (function
-    | x,(OpenedSection _|OpenedModule _|OpenedModtype _|CompilingLibrary _) ->
-	x = sp
-    | _ ->
-	false) in
+  let is_sp = function
+    | x,(OpenedSection _|OpenedModule _|CompilingLibrary _) -> x = sp
+    | _ -> false
+  in
+  let a,s,b = split_lib_gen is_sp in
   assert (List.tl s = []);
   (a,List.hd s,b)
 
@@ -254,97 +254,66 @@ let add_frozen_state () =
 
 (* Modules. *)
 
-
-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
+  | _,(OpenedSection _ | OpenedModule _) -> true
   | _ -> false
 
+let is_opening_node_or_lib = function
+  | _,(CompilingLibrary _ | OpenedSection _ | OpenedModule _) -> true
+  | _ -> false
 
 let current_mod_id () =
-  try match find_entry_p is_opening_node with
-    | oname,OpenedModule (_,_,fs) ->
-	basename (fst oname)
-    | oname,OpenedModtype (_,fs) ->
-	basename (fst oname)
+  try match find_entry_p is_opening_node_or_lib with
+    | oname,OpenedModule (_,_,_,fs) -> basename (fst oname)
+    | oname,CompilingLibrary _ -> basename (fst oname)
     | _ -> error "you are not in a module"
-  with Not_found ->
-    error "no opened modules"
+  with Not_found -> error "no opened modules"
 
 
-let start_module export id mp fs =
+let start_mod is_type export id mp fs =
   let dir = add_dirpath_suffix (fst !path_prefix) id in
   let prefix = dir,(mp,Names.empty_dirpath) in
-  let 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,fs));
+  let sp = make_path id in
+  let oname = sp, make_kn id in
+  let exists =
+    if is_type then Nametab.exists_cci sp else Nametab.exists_module dir
+  in
+  if exists then
+    errorlabstrm "open_module" (pr_id id ++ str " already exists");
+  add_entry oname (OpenedModule (is_type,export,prefix,fs));
   path_prefix := prefix;
   prefix
 (*  add_frozen_state () must be called in declaremods *)
 
+let start_module = start_mod false
+let start_modtype = start_mod true None
+
 let error_still_opened string oname =
   let id = basename (fst oname) in
-  errorlabstrm "" (str string ++ spc () ++ pr_id id ++ str " is still opened.")
+  errorlabstrm ""
+    (str ("The "^string^" ") ++ pr_id id ++ str " is still opened.")
 
-let end_module () =
+let end_mod is_type =
   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
+      | oname,OpenedModule (ty,_,_,fs) ->
+	if ty = is_type then oname,fs
+	else error_still_opened (module_kind ty) oname
+      | oname,OpenedSection _ -> error_still_opened "section" oname
       | _ -> assert false
-    with Not_found ->
-      error "No opened modules."
+    with Not_found -> error "No opened modules."
   in
   let (after,mark,before) = split_lib_at_opening oname in
   lib_stk := before;
   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
-          with global.ml, given that closing a module does?
-     TODO
-   *)
   recalc_path_prefix ();
   (* 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 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,fs));
-  path_prefix := prefix;
-  prefix
-
-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,mark,before) = split_lib_at_opening oname in
-  lib_stk := before;
-  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 *)
-  (oname,dir,fs,after)
-
+let end_module () = end_mod false
+let end_modtype () = end_mod true
 
 let contents_after = function
   | None -> !lib_stk
@@ -352,13 +321,6 @@ let contents_after = function
 
 (* Modules. *)
 
-let check_for_comp_unit () =
-  let is_decl = function (_,FrozenState _) -> false | _ -> true in
-  try
-    let _ = find_entry_p is_decl in
-    error "a module cannot be started after some declarations"
-  with Not_found -> ()
-
 (* TODO: use check_for_module ? *)
 let start_compilation s mp =
   if !comp_name <> None then
@@ -374,21 +336,18 @@ let end_compilation dir =
   let _ =
     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."
+      | OpenedModule (ty,_,_,_) ->
+	error ("There are some open "^module_kind ty^"s.")
       | _ -> assert false
-    with
-	Not_found -> ()
+    with Not_found -> ()
   in
-  let module_p =
-    function (_,CompilingLibrary _) -> true | x -> is_opening_node x
+  let is_opening_lib = function _,CompilingLibrary _ -> true | _ -> false
   in
   let oname =
-    try match find_entry_p module_p with
-	(oname, CompilingLibrary prefix) -> oname
+    try match find_entry_p is_opening_lib with
+      |	(oname, CompilingLibrary prefix) -> oname
       | _ -> assert false
-    with
-	Not_found -> anomaly "No module declared"
+    with Not_found -> anomaly "No module declared"
   in
   let _ =
     match !comp_name with
@@ -399,31 +358,23 @@ let end_compilation dir =
 	       " and not " ^ (Names.string_of_dirpath m));
   in
   let (after,mark,before) = split_lib_at_opening oname in
-    comp_name := None;
-    !path_prefix,after
+  comp_name := None;
+  !path_prefix,after
 
-(* Returns true if we are inside an opened module type *)
-let is_modtype () =
-  let opened_p = function
-    | _, OpenedModtype _ -> true
-    | _ -> false
-  in
-    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 opened_p = function
-    | _, OpenedModule _ -> true
+(* Returns true if we are inside an opened module or module type *)
+
+let is_module_gen which =
+  let test = function
+    | _, OpenedModule (ty,_,_,_) -> which ty
     | _ -> false
   in
-    try
-      let _ = find_entry_p opened_p in true
-    with
-	Not_found -> false
+  try
+    let _ = find_entry_p test in true
+  with Not_found -> false
 
+let is_module_or_modtype () = is_module_gen (fun _ -> true)
+let is_modtype () = is_module_gen (fun b -> b)
+let is_module () = is_module_gen (fun b -> not b)
 
 (* Returns the opening node of a given name *)
 let find_opening_node id =
@@ -495,8 +446,6 @@ let add_section_constant kn =
 
 let replacement_context () = pi2 (List.hd !sectab)
 
-let variables_context () = pi1 (List.hd !sectab)
-
 let section_segment_of_constant con =
   Names.Cmap.find con (fst (pi3 (List.hd !sectab)))
 
@@ -563,8 +512,8 @@ let discharge_item ((sp,_ as oname),e) =
   | Leaf lobj ->
       Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj))
   | FrozenState _ -> None
-  | ClosedSection _ | ClosedModtype _ | ClosedModule _ -> None
-  | OpenedSection _ | OpenedModtype _ | OpenedModule _ | CompilingLibrary _ ->
+  | ClosedSection _ | ClosedModule _ -> None
+  | OpenedSection _ | OpenedModule _ | CompilingLibrary _ ->
       anomaly "discharge_item"
 
 let close_section () =
@@ -590,8 +539,8 @@ let close_section () =
 (*****************)
 (* Backtracking. *)
 
-let (inLabel,outLabel) =
-  declare_object {(default_object "DOT") with
+let (inLabel : int -> obj), (outLabel : obj -> int) =
+  declare_object_full {(default_object "DOT") with
 				classify_function = (fun _ -> Dispose)}
 
 let recache_decl = function
@@ -604,13 +553,6 @@ let recache_context ctx =
 
 let is_frozen_state = function (_,FrozenState _) -> true | _ -> false
 
-let has_top_frozen_state () =
-  let rec aux = function
-  | (sp, FrozenState _)::_ -> Some sp
-  | (sp, Leaf o)::t when object_tag o = "DOT" -> aux t
-  | _ -> None
-  in aux !lib_stk
-
 let set_lib_stk new_lib_stk =
   lib_stk := new_lib_stk;
   recalc_path_prefix ();
@@ -630,17 +572,9 @@ let reset_to_gen test =
 
 let reset_to sp = reset_to_gen (fun x -> fst x = sp)
 
-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; recalc_path_prefix (); unfreeze_summaries f
-  | _ -> error "Not a frozen state"
-
-
 (* LEM: TODO
  * We will need to muck with frozen states in after, too!
- * Not only FrozenState, but also those embedded in Opened(Section|Module|Modtype)
+ * Not only FrozenState, but also those embedded in Opened(Section|Module)
  *)
 let delete_gen test =
   let (after,equal,before) = split_lib_gen test in
@@ -676,8 +610,8 @@ let remove_name (loc,id) =
     delete sp
 
 let is_mod_node = function
-  | OpenedModule _ | OpenedModtype _ | OpenedSection _
-  | ClosedModule _ | ClosedModtype _ | ClosedSection _  -> true
+  | OpenedModule _ | OpenedSection _
+  | ClosedModule _ | ClosedSection _  -> true
   | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE"
 	|| t = "MODULE ALIAS"
   | _ -> false
@@ -710,17 +644,16 @@ let is_label_n n x =
     | (sp,Leaf o) when object_tag o = "DOT" && n = outLabel o -> true
     | _ -> false
 
-(* Reset the label registered by [mark_end_of_command()] with number n. *)
+(** Reset the label registered by [mark_end_of_command()] with number n,
+    which should be strictly in the past. *)
+
 let reset_label n =
-  let current = current_command_label() in
-  if n < current then
-    let res = reset_to_gen (is_label_n n) in
-    set_command_label (n-1); (* forget state numbers after n only if reset succeeded *)
-    res
-  else (* optimisation to avoid recaching when not necessary (why is it so long??) *)
-    match !lib_stk with
-      | [] -> ()
-      | x :: ls -> (lib_stk := ls;set_command_label (n-1))
+  if n >= current_command_label () then
+    error "Cannot backtrack to the current label or a future one";
+  let res = reset_to_gen (is_label_n n) in
+  (* forget state numbers after n only if reset succeeded *)
+  set_command_label (n-1);
+  res
 
 let rec back_stk n stk =
   match stk with
@@ -729,7 +662,9 @@ let rec back_stk n stk =
     | _::tail -> back_stk n tail
     | [] -> error "Reached begin of command history"
 
-let back n = reset_to (back_stk n !lib_stk)
+let back n =
+  reset_to (back_stk n !lib_stk);
+  set_command_label (current_command_label () - n - 1)
 
 (* State and initialization. *)
 
@@ -793,7 +728,7 @@ let rec split_mp mp =
     | Names.MPdot (prfx, lbl) ->
 	let mprec, dprec = split_mp prfx in
 	  mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec))
-    | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in  library_dp(), Names.make_dirpath [Names.id_of_string id]
+    | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in  library_dp(), Names.make_dirpath [id]
 
 let split_modpath mp =
   let rec aux = function
diff --git a/library/lib.mli b/library/lib.mli
index 7eb8b688..0d6eb34b 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -1,25 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lib.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
+(** Lib: record of operations, backtrack, low-level sections *)
 
-(*s This module provides a general mechanism to keep a trace of all operations
+(** 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 is_type = bool (* Module Type or just Module *)
+type export = bool option (* None for a Module Type *)
+
 type node =
   | Leaf of Libobject.obj
   | CompilingLibrary of Libnames.object_prefix
-  | OpenedModule of bool option * Libnames.object_prefix * Summary.frozen
+  | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen
   | ClosedModule  of library_segment
-  | OpenedModtype of Libnames.object_prefix * Summary.frozen
-  | ClosedModtype of library_segment
   | OpenedSection of Libnames.object_prefix * Summary.frozen
   | ClosedSection of library_segment
   | FrozenState of Summary.frozen
@@ -28,14 +29,14 @@ and library_segment = (Libnames.object_name * node) list
 
 type lib_objects = (Names.identifier * Libobject.obj) list
 
-(*s Object iteratation functions. *)
+(** {6 Object iteration functions. } *)
 
 val open_objects : int -> Libnames.object_prefix -> lib_objects -> unit
 val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit
 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,
+(** [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
@@ -43,41 +44,45 @@ val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects
 val classify_segment :
   library_segment -> lib_objects * lib_objects * Libobject.obj list
 
-(* [segment_of_objects prefix objs] forms a list of Leafs *)
+(** [segment_of_objects prefix objs] forms a list of Leafs *)
 val segment_of_objects :
   Libnames.object_prefix -> lib_objects -> library_segment
 
 
-(*s Adding operations (which call the [cache] method, and getting the
+(** {6 ... } *)
+(** Adding operations (which call the [cache] method, and getting the
   current list of operations (most recent ones coming first). *)
 
 val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name
 val add_anonymous_leaf : Libobject.obj -> unit
 
-(* this operation adds all objects with the same name and calls [load_object]
+(** this operation adds all objects with the same name and calls [load_object]
    for each of them *)
 val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name
 
 val add_frozen_state : unit -> unit
 
-(* Adds a "dummy" entry in lib_stk with a unique new label number. *)
+(** Adds a "dummy" entry in lib_stk with a unique new label number. *)
 val mark_end_of_command : unit -> unit
-(* Returns the current label number *)
+
+(** Returns the current label number *)
 val current_command_label : unit -> int
-(* [reset_label n ] resets [lib_stk] to the label n registered by
-   [mark_end_of_command()]. That is it forgets the label and anything
-   registered after it. *)
+
+(** [reset_label n] resets [lib_stk] to the label n registered by
+   [mark_end_of_command()]. It forgets the label and anything
+   registered after it. The label should be strictly in the past. *)
 val reset_label : int -> unit
 
-(*s The function [contents_after] returns the current library segment,
+(** {6 ... } *)
+(** The function [contents_after] returns the current library segment,
   starting from a given section path. If not given, the entire segment
   is returned. *)
 
 val contents_after : Libnames.object_name option -> library_segment
 
-(*s Functions relative to current path *)
+(** {6 Functions relative to current path } *)
 
-(* User-side names *)
+(** User-side names *)
 val cwd : unit -> Names.dir_path
 val cwd_except_section : unit -> Names.dir_path
 val current_dirpath : bool -> Names.dir_path (* false = except sections *)
@@ -85,72 +90,79 @@ 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 *)
+(** Kernel-side names *)
 val current_prefix : unit -> Names.module_path * Names.dir_path
 val make_kn : Names.identifier -> Names.kernel_name
 val make_con : Names.identifier -> Names.constant
 
-(* Are we inside an opened section *)
+(** Are we inside an opened section *)
 val sections_are_opened : unit -> bool
 val sections_depth : unit -> int
 
-(* Are we inside an opened module type *)
+(** Are we inside an opened module type *)
+val is_module_or_modtype : unit -> bool
 val is_modtype : unit -> bool
 val is_module : unit -> bool
 val current_mod_id : unit -> Names.module_ident
 
-(* Returns the opening node of a given name *)
+(** Returns the opening node of a given name *)
 val find_opening_node : Names.identifier -> node
 
-(*s Modules and module types *)
+(** {6 Modules and module types } *)
 
 val start_module :
-  bool option -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix
-val end_module : unit
-  -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment
+  export -> Names.module_ident -> Names.module_path ->
+  Summary.frozen -> Libnames.object_prefix
 
 val start_modtype :
-  Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix
-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 *)
+  Names.module_ident -> Names.module_path ->
+  Summary.frozen -> Libnames.object_prefix
+
+val end_module :
+  unit ->
+  Libnames.object_name * Libnames.object_prefix *
+    Summary.frozen * library_segment
 
-(*s Compilation units *)
+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 *)
+
+(** {6 Compilation units } *)
 
 val start_compilation : Names.dir_path -> Names.module_path -> unit
 val end_compilation : Names.dir_path -> Libnames.object_prefix * library_segment
 
-(* The function [library_dp] returns the [dir_path] of the current
+(** The function [library_dp] returns the [dir_path] of the current
    compiling library (or [default_library]) *)
 val library_dp : unit -> Names.dir_path
 
-(* Extract the library part of a name even if in a section *)
+(** Extract the library part of a name even if in a section *)
 val dp_of_mp : Names.module_path -> Names.dir_path
 val split_mp : Names.module_path -> Names.dir_path * Names.dir_path
 val split_modpath : Names.module_path -> Names.dir_path * Names.identifier list
 val library_part :  Libnames.global_reference -> Names.dir_path
 val remove_section_part : Libnames.global_reference -> Names.dir_path
 
-(*s Sections *)
+(** {6 Sections } *)
 
 val open_section : Names.identifier -> unit
 val close_section : unit -> unit
 
-(*s Backtracking (undo). *)
+(** {6 Backtracking (undo). } *)
 
 val reset_to : Libnames.object_name -> unit
 val reset_name : Names.identifier Util.located -> unit
 val remove_name : Names.identifier Util.located -> unit
 val reset_mod : Names.identifier Util.located -> unit
-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
 
-(*s We can get and set the state of the operations (used in [States]). *)
+(** {6 We can get and set the state of the operations (used in [States]). } *)
 
 type frozen
 
@@ -163,13 +175,13 @@ val declare_initial_state : unit -> unit
 val reset_initial : unit -> unit
 
 
-(* XML output hooks *)
+(** XML output hooks *)
 val set_xml_open_section : (Names.identifier -> unit) -> unit
 val set_xml_close_section : (Names.identifier -> unit) -> unit
 
 type binding_kind = Explicit | Implicit
 
-(*s Section management for discharge *)
+(** {6 Section management for discharge } *)
 type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types
 type variable_context = variable_info list
 
@@ -189,7 +201,7 @@ val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit
 val replacement_context : unit ->
   (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t)
 
-(*s Discharge: decrease the section level if in the current section *)
+(** {6 Discharge: decrease the section level if in the current section } *)
 
 val discharge_kn :  Names.mutual_inductive -> Names.mutual_inductive
 val discharge_con : Names.constant -> Names.constant
diff --git a/library/libnames.ml b/library/libnames.ml
index 2986940d..b91d24bd 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 open Names
@@ -29,8 +27,7 @@ let isConstructRef = function ConstructRef _ -> true | _ -> false
 
 let eq_gr gr1 gr2 =
   match gr1,gr2 with 
-      ConstRef con1, ConstRef con2 ->
-	eq_constant con1 con2
+    | 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
@@ -58,13 +55,10 @@ let subst_global subst ref = match ref with
 	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
+  | 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
@@ -82,25 +76,37 @@ let constr_of_global = function
 let constr_of_reference = constr_of_global
 let reference_of_constr = global_of_constr
 
-(* outside of the kernel, names are ordered on their canonical part *)
+let global_ord_gen fc fmi x y =
+  let ind_ord (indx,ix) (indy,iy) =
+    let c = Pervasives.compare ix iy in
+    if c = 0 then kn_ord (fmi indx) (fmi indy) else c
+  in
+  match x, y with
+    | ConstRef cx, ConstRef cy -> kn_ord (fc cx) (fc cy)
+    | IndRef indx, IndRef indy -> ind_ord indx indy
+    | ConstructRef (indx,jx), ConstructRef (indy,jy) ->
+      let c = Pervasives.compare jx jy in
+      if c = 0 then ind_ord indx indy else c
+    | _, _ -> Pervasives.compare x y
+
+let global_ord_can = global_ord_gen canonical_con canonical_mind
+let global_ord_user = global_ord_gen user_con user_mind
+
+(* By default, [global_reference] are ordered on their canonical part *)
+
 module RefOrdered = struct
   type t = global_reference
-  let compare 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)
+  let compare = global_ord_can
+end
+
+module RefOrdered_env = struct
+  type t = global_reference
+  let compare = global_ord_user
 end
-  
+
 module Refset = Set.Make(RefOrdered)
 module Refmap = Map.Make(RefOrdered)
-  
+
 (* Extended global references *)
 
 type syndef_name = kernel_name
@@ -109,6 +115,18 @@ type extended_global_reference =
   | TrueGlobal of global_reference
   | SynDef of syndef_name
 
+(* We order [extended_global_reference] via their user part
+   (cf. pretty printer) *)
+
+module ExtRefOrdered = struct
+  type t = extended_global_reference
+  let compare x y =
+    match x, y with
+      | TrueGlobal rx, TrueGlobal ry -> global_ord_user rx ry
+      | SynDef knx, SynDef kny -> kn_ord knx kny
+      | _, _ -> Pervasives.compare x y
+end
+
 (**********************************************)
 
 let pr_dirpath sl = (str (string_of_dirpath sl))
@@ -177,6 +195,7 @@ type full_path = {
   basename : identifier }
 
 let make_path pa id = { dirpath = pa; basename = id }
+
 let repr_path { dirpath = pa; basename = id } = (pa,id)
 
 (* parsing and printing of section paths *)
@@ -197,8 +216,6 @@ module SpOrdered =
     let compare = sp_ord
   end
 
-module Spset = Set.Make(SpOrdered)
-module Sppred = Predicate.Make(SpOrdered)
 module Spmap = Map.Make(SpOrdered)
 
 let dirpath sp = let (p,_) = repr_path sp in p
diff --git a/library/libnames.mli b/library/libnames.mli
index a7bc3b52..18b6ac49 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
 open Term
 open Mod_subst
-(*i*)
 
-(*s Global reference is a kernel side type for all references together *)
+(** {6 Global reference is a kernel side type for all references together } *)
 type global_reference =
   | VarRef of variable
   | ConstRef of constant
@@ -40,14 +36,14 @@ val destConstructRef : global_reference -> constructor
 val subst_constructor : substitution -> constructor -> constructor * constr
 val subst_global : substitution -> global_reference -> global_reference * constr
 
-(* Turn a global reference into a construction *)
+(** Turn a global reference into a construction *)
 val constr_of_global : global_reference -> constr
 
-(* Turn a construction denoting a global reference into a global reference;
+(** Turn a construction denoting a global reference into a global reference;
    raise [Not_found] if not a global reference *)
 val global_of_constr : constr -> global_reference
 
-(* Obsolete synonyms for constr_of_global and global_of_constr *)
+(** Obsolete synonyms for constr_of_global and global_of_constr *)
 val constr_of_reference : global_reference -> constr
 val reference_of_constr : constr -> global_reference
 
@@ -55,12 +51,16 @@ module RefOrdered : sig
   type t = global_reference
   val compare : global_reference -> global_reference -> int
 end
-  
+
+module RefOrdered_env : sig
+  type t = global_reference
+  val compare : global_reference -> global_reference -> int
+end
 
 module Refset : Set.S with type elt = global_reference
 module Refmap : Map.S with type key = global_reference
 
-(*s Extended global references *)
+(** {6 Extended global references } *)
 
 type syndef_name = kernel_name
 
@@ -68,19 +68,24 @@ type extended_global_reference =
   | TrueGlobal of global_reference
   | SynDef of syndef_name
 
-(*s Dirpaths *)
+module ExtRefOrdered : sig
+  type t = extended_global_reference
+  val compare : t -> t -> int
+end
+
+(** {6 Dirpaths } *)
 val pr_dirpath : dir_path -> Pp.std_ppcmds
 
 val dirpath_of_string : string -> dir_path
 val string_of_dirpath : dir_path -> string
 
-(* Pop the suffix of a [dir_path] *)
+(** Pop the suffix of a [dir_path] *)
 val pop_dirpath : dir_path -> dir_path
 
-(* Pop the suffix n times *)
+(** Pop the suffix n times *)
 val pop_dirpath_n : int -> dir_path -> dir_path
 
-(* Give the immediate prefix and basename of a [dir_path] *)
+(** Give the immediate prefix and basename of a [dir_path] *)
 val split_dirpath : dir_path -> dir_path * identifier
 
 val add_dirpath_suffix : dir_path -> module_ident -> dir_path
@@ -95,28 +100,27 @@ val is_dirpath_prefix_of : dir_path -> dir_path -> bool
 module Dirset : Set.S with type elt = dir_path
 module Dirmap : Map.S with type key = dir_path
 
-(*s Full paths are {\em absolute} paths of declarations *)
+(** {6 Full paths are {e absolute} paths of declarations } *)
 type full_path
 
-(* Constructors of [full_path] *)
+(** Constructors of [full_path] *)
 val make_path : dir_path -> identifier -> full_path
 
-(* Destructors of [full_path] *)
+(** Destructors of [full_path] *)
 val repr_path : full_path -> dir_path * identifier
 val dirpath : full_path -> dir_path
 val basename : full_path -> identifier
 
-(* Parsing and printing of section path as ["coq_root.module.id"] *)
+(** Parsing and printing of section path as ["coq_root.module.id"] *)
 val path_of_string : string -> full_path
 val string_of_path : full_path -> string
 val pr_path : full_path -> std_ppcmds
 
-module Sppred : Predicate.S with type elt = full_path
 module Spmap  : Map.S with type key = full_path
 
 val restrict_path : int -> full_path -> full_path
 
-(*s Temporary function to brutally form kernel names from section paths *)
+(** {6 Temporary function to brutally form kernel names from section paths } *)
 
 val encode_mind : dir_path -> identifier -> mutual_inductive
 val decode_mind : mutual_inductive -> dir_path * identifier
@@ -124,7 +128,8 @@ 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
+(** {6 ... } *)
+(** 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.
     The [qualid] are used to access the name table. *)
@@ -138,14 +143,14 @@ val pr_qualid : qualid -> std_ppcmds
 val string_of_qualid : qualid -> string
 val qualid_of_string : string -> qualid
 
-(* Turns an absolute name, a dirpath, or an identifier into a
+(** Turns an absolute name, a dirpath, or an identifier into a
    qualified name denoting the same name *)
 
 val qualid_of_path : full_path -> qualid
 val qualid_of_dirpath : dir_path -> qualid
 val qualid_of_ident : identifier -> qualid
 
-(* Both names are passed to objects: a "semantic" [kernel_name], which
+(** Both names are passed to objects: a "semantic" [kernel_name], which
    can be substituted and a "syntactic" [full_path] which can be printed
 *)
 
@@ -155,16 +160,17 @@ 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 *)
+(** to this type are mapped [dir_path]'s in the nametab *)
 type global_dir_reference =
   | DirOpenModule of object_prefix
   | DirOpenModtype of object_prefix
   | DirOpenSection of object_prefix
   | DirModule of object_prefix
   | DirClosedSection of dir_path
-      (* this won't last long I hope! *)
+      (** this won't last long I hope! *)
 
-(*s A [reference] is the user-level notion of name. It denotes either a
+(** {6 ... } *)
+(** A [reference] is the user-level notion of name. It denotes either a
     global name (referred either by a qualified name or by a single
     name) or a variable *)
 
@@ -177,13 +183,13 @@ val string_of_reference : reference -> string
 val pr_reference : reference -> std_ppcmds
 val loc_of_reference : reference -> loc
 
-(*s Popping one level of section in global names *)
+(** {6 Popping one level of section in global names } *)
 
 val pop_con : constant -> constant
 val pop_kn : mutual_inductive-> mutual_inductive
 val pop_global_reference : global_reference -> global_reference
 
-(* Deprecated synonyms *)
+(** Deprecated synonyms *)
 
-val make_short_qualid : identifier -> qualid (* = qualid_of_ident *)
-val qualid_of_sp : full_path -> qualid (* = qualid_of_path *)
+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 7b61a386..bc62913d 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: libobject.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Libnames
@@ -18,7 +16,7 @@ open Mod_subst
    wants to work with restricted Coq programs that have only parts of
    the full capabilities, but may still be able to work correctly for
    limited purposes.  One example is for the graphical interface, that uses
-   such a limite coq process to do only parsing.  It loads .vo files, but
+   such a limited Coq process to do only parsing.  It loads .vo files, but
    is only interested in loading the grammar rule definitions. *)
 
 let relax_flag = ref false;;
@@ -57,7 +55,7 @@ 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 actually
    differ from the default.
 
    This helps introducing new functions in objects.
@@ -81,7 +79,7 @@ let object_tag lobj = Dyn.tag lobj
 let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
 
-let declare_object odecl =
+let declare_object_full odecl =
   let na = odecl.object_name in
   let (infun,outfun) = Dyn.create na in
   let cacher (oname,lobj) =
@@ -124,6 +122,8 @@ let declare_object odecl =
 			     dyn_rebuild_function = rebuild };
   (infun,outfun)
 
+let declare_object odecl = fst (declare_object_full odecl)
+
 let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t)
 
 (* this function describes how the cache, load, open, and export functions
@@ -143,8 +143,9 @@ let apply_dyn_fun deflt f lobj =
     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)");
+          Pp.msg_warning
+	    (Pp.str ("Cannot find library functions for an object with tag "
+                      ^ tag ^ " (a plugin may be missing)"));
           Hashtbl.add missing_tab tag ()
         end;
       deflt
diff --git a/library/libobject.mli b/library/libobject.mli
index c0d89e4d..57c3debe 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libobject.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Libnames
 open Mod_subst
-(*i*)
 
-(* [Libobject] declares persistent objects, given with methods:
+(** [Libobject] declares persistent objects, given with methods:
 
    * a caching function specifying how to add the object in the current
      scope;
      If the object wishes to register its visibility in the Nametab,
-     it should do so for all possible sufixes.
+     it should do so for all possible suffixes.
 
    * 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
+     it should do so for all suffixes no shorter than the "int" argument
 
    * an opening function, specifying what to do when the module
      containing the object is opened (imported);
@@ -39,7 +35,7 @@ open Mod_subst
                   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
+     Anticipate - this is for objects that have to be explicitly
                   managed by the [end_module] function (like Require
                   and Read markers)
 
@@ -74,7 +70,7 @@ type 'a object_declaration = {
   discharge_function : object_name * '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 = ...
@@ -85,18 +81,22 @@ type 'a object_declaration = {
 
 val default_object : string -> 'a object_declaration
 
-(* the identity substitution function *)
+(** the identity substitution function *)
 val ident_subst_function : substitution * 'a -> 'a
 
-(*s Given an object declaration, the function [declare_object]
+(** {6 ... } *)
+(** Given an object declaration, the function [declare_object_full]
    will hand back two functions, the "injection" and "projection"
    functions for dynamically typed library-objects. *)
 
 type obj
 
-val declare_object :
+val declare_object_full :
   'a object_declaration -> ('a -> obj) * (obj -> 'a)
 
+val declare_object :
+  'a object_declaration -> ('a -> obj)
+
 val object_tag : obj -> string
 
 val cache_object : object_name * obj -> unit
diff --git a/library/library.ml b/library/library.ml
index 09f92e6a..37622874 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: library.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 
@@ -68,8 +66,6 @@ let add_load_path isroot (phys_path,coq_path) =
 	  load_paths := (phys_path,coq_path,isroot) :: !load_paths;
       | _ -> anomaly ("Two logical paths are associated to "^phys_path)
 
-let physical_paths (dp,lp) = dp
-
 let extend_path_with_dirpath p dir =
   List.fold_left Filename.concat p
     (List.map string_of_id (List.rev (repr_dirpath dir)))
@@ -119,7 +115,7 @@ type compilation_unit_name = dir_path
 
 type library_disk = {
   md_name : compilation_unit_name;
-  md_compiled : compiled_library;
+  md_compiled : LightenLibrary.lightened_compiled_library;
   md_objects : Declaremods.library_objects;
   md_deps : (compilation_unit_name * Digest.t) list;
   md_imports : compilation_unit_name list }
@@ -215,9 +211,6 @@ let library_is_loaded 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 () =
   List.map (fun m -> m.library_name) !libraries_loaded_list
 
@@ -307,7 +300,7 @@ let subst_import (_,o) = o
 let classify_import (_,export as obj) =
   if export then Substitute obj else Dispose
 
-let (in_import, out_import) =
+let in_import : dir_path * bool -> obj =
   declare_object {(default_object "IMPORT LIBRARY") with
        cache_function = cache_import;
        open_function = open_import;
@@ -389,24 +382,41 @@ let try_locate_qualified_library (loc,qid) =
 (************************************************************************)
 (* Internalise libraries *)
 
-let lighten_library m =
-  if !Flags.dont_load_proofs then lighten_library m else m
-
-let mk_library md digest = {
-  library_name = md.md_name;
-  library_compiled = lighten_library md.md_compiled;
-  library_objects = md.md_objects;
-  library_deps = md.md_deps;
-  library_imports = md.md_imports;
-  library_digest = digest }
+let mk_library md table digest =
+  let md_compiled =
+    LightenLibrary.load ~load_proof:!Flags.load_proofs table md.md_compiled
+  in {
+    library_name     = md.md_name;
+    library_compiled = md_compiled;
+    library_objects  = md.md_objects;
+    library_deps     = md.md_deps;
+    library_imports  = md.md_imports;
+    library_digest    = digest
+  }
+
+let fetch_opaque_table (f,pos,digest) =
+  try
+    let ch = System.with_magic_number_check raw_intern_library f in
+    seek_in ch pos;
+    if System.marshal_in ch <> digest then failwith "File changed!";
+    let table = (System.marshal_in ch : LightenLibrary.table) in
+    close_in ch;
+    table
+  with _ ->
+    error
+      ("The file "^f^" is inaccessible or has changed,\n" ^
+       "cannot load some opaque constant bodies in it.\n")
 
 let intern_from_file f =
   let ch = System.with_magic_number_check raw_intern_library f in
-  let md = System.marshal_in ch in
+  let lmd = System.marshal_in ch in
+  let pos = pos_in ch in
   let digest = System.marshal_in ch in
+  let table = lazy (fetch_opaque_table (f,pos,digest)) in
+  register_library_filename lmd.md_name f;
+  let library = mk_library lmd table digest in
   close_in ch;
-  register_library_filename md.md_name f;
-  mk_library md digest
+  library
 
 let rec intern_library needed (dir, f) =
   (* Look if in the current logical environment *)
@@ -453,9 +463,9 @@ 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
-	((string_of_dirpath m.library_name)^" is already loaded from file "^
-	library_full_filename m.library_name);
+      Flags.if_warn msg_warning
+	(pr_dirpath m.library_name ++ str " is already loaded from file " ++
+	str (library_full_filename m.library_name));
       m.library_name, []
     end
  else
@@ -488,7 +498,7 @@ let rec_intern_library_from_file idopt f =
 
 type library_reference = dir_path list * bool option
 
-let register_library (dir,m) =
+let register_library m =
   Declaremods.register_library
     m.library_name
     m.library_compiled
@@ -516,7 +526,9 @@ let discharge_require (_,o) = Some o
 
 (* open_function is never called from here because an Anticipate object *)
 
-let (in_require, out_require) =
+type require_obj = library_t list * dir_path list * bool option
+
+let in_require : require_obj -> obj =
   declare_object {(default_object "REQUIRE") with
        cache_function = cache_require;
        load_function = load_require;
@@ -531,9 +543,10 @@ let xml_require = ref (fun d -> ())
 let set_xml_require f = xml_require := f
 
 let require_library_from_dirpath modrefl export =
-  let needed = List.rev (List.fold_left rec_intern_library [] modrefl) in
+  let needed = List.fold_left rec_intern_library [] modrefl in
+  let needed = List.rev_map snd needed in
   let modrefl = List.map fst modrefl in
-    if Lib.is_modtype () || Lib.is_module () then
+    if Lib.is_module_or_modtype () then
       begin
 	add_anonymous_leaf (in_require (needed,modrefl,None));
 	Option.iter (fun exp ->
@@ -551,8 +564,8 @@ let require_library qidl 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
-  if Lib.is_modtype () || Lib.is_module () then begin
+  let needed = List.rev_map snd needed in
+  if Lib.is_module_or_modtype () then begin
     add_anonymous_leaf (in_require (needed,[modref],None));
     Option.iter (fun exp -> add_anonymous_leaf (in_import (modref,exp)))
       export
@@ -568,7 +581,7 @@ let import_module export (loc,qid) =
   try
     match Nametab.locate_module qid with
       | MPfile dir ->
-	  if Lib.is_modtype () || Lib.is_module () || not export then
+	  if Lib.is_module_or_modtype () || not export then
 	    add_anonymous_leaf (in_import (dir, export))
 	  else
 	    add_anonymous_leaf (in_import (dir, export))
@@ -620,6 +633,7 @@ let error_recursively_dependent_library dir =
    writing the content and computing the checksum... *)
 let save_library_to dir f =
   let cenv, seg = Declaremods.end_library dir in
+  let cenv, table = LightenLibrary.save cenv in
   let md = {
     md_name = dir;
     md_compiled = cenv;
@@ -632,8 +646,14 @@ let save_library_to dir f =
   try
     System.marshal_out ch md;
     flush ch;
+    (* The loading of the opaque definitions table is optional whereas
+       the digest is loaded all the time. As a consequence, the digest
+       must be serialized before the table (if we want to keep the
+       current simple layout of .vo files). This also entails that the
+       digest does not take opaque terms into account anymore. *)
     let di = Digest.file f' in
     System.marshal_out ch di;
+    System.marshal_out ch table;
     close_out ch
   with e -> warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise e
 
diff --git a/library/library.mli b/library/library.mli
index bc939666..ed17ed15 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: library.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Libnames
 open Libobject
-(*i*)
 
-(*s This module provides functions to load, open and save
+(** This module provides functions to load, open and save
   libraries. Libraries correspond to the subclass of modules that
   coincide with a file on disk (the ".vo" files). Libraries on the
   disk comes with checksums (obtained with the [Digest] module), which
@@ -23,43 +19,46 @@ open Libobject
   written at various dates.
 *)
 
-(*s Require = load in the environment + open (if the optional boolean
+(** {6 ... } *)
+(** 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
 
-(*s Open a module (or a library); if the boolean is true then it's also
+(** {6 ... } *)
+(** Open a module (or a library); if the boolean is true then it's also
    an export otherwise just a simple import *)
 val import_module : bool -> qualid located -> unit
 
-(*s Start the compilation of a library *)
+(** {6 Start the compilation of a library } *)
 val start_library : string -> dir_path * string
 
-(*s End the compilation of a library and save it to a ".vo" file *)
+(** {6 End the compilation of a library and save it to a ".vo" file } *)
 val save_library_to : dir_path -> string -> unit
 
-(*s Interrogate the status of libraries *)
+(** {6 Interrogate the status of libraries } *)
 
-  (* - Tell if a library is loaded or opened *)
+  (** - Tell if a library is loaded or opened *)
 val library_is_loaded : dir_path -> bool
 val library_is_opened : dir_path -> bool
 
-  (* - Tell which libraries are loaded or imported *)
+  (** - Tell which libraries are loaded or imported *)
 val loaded_libraries : unit -> dir_path list
 val opened_libraries : unit -> dir_path list
 
-  (* - Return the full filename of a loaded library. *)
+  (** - Return the full filename of a loaded library. *)
 val library_full_filename : dir_path -> string
 
-  (* - Overwrite the filename of all libraries (used when restoring a state) *)
+  (** - Overwrite the filename of all libraries (used when restoring a state) *)
 val overwrite_library_filenames : string -> unit
 
-(*s Hook for the xml exportation of libraries *)
+(** {6 Hook for the xml exportation of libraries } *)
 val set_xml_require : (dir_path -> unit) -> unit
 
-(*s Global load paths: a load path is a physical path in the file
+(** {6 ... } *)
+(** Global load paths: a load path is a physical path in the file
     system; to each load path is associated a Coq [dir_path] (the "logical"
     path of the physical path) *)
 
@@ -70,7 +69,7 @@ val remove_load_path : System.physical_path -> unit
 val find_logical_path : System.physical_path -> dir_path
 val is_in_load_paths : System.physical_path -> bool
 
-(*s Locate a library in the load paths *)
+(** {6 Locate a library in the load paths } *)
 exception LibUnmappedDir
 exception LibNotFound
 type library_location = LibLoaded | LibInPath
@@ -79,5 +78,5 @@ val locate_qualified_library :
   bool -> qualid -> library_location * dir_path * System.physical_path
 val try_locate_qualified_library : qualid located -> dir_path * string
 
-(*s Statistics: display the memory use of a library. *)
+(** {6 Statistics: display the memory use of a library. } *)
 val mem : dir_path -> Pp.std_ppcmds
diff --git a/library/nameops.ml b/library/nameops.ml
index 6a4bec5a..799b8ebe 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nameops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -112,8 +110,6 @@ let add_prefix s id = id_of_string (s ^ string_of_id id)
 
 let atompart_of_id id = fst (repr_ident id)
 
-let lift_ident = lift_subscript
-
 (* Names *)
 
 let out_name = function
diff --git a/library/nameops.mli b/library/nameops.mli
index e549d506..f3f9f752 100644
--- a/library/nameops.mli
+++ b/library/nameops.mli
@@ -1,24 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nameops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 
-(* Identifiers and names *)
+(** Identifiers and names *)
 val pr_id : identifier -> Pp.std_ppcmds
 val pr_name : name -> Pp.std_ppcmds
 
 val make_ident : string -> int option -> identifier
 val repr_ident : identifier -> string * int option
 
-val atompart_of_id : identifier -> string  (* remove trailing digits *)
-val root_of_id : identifier -> identifier (* remove trailing digits, $'$ and $\_$ *)
+val atompart_of_id : identifier -> string  (** remove trailing digits *)
+val root_of_id : identifier -> identifier (** remove trailing digits, ' and _ *)
 
 val add_suffix : identifier -> string -> identifier
 val add_prefix : string -> identifier -> identifier
@@ -38,17 +36,17 @@ val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a *
 
 val pr_lab : label -> Pp.std_ppcmds
 
-(* some preset paths *)
+(** some preset paths *)
 
 val default_library : dir_path
 
-(* This is the root of the standard library of Coq *)
+(** This is the root of the standard library of Coq *)
 val coq_root : module_ident
 
-(* This is the default root prefix for developments which doesn't
+(** This is the default root prefix for developments which doesn't
    mention a root *)
 val default_root_prefix : dir_path
 
-(* Metavariables *)
+(** Metavariables *)
 val pr_meta : Term.metavariable -> Pp.std_ppcmds
 val string_of_meta : Term.metavariable -> string
diff --git a/library/nametab.ml b/library/nametab.ml
index c4ea5953..6dbd927d 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -1,14 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nametab.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
+open Compat
 open Pp
 open Names
 open Libnames
@@ -20,10 +19,10 @@ exception GlobalizationError of qualid
 exception GlobalizationConstantError of qualid
 
 let error_global_not_found_loc loc q =
-  Stdpp.raise_with_loc loc (GlobalizationError q)
+  Loc.raise loc (GlobalizationError q)
 
 let error_global_constant_not_found_loc loc q =
-  Stdpp.raise_with_loc loc (GlobalizationConstantError q)
+  Loc.raise loc (GlobalizationConstantError q)
 
 let error_global_not_found q = raise (GlobalizationError q)
 
@@ -109,9 +108,9 @@ struct
 	      | 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 ^ "\"!");
+		  Flags.if_warn
+		    msg_warning (str ("Trying to mask the absolute name \""
+			     ^ U.to_string n ^ "\"!"));
 		  current
 	      | Nothing
 	      | Relative _ -> Relative (uname,o)
@@ -132,7 +131,7 @@ struct
 		   become unaccessible forever *)
 		(* But ours is also absolute! This is an error! *)
 		error ("Cannot mask the absolute name \""
-  		       ^ U.to_string uname' ^ "\"!")
+		       ^ U.to_string uname' ^ "\"!")
 	  | Nothing
 	  | Relative _ -> Absolute (uname,o), dirmap
 
@@ -149,9 +148,9 @@ let rec push_exactly uname o level (current,dirmap) = function
 	      | 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 ^ "\"!");
+		  Flags.if_warn
+		    msg_warning (str ("Trying to mask the absolute name \""
+			     ^ U.to_string n ^ "\"!"));
 		  current
 	      | Nothing
 	      | Relative _ -> Relative (uname,o)
@@ -288,10 +287,7 @@ 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
-			     end)
+module Globrevtab = Map.Make(ExtRefOrdered)
 
 type globrevtab = full_path Globrevtab.t
 let the_globrevtab = ref (Globrevtab.empty : globrevtab)
@@ -379,7 +375,6 @@ let locate_modtype qid = SpTab.locate qid !the_modtypetab
 let full_name_modtype qid = SpTab.user_name qid !the_modtypetab
 
 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
 
@@ -412,11 +407,6 @@ let locate_constant qid =
     | TrueGlobal (ConstRef kn) -> kn
     | _ -> raise Not_found
 
-let locate_mind qid =
-  match locate_extended qid with
-    | TrueGlobal (IndRef (kn,0)) -> kn
-    | _ -> raise Not_found
-
 let global_of_path sp =
   match SpTab.find sp !the_ccitab with
     | TrueGlobal ref -> ref
@@ -424,9 +414,6 @@ let global_of_path sp =
 
 let extended_global_of_path sp = SpTab.find sp !the_ccitab
 
-let locate_in_absolute_module dir id =
-  global_of_path (make_path dir id)
-
 let global r =
   let (loc,qid) = qualid_of_reference r in
   try match locate_extended qid with
@@ -450,8 +437,6 @@ let exists_module = exists_dir
 
 let exists_modtype sp = SpTab.exists sp !the_modtypetab
 
-let exists_tactic sp = SpTab.exists sp !the_tactictab
-
 (* Reverse locate functions ***********************************************)
 
 let path_of_global ref =
diff --git a/library/nametab.mli b/library/nametab.mli
index d0c24bfa..c5b55f2c 100644
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -1,86 +1,78 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nametab.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Pp
 open Names
 open Libnames
-(*i*)
 
-(*s This module contains the tables for globalization, which
-    associates internal object references to qualified names (qualid).
+(** This module contains the tables for globalization. *)
 
-    There are three classes of names:
+(** These globalization tables associate 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]
+    - 1a) internal kernel names: [kernel_name], [constant], [inductive],
+         [module_path], [dir_path]
 
-    1b- other internal names: [global_reference], [syndef_name],
+    - 1b) other internal names: [global_reference], [syndef_name],
         [extended_global_reference], [global_dir_reference], ...
 
-    2- full, non ambiguous user names: [full_path]
+    - 2) full, non ambiguous user names: [full_path]
 
-    3- non necessarily full, possibly ambiguous user names: [reference]
-       and [qualid]
+    - 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 [full_path] or a [dir_path].
-
-   \item [exists : full_user_name -> bool]
+(** Most functions in this module fall into one of the following categories:
+{ul {- [push : visibility -> full_user_name -> object_reference -> unit]
 
-   Is the [full_user_name] already atributed as an absolute user name
-   of some object?
+     Registers the [object_reference] to be referred to by the
+     [full_user_name] (and its suffixes according to [visibility]).
+     [full_user_name] can either be a [full_path] or a [dir_path].
+   }
+   {- [exists : full_user_name -> bool]
 
-   \item [locate : qualid -> object_reference]
+     Is the [full_user_name] already atributed as an absolute user name
+     of some object?
+   }
+   {- [locate : qualid -> object_reference]
 
-   Finds the object referred to by [qualid] or raises [Not_found]
+     Finds the object referred to by [qualid] or raises [Not_found]
+   }
+   {- [full_name : qualid -> full_user_name]
 
-   \item [full_name : qualid -> full_user_name]
+     Finds the full user name referred to by [qualid] or raises [Not_found]
+   }
+   {- [shortest_qualid_of : object_reference -> user_name]
 
-   Finds the full user name referred to by [qualid] or raises [Not_found]
+     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 [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
 
-(* Raises a globalization error *)
+(** Raises a globalization error *)
 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
-   \begin{itemize}
+(** {6 Register visibility of things } *)
 
-   \item for all suffixes not shorter then a given int -- when the
+(** The visibility can be registered either
+   - for all suffixes not shorter then a given int -- when the
    object is loaded inside a module -- or
-
-   \item for a precise suffix, when the module containing (the module
+   - for a precise suffix, when the module containing (the module
    containing ...) the object is opened (imported)
-   \end{itemize}
+   
 *)
 
 type visibility = Until of int | Exactly of int
@@ -94,9 +86,9 @@ type ltac_constant = kernel_name
 val push_tactic : visibility -> full_path -> ltac_constant -> unit
 
 
-(*s The following functions perform globalization of qualified names *)
+(** {6 The following functions perform globalization of qualified names } *)
 
-(* These functions globalize a (partially) qualified name or fail with
+(** These functions globalize a (partially) qualified name or fail with
    [Not_found] *)
 
 val locate : qualid -> global_reference
@@ -109,42 +101,43 @@ val locate_module : qualid -> module_path
 val locate_section : qualid -> dir_path
 val locate_tactic : qualid -> ltac_constant
 
-(* These functions globalize user-level references into global
+(** 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
 
-(* These functions locate all global references with a given suffix;
+(** These functions locate all global references with a given suffix;
    if [qualid] is valid as such, it comes first in the list *)
 
 val locate_all : qualid -> global_reference list
 val locate_extended_all : qualid -> extended_global_reference list
 
-(* Mapping a full path to a global reference *)
+(** 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 tell if the given absolute name is already taken *)
+(** {6 These functions tell if the given absolute name is already taken } *)
 
 val exists_cci : full_path -> bool
 val exists_modtype : full_path -> bool
 val exists_dir : dir_path -> bool
-val exists_section : dir_path -> bool (* deprecated synonym of [exists_dir] *)
-val exists_module : dir_path -> bool (* deprecated synonym of [exists_dir] *)
+val exists_section : dir_path -> bool (** deprecated synonym of [exists_dir] *)
+val exists_module : dir_path -> bool (** deprecated synonym of [exists_dir] *)
 
-(*s These functions locate qualids into full user names *)
+(** {6 These functions locate qualids into full user names } *)
 
 val full_name_cci : qualid -> full_path
 val full_name_modtype : qualid -> full_path
 val full_name_module : qualid -> dir_path
 
-(*s Reverse lookup -- finding user names corresponding to the given
+(** {6 Reverse lookup }
+  Finding user names corresponding to the given
   internal name *)
 
-(* Returns the full path bound to a global reference or syntactic
+(** 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
@@ -152,17 +145,17 @@ val path_of_global : global_reference -> full_path
 val dirpath_of_module : module_path -> dir_path
 val path_of_tactic : ltac_constant -> full_path
 
-(* Returns in particular the dirpath or the basename of the full path
+(** Returns in particular the dirpath or the basename of the full path
    associated to global reference *)
 
 val dirpath_of_global : global_reference -> dir_path
 val basename_of_global : global_reference -> identifier
 
-(* Printing of global references using names as short as possible *)
+(** Printing of global references using names as short as possible *)
 val pr_global_env : Idset.t -> global_reference -> std_ppcmds
 
 
-(* The [shortest_qualid] functions given an object with [user_name]
+(** The [shortest_qualid] functions given an object with [user_name]
    Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and
    Coq.A.B.x that denotes the same object. *)
 
@@ -172,7 +165,7 @@ 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 *)
+(** Deprecated synonyms *)
 
 val extended_locate : qualid -> extended_global_reference (*= locate_extended *)
-val absolute_reference : full_path -> global_reference (* = global_of_path *)
+val absolute_reference : full_path -> global_reference (** = global_of_path *)
diff --git a/library/states.ml b/library/states.ml
index 679f9028..c88858f7 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: states.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open System
 
 type state = Lib.frozen * Summary.frozen
@@ -22,7 +20,10 @@ let unfreeze (fl,fs) =
 let (extern_state,intern_state) =
   let (raw_extern, raw_intern) =
     extern_intern Coq_config.state_magic_number ".coq" in
-  (fun s -> raw_extern s (freeze())),
+  (fun s ->
+    if !Flags.load_proofs <> Flags.Force then
+      Util.error "Write State only works with option -force-load-proofs";
+    raw_extern s (freeze())),
   (fun s ->
     unfreeze
       (with_magic_number_check (raw_intern (Library.get_load_paths ())) s);
diff --git a/library/states.mli b/library/states.mli
index fc6497b6..4f114d57 100644
--- a/library/states.mli
+++ b/library/states.mli
@@ -1,14 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: states.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** {6 States of the system} *)
 
-(*s States of the system. In that module, we provide functions to get
+(** 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
   to write and restore state to and from a given file. *)
@@ -20,13 +20,14 @@ type state
 val freeze : unit -> state
 val unfreeze : state -> unit
 
-(*s Rollback. [with_heavy_rollback f x] applies [f] to [x] and restores the
+(** {6 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
   is raised. *)
-
 val with_heavy_rollback : ('a -> 'b) -> (exn -> exn) -> 'a -> 'b
 
-(*s [with_state_protection f x] applies [f] to [x] and restores the
+(** [with_state_protection f x] applies [f] to [x] and restores the
   state of the whole system as it was before the evaluation of f *)
 
 val with_state_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/library/summary.ml b/library/summary.ml
index a40a9354..697f57e8 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: summary.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 
diff --git a/library/summary.mli b/library/summary.mli
index 5db9617b..5963b23b 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: summary.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* This module registers the declaration of global tables, which will be kept
+(** This module registers the declaration of global tables, which will be kept
    in synchronization during the various backtracks of the system. *)
 
 type 'a summary_declaration = {
diff --git a/man/coqchk.1 b/man/coqchk.1
index f51861f0..76a7cfc5 100644
--- a/man/coqchk.1
+++ b/man/coqchk.1
@@ -1,7 +1,7 @@
-.TH COQ 1 "February 9, 2009"
+.TH COQ 1 "July 7, 201"
 
 .SH NAME
-coqchk \- The Coq Proof Assistant compiled libraries verifier
+coqchk \- The Coq Proof Checker compiled libraries verifier
 
 
 .SH SYNOPSIS
@@ -9,7 +9,7 @@ coqchk \- The Coq Proof Assistant compiled libraries verifier
 [
 .B options
 ]
-.I files-or-modules
+.I modules
 
 
 .SH DESCRIPTION
@@ -21,10 +21,9 @@ information. It returns with exit code 0 if all the requested tasks
 succeeded. A non-zero return code means that something went wrong: some
 library was not found, corrupted content, type-checking failure, etc.
 
-.IR files-or-modules \&
-is a list of modules to be checked. Modules can be referred to either
-by a filename (without the .vo suffix) or by their (possibly
-qualified) module name.
+.IR modules \&
+is a list of modules to be checked. Modules can be referred to by a
+short or qualified name.
 
 .SH OPTIONS
 
@@ -42,44 +41,44 @@ to logical
 .I coqdir
 
 .TP
-.BI \-where
-print Coq's standard library location and exit
-
-.TP
 .BI \-silent
 makes coqchk less verbose.
 
 .TP
-.BI \-admit \ file-or-module
+.BI \-admit \ module
 tag the specified module and all its dependencies as trusted, and will
 not be rechecked, unless explicitly requested by other options.
 
 .TP
-.BI \-norec \ file-or-module
+.BI \-norec \ module
 specifies that the given module shall be verified without requesting
-to check its dependencies
+to check its dependencies.
 
 .TP
 .BI \-m,\ \-\-memory
-displays a summary of the memory used by the checker
+displays a summary of the memory used by the checker.
 
 .TP
 .BI \-o,\ \-\-output\-context
 displays a summary of the logical content that have been
-verified: assumptions and usage of impredicativity
+verified: assumptions and usage of impredicativity.
 
 .TP
 .BI \-impredicative\-set
-allows the checker to verify libraries that have been compiled with
+allows the checker to accept libraries that have been compiled with
 this flag.
 
 .TP
 .BI \-v
-print Coq version and exit
+print coqchk version and exit.
+
+.TP
+.BI \-coqlib \ dir
+overrides the default location of the standard library.
 
 .TP
 .BI \-where
-print Coq's standard library location and exit
+print coqchk standard library location and exit.
 
 .TP
 .BI \-h,\ \-\-help
diff --git a/man/coqide.1 b/man/coqide.1
index 20379ef4..9862ebb2 100644
--- a/man/coqide.1
+++ b/man/coqide.1
@@ -12,11 +12,11 @@ coqide \- The Coq Proof Assistant graphical interface
 
 .SH DESCRIPTION
 
-.B coqtop
+.B coqide
 is a gtk graphical interface for the Coq proof assistant.
 
 For command-line-oriented use of Coq, see
-.BR coqide (1)
+.BR coqtop (1)
 ; for batch-oriented use of Coq, see 
 .BR coqc (1).
 
@@ -112,10 +112,6 @@ Skip loading of rcfile.
 Set the rcfile to
 .IR f .
 .TP
-.BI \-user\  u
-Use the rcfile of user
-.IR u .
-.TP
 .B \-batch
 Batch mode (exits just after arguments parsing).
 .TP
diff --git a/man/coqmktop.1 b/man/coqmktop.1
index 1b9c9e2a..810df782 100644
--- a/man/coqmktop.1
+++ b/man/coqmktop.1
@@ -50,14 +50,6 @@ Build Coq on a ocaml toplevel (incompatible with
 .BR \-opt )
 
 .TP
-.B \-searchisos
-Build a toplevel for SearchIsos
-
-.TP
-.B \-ide
-Build a toplevel for the Coq IDE
-
-.TP
 .BI \-R \ dir
 Specify recursively directories for Ocaml
 
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 1994efac..bd4d1c34 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -74,8 +74,14 @@ let _ = if w32 then begin
   Options.ocamlmklib := A w32ocamlmklib;
 end
 
+let use_camlp5 = (Coq_config.camlp4 = "camlp5")
+
+let camlp4args =
+  if use_camlp5 then [A "pa_extend.cmo";A "q_MLast.cmo";A "pa_macro.cmo"]
+  else []
+
 let ocaml = A Coq_config.ocaml
-let camlp4o = A Coq_config.camlp4o
+let camlp4o = S ((A Coq_config.camlp4o) :: camlp4args)
 let camlp4incl = S[A"-I"; A Coq_config.camlp4lib]
 let camlp4compat = Sh Coq_config.camlp4compat
 let opt = (Coq_config.best = "opt")
@@ -86,7 +92,6 @@ 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 ? *)
@@ -107,10 +112,6 @@ 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 =
@@ -125,10 +126,6 @@ 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"
@@ -171,7 +168,7 @@ type links = Both | Best | BestInPlace | Ide
 let all_binaries =
  (if w32 then [ "mkwinapp", "tools/mkwinapp", Best ] else []) @
  [ "coqtop", coqtop, Both;
-   "coqide", coqide, Ide;
+   "coqide", "ide/coqide_main", Ide;
    "coqmktop", coqmktop, Both;
    "coqc", "scripts/coqc", Both;
    "coqchk", "checker/main", Both;
@@ -183,6 +180,7 @@ let all_binaries =
    "coq-tex", "tools/coq_tex", Best;
    "gallina", "tools/gallina", Best;
    "csdpcert", "plugins/micromega/csdpcert", BestInPlace;
+   "fake_ide", "tools/fake_ide", Best;
  ]
 
 
@@ -191,22 +189,28 @@ 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)
+(* For inner needs, we rather use the bytecode versions of coqdep
+   and coqmktop: slightly slower but compile quickly, and ok with
+   w32 cross-compilation *)
+let coqdep_boot = coqdepboot^".byte"
+let coqmktop_boot = coqmktop^".byte"
 
-let binaries_deps =
+let binariesopt_deps =
+  let addext b = b ^ ".native" in
   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
+    | (_,b,Ide)::l -> if ide="opt" then addext b :: deps l else deps l
+    | (_,b,_)::l -> if opt then addext b :: deps l else deps l
   in deps all_binaries
 
-let binariesopt_deps =
-  List.filter (fun s -> Filename.check_suffix s ".native") binaries_deps
+let binariesbyte_deps =
+  let addext b = b ^ ".byte" in
+  let rec deps = function
+    | [] -> []
+    | (_,b,Ide)::l -> if ide<>"no" then addext b :: deps l else deps l
+    | (_,b,Both)::l -> addext b :: deps l
+    | (_,b,_)::l -> if not opt then addext b :: deps l else deps l
+  in deps all_binaries
 
 let ln_sf toward f =
   Command.execute ~quiet:true (Cmd (S [A"ln";A"-sf";P toward;P f]))
@@ -245,8 +249,9 @@ 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);
+  rule "binariesbyte" ~stamp:"binariesbyte" ~deps:binariesbyte_deps (fun _ _ -> Nop);
+  rule "binaries" ~stamp:"binaries" ~deps:["binariesbyte";"binariesopt"] (fun _ _ -> Nop);
 
 (** We create a special coq_config which mentions _build *)
 
@@ -255,17 +260,13 @@ let extra_rules () = begin
        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:
+       (* TODO : line2 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"
+       let line1 =
+	 "let coqrunbyteflags = \"-dllib -lcoqrun\"\n"
        in
-       Echo (lines @ [line0;line1] @ (if local then [line2;line3] else []),
+       Echo (lines @ (if local then [line0;line1] else []),
 	     "coq_config.ml"));
 
 (** Camlp4 extensions *)
@@ -277,13 +278,31 @@ let extra_rules () = begin
 	      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 ["p4mod"; "use_grammar"] (P "parsing/grammar.cma");
+  flag_and_dep ["p4mod"; "use_constr"] (P "parsing/q_constr.cmo");
+
+  flag_and_dep ["p4mod"; "use_compat5"] (P "tools/compat5.cmo");
+  flag_and_dep ["p4mod"; "use_compat5b"] (P "tools/compat5b.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);
+  if w32 then begin
+    flag ["p4mod"] (A "-DWIN32");
+    dep ["ocaml"; "link"; "ide"] ["ide/ide_win32_stubs.o"];
+  end;
+
+  if not use_camlp5 then begin
+  let mlp_cmo s =
+    let src=s^".mlp" and dst=s^".cmo" in
+    rule (src^".cmo") ~dep:src ~prod:dst ~insert:`top
+      (fun env _ ->
+	 Cmd (S [!Options.ocamlc; A"-c"; A"-pp";
+		 Quote (S [camlp4o;A"-impl"]); camlp4incl; A"-impl"; P src]))
+  in
+  mlp_cmo "tools/compat5";
+  mlp_cmo "tools/compat5b";
+  end;
+
+  ocaml_lib ~extern:true ~dir:Coq_config.camlp4lib ~tag_name:"use_camlpX"
+    ~byte:true ~native:true (if use_camlp5 then "gramlib" else "camlp4lib");
 
 (** Special case of toplevel/mltop.ml4:
     - mltop.ml will be the old mltop.optml and be used to obtain mltop.cmx
@@ -310,18 +329,18 @@ let extra_rules () = begin
 
   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";
+  flag ["ocaml"; "ide"; "compile"] lablgtkincl;
+  flag ["ocaml"; "ide"; "link"] lablgtkincl;
+  flag ["ocaml"; "ide"; "link"; "byte"] (S [A"lablgtk.cma"; A"gtkThread.cmo"]);
+  flag ["ocaml"; "ide"; "link"; "native"] (S [A"lablgtk.cmxa"; A"gtkThread.cmx"]);
 
 (** C code for the VM *)
 
   dep ["compile"; "c"] c_headers;
   flag ["compile"; "c"] cflags;
-  dep ["link"; "ocaml"; "use_libcoqrun"] [libcoqrun];
+  dep ["ocaml"; "use_libcoqrun"; "compile"] [libcoqrun];
+  dep ["ocaml"; "use_libcoqrun"; "link"; "native"] [libcoqrun];
+  flag ["ocaml"; "use_libcoqrun"; "link"; "byte"] (Sh Coq_config.coqrunbyteflags);
 
   (* we need to use a different ocamlc. For now we copy the rule *)
   if w32 then
@@ -356,16 +375,14 @@ let extra_rules () = begin
 
 (** Generation of tolink.ml *)
 
-  rule tolink ~deps:(ide_mllib::core_mllib) ~prod:tolink
+  rule tolink ~deps:core_mllib ~prod:tolink
     (fun _ _ ->
        let cat s = String.concat " " (string_list_of_file s) in
        let core_mods = String.concat " " (List.map cat core_mllib) in
-       let 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"],
+	      "let core_objs = \"Coq_config "^core_mods^"\"\n"],
 	     tolink));
 
 (** For windows, building coff object file from a .rc (for the icon) *)
@@ -376,55 +393,57 @@ let extra_rules () = begin
        Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc;
 	       A "--output-format";A "coff";A "--output"; Px o]));
 
-(** Coqtop and coqide *)
+(** The windows version of Coqide is now a console-free win32 app,
+    which moreover contains the Coq icon. If necessary, the mkwinapp
+    tool can be used later to restore or suppress the console of Coqide. *)
 
-  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 depsall = if w32 then w32ico::depsall else depsall in
+  if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico];
+
+  if w32 then flag ["link"; "ocaml"; "program"; "ide"]
+    (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]);
+
+(** Coqtop *)
+
+  let () =
+    let fo = coqtop^".native" and fb = coqtop^".byte" in
+    let depsall = (if w32 then [w32ico] else [])@[coqmktop_boot;libcoqrun] in
     let depso = "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 =
-      (* Uncomment the following line to make coqide a console-free win32 app.
-         For the moment we don't, some issue remain to be investigated.
-         In the meantime, coqide can be made console-free a posteriori via
-         the mkwinapp tool. *)
-      (*if is_ide then [A"-ccopt";A"\"-link -Wl,-subsystem,windows\""] else*) [] in
     let w32flag =
-      if not w32 then N
-      else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico]@w32ideflag)
+      if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico])
     in
-    if opt then rule fo ~prod:fo ~deps:(depsall@depso@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]);
+    if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top
+      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;A"-o";Px fo]);
+    rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top
+      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;A"-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"]
+  rule ".v.d" ~prod:"%.v.depends" ~deps:["%.v";coqdep_boot;"coqdepready"]
     (fun env _ ->
        let v = env "%.v" and vd = env "%.v.depends" in
        (** NB: this relies on all .v files being already in _build. *)
-       Cmd (S [P coqdepbest;dep_dynlink;A"-slash";P v;Sh">";Px vd]));
+       Cmd (S [P coqdep_boot;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")
+	for one .v file, with some specific shape "f.vo ...: f.v deps.vo ..." *)
+    let src = f^".v" in
+    let depends = f^".v.depends" in
+    let rec get_deps keep = function
+      | [] -> []
+      | d::deps when d = src -> get_deps keep deps
+      | d::deps when keep -> [d] :: get_deps keep deps
+      | d::deps -> get_deps (String.contains d ':') deps
+    in
+    let d = get_deps false (string_list_of_file depends) in
+    List.iter Outcome.ignore_good (build d)
+
   in
 
   let coq_v_rule d init =
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
index 848223a0..3266fcf9 100644
--- a/parsing/argextend.ml4
+++ b/parsing/argextend.ml4
@@ -1,21 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-
-(* $Id: argextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
+(*i camlp4deps: "tools/compat5b.cmo" i*)
 
 open Genarg
 open Q_util
-open Q_coqast
 open Egrammar
+open Pcoq
+open Compat
 
-let join_loc = Util.join_loc
 let loc = Util.dummy_loc
 let default_loc = <:expr< Util.dummy_loc >>
 
@@ -42,7 +40,12 @@ let rec make_rawwit loc = function
   | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >>
   | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >>
-  | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >>
+  | ExtraArgType s ->
+    <:expr<
+      let module WIT = struct
+        open Extrawit;
+        value wit = $lid:"rawwit_"^s$;
+      end in WIT.wit >>
 
 let rec make_globwit loc = function
   | BoolArgType -> <:expr< Genarg.globwit_bool >>
@@ -67,7 +70,12 @@ let rec make_globwit loc = function
   | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >>
   | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >>
-  | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >>
+  | ExtraArgType s ->
+    <:expr<
+      let module WIT = struct
+        open Extrawit;
+        value wit = $lid:"globwit_"^s$;
+      end in WIT.wit >>
 
 let rec make_wit loc = function
   | BoolArgType -> <:expr< Genarg.wit_bool >>
@@ -92,48 +100,51 @@ let rec make_wit loc = function
   | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
   | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
-  | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >>
+  | ExtraArgType s ->
+    <:expr<
+      let module WIT = struct
+        open Extrawit;
+        value wit = $lid:"wit_"^s$;
+      end in WIT.wit >>
 
 let make_act loc act pil =
   let rec make = function
-    | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >>
+    | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >>
     | GramNonTerminal (_,t,_,Some p) :: tl ->
 	let p = Names.string_of_id p in
 	<:expr<
-          Gramext.action
+          Pcoq.Gram.action
             (fun $lid:p$ ->
                let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
         >>
     | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl ->
-	<:expr< Gramext.action (fun _ -> $make tl$) >> in
+	<:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in
   make (List.rev pil)
 
 let make_prod_item = function
-  | GramTerminal s -> <:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>
+  | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >>
   | GramNonTerminal (_,_,g,_) ->
       <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >>
 
 let make_rule loc (prods,act) =
   <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >>
 
-let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
-  let rawtyp, rawpr = match rawtyppr with
-    | None -> typ,pr
-    | Some (t,p) -> t,p in
-  let globtyp, globpr = match globtyppr with
-    | None -> typ,pr
-    | Some (t,p) -> t,p in
+let declare_tactic_argument loc s (typ, pr, f, g, h) cl =
+  let rawtyp, rawpr, globtyp, globpr = match typ with
+    | `Uniform typ -> typ, pr, typ, pr
+    | `Specialized (a, b, c, d) -> a, b, c, d
+  in
   let glob = match g with
     | None ->
 	<:expr< fun e x ->
-          out_gen $make_globwit loc typ$
+          out_gen $make_globwit loc rawtyp$
             (Tacinterp.intern_genarg e
                (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >>
     | Some f -> <:expr< $lid:f$>> in
   let interp = match f with
     | None ->
 	<:expr< fun ist gl x ->
-          out_gen $make_wit loc typ$
+          out_gen $make_wit loc globtyp$
             (Tacinterp.interp_genarg ist gl
                (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
     | Some f -> <:expr< $lid:f$>> in
@@ -149,13 +160,13 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
   let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
   let globwit = <:expr< $lid:"globwit_"^s$ >> in
   let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
-  <:str_item<
-    declare
-      open Pcoq;
-      open Extrawit;
+  declare_str_items loc
+   [ <:str_item<
       value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
-        Genarg.create_arg $se$;
-      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
+      Genarg.create_arg $se$ >>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+     <:str_item< do {
       Tacinterp.add_interp_genarg $se$
         ((fun e x ->
           (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))),
@@ -163,14 +174,13 @@ 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
-        [(None, None, $rules$)];
+      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
+	(None, [(None, None, $rules$)]);
       Pptactic.declare_extra_genarg_pprule
         ($rawwit$, $lid:rawpr$)
         ($globwit$, $lid:globpr$)
-        ($wit$, $lid:pr$);
-    end
-  >>
+        ($wit$, $lid:pr$) }
+     >> ]
 
 let declare_vernac_argument loc s pr cl =
   let se = mlexpr_of_string s in
@@ -181,56 +191,58 @@ let declare_vernac_argument loc s pr cl =
   let pr_rules = match pr with
     | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >>
     | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in
-  <:str_item<
-    declare
-      open Pcoq;
-      open Extrawit;
+  declare_str_items loc
+   [ <:str_item<
       value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel),
              ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel),
-              $lid:"rawwit_"^s$) = Genarg.create_arg $se$;
-      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
-      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None
-        [(None, None, $rules$)];
+              $lid:"rawwit_"^s$) = Genarg.create_arg $se$ >>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+    <:str_item< do {
+      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
+	(None, [(None, None, $rules$)]);
       Pptactic.declare_extra_genarg_pprule
         ($rawwit$, $pr_rules$)
         ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer")
-        ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer");
-    end
-  >>
+        ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer") }
+      >> ]
 
 open Vernacexpr
 open Pcoq
 open Pcaml
+open PcamlSig
 
 EXTEND
   GLOBAL: str_item;
   str_item:
-    [ [ "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
-        "TYPED"; "AS"; typ = argtype;
-        "PRINTED"; "BY"; pr = LIDENT;
-        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
-        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
-        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
-        rawtyppr =
-        (* Necessary if the globalized type is different from the final type *)
-          OPT [ "RAW_TYPED"; "AS"; t = argtype;
-                "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
-        globtyppr =
-          OPT [ "GLOB_TYPED"; "AS"; t = argtype;
-                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
+    [ [ "ARGUMENT"; "EXTEND"; s = entry_name;
+        header = argextend_header;
         OPT "|"; l = LIST1 argrule SEP "|";
         "END" ->
-	  if String.capitalize s = s then
-	    failwith "Argument entry names must be lowercase";
-         declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l
-      | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
+         declare_tactic_argument loc s header l
+      | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name;
         pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr];
         OPT "|"; l = LIST1 argrule SEP "|";
         "END" ->
-	  if String.capitalize s = s then
-	    failwith "Argument entry names must be lowercase";
          declare_vernac_argument loc s pr l ] ]
   ;
+  argextend_header:
+    [ [ "TYPED"; "AS"; typ = argtype;
+        "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] ->
+        (`Uniform typ, pr, f, g, h)
+      | "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
+        "RAW_TYPED"; "AS"; rawtyp = argtype;
+        "RAW_PRINTED"; "BY"; rawpr = LIDENT;
+        "GLOB_TYPED"; "AS"; globtyp = argtype;
+        "GLOB_PRINTED"; "BY"; globpr = LIDENT ->
+        (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ]
+  ;
   argtype:
     [ "2"
       [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
@@ -253,9 +265,14 @@ EXTEND
 	GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
       | s = STRING ->
 	  if String.length s > 0 && Util.is_letter s.[0] then
-	    Lexer.add_token ("", s);
+	    Lexer.add_keyword s;
           GramTerminal s
     ] ]
   ;
+  entry_name:
+    [ [ s = LIDENT -> s
+      | UIDENT -> failwith "Argument entry names must be lowercase"
+      ] ]
+  ;
   END
 
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
index ba965a54..4418a45f 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egrammar.ml
@@ -1,14 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: egrammar.ml 14779 2011-12-07 21:54:18Z herbelin $ *)
-
 open Pp
+open Compat
 open Util
 open Pcoq
 open Extend
@@ -57,45 +56,43 @@ let cases_pattern_expr_of_name (loc,na) = match na with
   | Name id -> CPatAtom (loc,Some (Ident (loc,id)))
 
 type grammar_constr_prod_item =
-  | GramConstrTerminal of Token.pattern
+  | GramConstrTerminal of Tok.t
   | GramConstrNonTerminal of constr_prod_entry_key * identifier option
   | GramConstrListMark of int * bool
     (* tells action rule to make a list of the n previous parsed items; 
        concat with last parsed list if true *)
 
-type 'a action_env = 'a list * 'a list list
-
 let make_constr_action
   (f : loc -> constr_notation_substitution -> constr_expr) pil =
   let rec make (constrs,constrlists,binders as fullsubst) = function
   | [] ->
-      Gramext.action (fun loc -> f loc fullsubst)
+      Gram.action (fun loc -> f loc fullsubst)
   | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
       (* parse a non-binding item *)
-      Gramext.action (fun _ -> make fullsubst tl)
+      Gram.action (fun _ -> make fullsubst tl)
   | GramConstrNonTerminal (typ, Some _) :: tl ->
       (* parse a binding non-terminal *)
-     (match typ with
-     | (ETConstr _| ETOther _) ->
-	Gramext.action (fun (v:constr_expr) ->
+    (match typ with
+    | (ETConstr _| ETOther _) ->
+	Gram.action (fun (v:constr_expr) ->
 	  make (v :: constrs, constrlists, binders) tl)
-     | ETReference ->
-        Gramext.action (fun (v:reference) ->
+    | ETReference ->
+        Gram.action (fun (v:reference) ->
 	  make (CRef v :: constrs, constrlists, binders) tl)
-     | ETName ->
-         Gramext.action (fun (na:name located) ->
+    | ETName ->
+        Gram.action (fun (na:name located) ->
 	  make (constr_expr_of_name na :: constrs, constrlists, binders) tl)
-     | ETBigint ->
-         Gramext.action (fun (v:Bigint.bigint) ->
+    | ETBigint ->
+        Gram.action (fun (v:Bigint.bigint) ->
 	  make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl)
-     | ETConstrList (_,n) ->
-	Gramext.action (fun (v:constr_expr list) ->
+    | ETConstrList (_,n) ->
+	Gram.action (fun (v:constr_expr list) ->
 	  make (constrs, v::constrlists, binders) tl)
     | ETBinder _ | ETBinderList (true,_) ->
-	Gramext.action (fun (v:local_binder list) ->
+	Gram.action (fun (v:local_binder list) ->
 	  make (constrs, constrlists, v::binders) tl)
     | ETBinderList (false,_) ->
-	Gramext.action (fun (v:local_binder list list) ->
+	Gram.action (fun (v:local_binder list list) ->
 	  make (constrs, constrlists, List.flatten v::binders) tl)
     | ETPattern ->
 	failwith "Unexpected entry of type cases pattern")
@@ -113,26 +110,26 @@ let make_cases_pattern_action
   (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
   let rec make (env,envlist as fullenv) = function
   | [] ->
-      Gramext.action (fun loc -> f loc fullenv)
+      Gram.action (fun loc -> f loc fullenv)
   | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
       (* parse a non-binding item *)
-      Gramext.action (fun _ -> make fullenv tl)
+      Gram.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)
+        Gram.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl)
     | ETReference ->
-        Gramext.action (fun (v:reference) ->
+        Gram.action (fun (v:reference) ->
 	  make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl)
     | ETName ->
-        Gramext.action (fun (na:name located) ->
+        Gram.action (fun (na:name located) ->
 	  make (cases_pattern_expr_of_name na :: env, envlist) tl)
     | ETBigint ->
-        Gramext.action (fun (v:Bigint.bigint) ->
+        Gram.action (fun (v:Bigint.bigint) ->
 	  make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl)
     | ETConstrList (_,_) ->
-        Gramext.action  (fun (vl:cases_pattern_expr list) ->
+        Gram.action  (fun (vl:cases_pattern_expr list) ->
 	  make (env, vl :: envlist) tl)
     | (ETPattern | ETBinderList _ | ETBinder _ | ETOther _) ->
 	failwith "Unexpected entry of type cases pattern or other")
@@ -146,7 +143,7 @@ let make_cases_pattern_action
 
 let rec make_constr_prod_item assoc from forpat = function
   | GramConstrTerminal tok :: l ->
-      Gramext.Stoken tok :: make_constr_prod_item assoc from forpat l
+      gram_token_of_token tok :: make_constr_prod_item assoc from forpat l
   | GramConstrNonTerminal (nt, ovar) :: l ->
       symbol_of_constr_prod_entry_key assoc from forpat nt
       :: make_constr_prod_item assoc from forpat l
@@ -156,17 +153,18 @@ let rec make_constr_prod_item assoc from forpat = function
       []
 
 let prepare_empty_levels forpat (pos,p4assoc,name,reinit) =
-  let entry = 
+  let entry =
     if forpat then weaken_entry Constr.pattern
     else weaken_entry Constr.operconstr in
-  grammar_extend entry pos reinit [(name, p4assoc, [])]
+  grammar_extend entry reinit (pos,[(name, p4assoc, [])])
 
 let pure_sublevels level symbs =
-  map_succeed (function
-  | Gramext.Snterml (_,n) when Some (int_of_string n) <> level ->
-      int_of_string n
-  | _ ->
-      failwith "") symbs
+  map_succeed
+    (function s ->
+       let i = level_of_snterml s in
+       if level = Some i then failwith "";
+       i)
+    symbs
 
 let extend_constr (entry,level) (n,assoc) mkact forpat rules =
   List.fold_left (fun nb pt ->
@@ -176,7 +174,7 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules =
   let pos,p4assoc,name,reinit = find_position forpat assoc level in
   let nb_decls = List.length needed_levels + 1 in
   List.iter (prepare_empty_levels forpat) needed_levels;
-  grammar_extend entry pos reinit [(name, p4assoc, [symbs, mkact pt])];
+  grammar_extend entry reinit (pos,[(name, p4assoc, [symbs, mkact pt])]);
   nb_decls) 0 rules
 
 let extend_constr_notation (n,assoc,ntn,rules) =
@@ -187,8 +185,8 @@ let extend_constr_notation (n,assoc,ntn,rules) =
   (* Add the notation in cases_pattern *)
   let mkact loc env = CPatNotation (loc,ntn,env) in
   let e = interp_constr_entry_key true (ETConstr (n,())) in
-  let nb' =
-    extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact) true rules in
+  let nb' = extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact)
+    true rules in
   nb+nb'
 
 (**********************************************************************)
@@ -198,11 +196,11 @@ 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)
+	Gram.action (fun loc -> f loc env)
     | None :: tl -> (* parse a non-binding item *)
-        Gramext.action (fun _ -> make env tl)
+        Gram.action (fun _ -> make env tl)
     | Some (p, t) :: tl -> (* non-terminal *)
-        Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in
+        Gram.action (fun v -> make ((p,in_generic t v) :: env) tl) in
   make [] (List.rev pil)
 
 let make_rule univ f g pt =
@@ -216,10 +214,10 @@ let make_rule univ f g pt =
 type grammar_prod_item =
   | GramTerminal of string
   | GramNonTerminal of
-      loc * argument_type * Gram.te prod_entry_key * identifier option
+      loc * argument_type * prod_entry_key * identifier option
 
 let make_prod_item = function
-  | GramTerminal s -> (Gramext.Stoken (Lexer.terminal s), None)
+  | GramTerminal s -> (gram_token_of_string s, None)
   | GramNonTerminal (_,t,e,po) ->
       (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po)
 
@@ -229,19 +227,21 @@ let extend_tactic_grammar s gl =
   let univ = get_univ "tactic" in
   let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
   let rules = List.map (make_rule univ mkact make_prod_item) gl in
-  Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+  maybe_uncurry (Gram.extend Tactic.simple_tactic)
+    (None,[(None, None, List.rev rules)])
 
 (* Vernac grammar extensions *)
 
 let vernac_exts = ref []
 let get_extend_vernac_grammars () = !vernac_exts
 
-let extend_vernac_command_grammar s gl =
+let extend_vernac_command_grammar s nt gl =
+  let nt = Option.default Vernac_.command nt in
   vernac_exts := (s,gl) :: !vernac_exts;
   let univ = get_univ "vernac" in
   let mkact loc l = VernacExtend (s,List.map snd l) in
   let rules = List.map (make_rule univ mkact make_prod_item) gl in
-  Gram.extend Vernac_.command None [(None, None, List.rev rules)]
+  maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
 
 (**********************************************************************)
 (** Grammar declaration for Tactic Notation (Coq level)               *)
@@ -252,7 +252,7 @@ let get_tactic_entry n =
   else if n = 5 then
     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))
+    weaken_entry Tactic.tactic_expr, Some (Compat.Level (string_of_int n))
   else
     error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
 
@@ -276,14 +276,14 @@ let add_tactic_entry (key,lev,prods,tac) =
 	(TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) 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])];
+  grammar_extend entry None (pos,[(None, None, List.rev [rules])]);
   1
 
 (**********************************************************************)
 (** State of the grammar extensions                                   *)
 
 type notation_grammar =
-    int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list
+    int * gram_assoc option * notation * grammar_constr_prod_item list list
 
 type all_grammar_command =
   | Notation of
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index 8554c9be..1d85c74e 100644
--- a/parsing/egrammar.mli
+++ b/parsing/egrammar.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: egrammar.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
+open Compat
 open Util
 open Names
 open Topconstr
@@ -16,36 +14,35 @@ open Pcoq
 open Extend
 open Vernacexpr
 open Ppextend
-open Rawterm
+open Glob_term
 open Genarg
 open Mod_subst
-(*i*)
 
 (** Mapping of grammar productions to camlp4 actions
     Used for Coq-level Notation and Tactic Notation,
     and for ML-level tactic and vernac extensions
  *)
 
-(* For constr notations *)
+(** For constr notations *)
 
 type grammar_constr_prod_item =
-  | GramConstrTerminal of Token.pattern
+  | GramConstrTerminal of Tok.t
   | GramConstrNonTerminal of constr_prod_entry_key * identifier option
   | GramConstrListMark of int * bool
     (* tells action rule to make a list of the n previous parsed items; 
        concat with last parsed list if true *)
 
 type notation_grammar =
-    int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list
+    int * gram_assoc option * notation * grammar_constr_prod_item list list
 
-(* For tactic and vernac notations *)
+(** For tactic and vernac notations *)
 
 type grammar_prod_item =
   | GramTerminal of string
   | GramNonTerminal of loc * argument_type *
-      Gram.te prod_entry_key * identifier option
+      prod_entry_key * identifier option
 
-(* Adding notations *)
+(** Adding notations *)
 
 type all_grammar_command =
   | Notation of
@@ -64,7 +61,7 @@ val extend_tactic_grammar :
   string -> grammar_prod_item list list -> unit
 
 val extend_vernac_command_grammar :
-  string -> grammar_prod_item list list -> unit
+  string -> vernac_expr Gram.entry option -> grammar_prod_item list list -> unit
 
 val get_extend_vernac_grammars :
  unit -> (string * grammar_prod_item list list) list
diff --git a/parsing/extend.ml b/parsing/extend.ml
index 9b85ada5..fca24ed5 100644
--- a/parsing/extend.ml
+++ b/parsing/extend.ml
@@ -1,42 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extend.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
+open Compat
 open Util
 
-(**********************************************************************)
-(* 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                                    *)
+(** Entry keys for constr notations *)
 
 type side = Left | Right
 
 type production_position =
-  | BorderProd of side * Gramext.g_assoc option
+  | BorderProd of side * gram_assoc option
   | InternalProd
 
 type production_level =
@@ -45,21 +23,24 @@ type production_level =
 
 type ('lev,'pos) constr_entry_key_gen =
   | ETName | ETReference | ETBigint
-  | ETBinder of bool
+  | ETBinder of bool (* true=open, as in "fun .."; false as in "let f .. :=" *)
   | ETConstr of ('lev * 'pos)
   | ETPattern
   | ETOther of string * string
-  | ETConstrList of ('lev * 'pos) * Token.pattern list
-  | ETBinderList of bool * Token.pattern list
+  | ETConstrList of ('lev * 'pos) * Tok.t list
+  | ETBinderList of bool * Tok.t list
+
+(**  Entries level (left-hand-side of grammar rules) *)
 
-(* Entries level (left-hand-side of grammar rules) *)
 type constr_entry_key =
     (int,unit) constr_entry_key_gen
 
-(* Entries used in productions (in right-hand side of grammar rules) *)
+(** 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") *)
+(** 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 269331c2..6b29fc74 100644
--- a/parsing/extend.mli
+++ b/parsing/extend.mli
@@ -1,42 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extend.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+open Compat
 
-open Util
-
-(**********************************************************************)
-(* 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                                    *)
+(** Entry keys for constr notations *)
 
 type side = Left | Right
 
 type production_position =
-  | BorderProd of side * Gramext.g_assoc option
+  | BorderProd of side * gram_assoc option
   | InternalProd
 
 type production_level =
@@ -49,17 +26,20 @@ type ('lev,'pos) constr_entry_key_gen =
   | ETConstr of ('lev * 'pos)
   | ETPattern
   | ETOther of string * string
-  | ETConstrList of ('lev * 'pos) * Token.pattern list
-  | ETBinderList of bool * Token.pattern list
+  | ETConstrList of ('lev * 'pos) * Tok.t list
+  | ETBinderList of bool * Tok.t list
+
+(** Entries level (left-hand-side of grammar rules) *)
 
-(* Entries level (left-hand-side of grammar rules) *)
 type constr_entry_key =
     (int,unit) constr_entry_key_gen
 
-(* Entries used in productions (in right-hand-side of grammar rules) *)
+(** 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") *)
+(** 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
index 94179d95..ce734622 100644
--- a/parsing/extrawit.ml
+++ b/parsing/extrawit.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extrawit.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Genarg
 
diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli
index 9b0aac39..2d2eef37 100644
--- a/parsing/extrawit.mli
+++ b/parsing/extrawit.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extrawit.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Genarg
 open Tacexpr
 
-(* This file defines extra argument types *)
+(** This file defines extra argument types *)
 
-(* Tactics as arguments *)
+(** Tactics as arguments *)
 
 val tactic_main_level : int
 
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index e7d4684b..5d5f6e4d 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -1,26 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_constr.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Constr
 open Prim
-open Rawterm
+open Glob_term
 open Term
 open Names
 open Libnames
 open Topconstr
-
 open Util
+open Tok
+open Compat
 
 let constr_kw =
   [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for";
@@ -28,7 +25,7 @@ let constr_kw =
     "Prop"; "Set"; "Type"; ".("; "_"; "..";
     "`{"; "`("; "{|"; "|}" ]
 
-let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw
+let _ = List.iter Lexer.add_keyword constr_kw
 
 let mk_cast = function
     (c,(_,None)) -> c
@@ -36,7 +33,7 @@ let mk_cast = function
 
 let binders_of_lidents l =
   List.map (fun (loc, id) ->
-    LocalRawAssum ([loc, Name id], Default Rawterm.Explicit,
+    LocalRawAssum ([loc, Name id], Default Glob_term.Explicit,
 		  CHole (loc, Some (Evd.BinderType (Name id))))) l
 
 let mk_fixb (id,bl,ann,body,(loc,tyc)) =
@@ -66,60 +63,49 @@ 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 err () = raise Stream.Failure
+
 (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
 (* admissible notation "(x t)" *)
 let lpar_id_coloneq =
   Gram.Entry.of_parser "test_lpar_id_coloneq"
     (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-	      | [_; ("IDENT",s)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":=")] ->
-                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+	      | IDENT s ->
+                  (match get_tok (stream_nth 2 strm) with
+                    | KEYWORD ":=" ->
+                        stream_njunk 3 strm;
                         Names.id_of_string s
-	            | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
+	            | _ -> err ())
+              | _ -> err ())
+        | _ -> err ())
 
 let impl_ident_head =
   Gram.Entry.of_parser "impl_ident_head"
     (fun strm ->
-      match Stream.npeek 1 strm with
-	| [(_,"{")] ->
-	    (match Stream.npeek 2 strm with
-	      | [_;("IDENT",("wf"|"struct"|"measure"))] ->
-		  raise Stream.Failure
-	      | [_;("IDENT",s)] ->
-		  Stream.junk strm; Stream.junk strm;
+      match get_tok (stream_nth 0 strm) with
+	| KEYWORD "{" ->
+	    (match get_tok (stream_nth 1 strm) with
+	      | IDENT ("wf"|"struct"|"measure") -> err ()
+	      | IDENT s ->
+		  stream_njunk 2 strm;
 		  Names.id_of_string s
-	      | _ -> raise Stream.Failure)
-	| _ -> raise Stream.Failure)
+	      | _ -> err ())
+	| _ -> err ())
 
 let ident_colon =
   Gram.Entry.of_parser "ident_colon"
     (fun strm ->
-      match Stream.npeek 1 strm with
-	| [("IDENT",s)] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("", ":")] ->
-                  Stream.junk strm; Stream.junk strm;
+      match get_tok (stream_nth 0 strm) with
+	| IDENT s ->
+            (match get_tok (stream_nth 1 strm) with
+              | KEYWORD ":" ->
+                  stream_njunk 2 strm;
                   Names.id_of_string s
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
-
-let ident_with =
-  Gram.Entry.of_parser "ident_with"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-      | [("IDENT",s)] ->
-          (match Stream.npeek 2 strm with
-          | [_; ("", "with")] ->
-              Stream.junk strm; Stream.junk strm;
-              Names.id_of_string s
-          | _ -> raise Stream.Failure)
-      | _ -> raise Stream.Failure)
+              | _ -> err ())
+        | _ -> err ())
 
 let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None
 
@@ -147,9 +133,9 @@ GEXTEND Gram
     [ [ c = lconstr -> c ] ]
   ;
   sort:
-    [ [ "Set"  -> RProp Pos
-      | "Prop" -> RProp Null
-      | "Type" -> RType None ] ]
+    [ [ "Set"  -> GProp Pos
+      | "Prop" -> GProp Null
+      | "Type" -> GType None ] ]
   ;
   lconstr:
     [ [ c = operconstr LEVEL "200" -> c ] ]
@@ -215,7 +201,7 @@ GEXTEND Gram
     [ [ "fun" -> () ] ]
   ;
   record_declaration:
-    [ [ fs = LIST1 record_field_declaration SEP ";" -> CRecord (loc, None, fs)
+    [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (loc, None, fs)
 (*       | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *)
 (* 	  CRecord (loc, Some c, fs) *)
     ] ]
@@ -227,7 +213,7 @@ GEXTEND Gram
   binder_constr:
     [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" ->
           mkCProdN loc bl c
-      | lambda; bl = open_binders; [ "=>" | "," ]; c = operconstr LEVEL "200" ->
+      | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" ->
           mkCLambdaN loc bl c
       | "let"; id=name; bl = binders; ty = type_cstr; ":=";
         c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
@@ -334,14 +320,17 @@ GEXTEND Gram
       [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ]
     | "99" RIGHTA [ ]
     | "10" LEFTA
+      [ p = pattern; "as"; id = ident ->
+	  CPatAlias (loc, p, id) ]
+    | "9" RIGHTA
       [ p = pattern; lp = LIST1 NEXT ->
         (match p with
           | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
           | _ -> Util.user_err_loc
               (cases_pattern_expr_loc p, "compound_pattern",
                Pp.str "Constructor expected."))
-      | p = pattern; "as"; id = ident ->
-	  CPatAlias (loc, p, id) ]
+      |"@"; r = Prim.reference; lp = LIST1 NEXT ->
+        CPatCstrExpl (loc, r, lp) ]
     | "1" LEFTA
       [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ]
     | "0"
diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4
deleted file mode 100644
index 8893ebcc..00000000
--- a/parsing/g_decl_mode.ml4
+++ /dev/null
@@ -1,252 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 q_MLast.cmo" i*)
-
-(* $Id: g_decl_mode.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-
-open Decl_expr
-open Names
-open Term
-open Genarg
-open Pcoq
-
-open Pcoq.Constr
-open Pcoq.Tactic
-open Pcoq.Vernac_
-
-let none_is_empty = function
-    None -> []
-  | Some l -> l
-
-GEXTEND Gram
-GLOBAL: proof_instr;
-  thesis :
-    [[ "thesis" -> Plain
-     | "thesis"; "for"; i=ident -> (For i)
-     ]];
-  statement :
-    [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c}
-     | i=ident -> {st_label=Anonymous;
-		   st_it=Topconstr.CRef (Libnames.Ident (loc, i))}
-     | c=constr -> {st_label=Anonymous;st_it=c}
-     ]];
-  constr_or_thesis :
-     [[ t=thesis -> Thesis t ] |
-      [ c=constr -> This c
-      ]];
-  statement_or_thesis :
-    [
-      [ 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;
-		    st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))}
-      | c=constr -> {st_label=Anonymous;st_it=This c}
-      ]
-    ];
-  justification_items :
-    [[ -> Some []
-     | "by"; l=LIST1 constr SEP "," -> Some l
-     | "by"; "*"                    -> None ]]
-  ;
-  justification_method :
-    [[ -> None
-     | "using";  tac = tactic -> Some tac ]]
-  ;
-  simple_cut_or_thesis :
-    [[ ls = statement_or_thesis;
-       j = justification_items;
-       taco = justification_method
-	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
-  ;
-  simple_cut :
-    [[ ls = statement;
-       j = justification_items;
-       taco = justification_method
-	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
-  ;
-  elim_type:
-    [[ IDENT "induction" -> ET_Induction
-     | IDENT "cases" -> ET_Case_analysis ]]
-  ;
-  block_type :
-    [[ IDENT "claim" -> B_claim
-     | 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" ;
-       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} ]]
-  ;
-  rew_step :
-    [[ "~=" ;         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"; 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);
-     | IDENT "have"; c=simple_cut_or_thesis -> Pcut c;
-     | IDENT "claim"; c=statement -> Pclaim 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:
-    [[ id=ident -> fun x -> (loc,(id,x)) ]];
-  hyp:
-    [[ id=loc_id -> id None ;
-     | id=loc_id ; ":" ; c=constr -> id (Some c)]]
-  ;
-  consider_vars:
-    [[ name=hyp -> [Hvar name]
-     | name=hyp; ","; v=consider_vars -> (Hvar name) :: v
-     | name=hyp;
-       IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h
-     ]]
-  ;
-  consider_hyps:
-    [[ st=statement; IDENT "and"; h=consider_hyps  -> Hprop st::h
-     | 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;
-       IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h
-     ]]
-  ;
-  assume_hyps:
-    [[ st=statement; IDENT "and"; h=assume_hyps  -> Hprop st::h
-     | st=statement; IDENT "and";
-       IDENT "we"; IDENT "have" ; v=assume_vars  -> Hprop st::v
-     | st=statement -> [Hprop st]
-     ]]
-  ;
-  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 ->
-	 let (q,c) = v in ((Hvar name) :: q),c
-     | 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  ->
-	 let (q,c) = h in (Hprop st::q),c
-     | 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 ->
-	 [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";
-       IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h
-     ]]
-  ;
-  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]
-    ]];
-  given_vars:
-    [[ name=hyp -> [Hvar name]
-     | name=hyp; ","; v=given_vars -> (Hvar name) :: v
-     | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h
-     ]]
-  ;
-  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; ","; v=suppose_vars -> (Hvar name) :: v
-     |name=hyp; OPT[IDENT "be"];
-      IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h
-     ]]
-  ;
-  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
-     | st=statement_or_thesis -> [Hprop st]
-     ]]
-  ;
-  suppose_clause:
-    [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v;
-     |  h=suppose_hyps -> h ]]
-  ;
-  intro_step:
-    [[ IDENT "suppose" ; h=assume_clause -> Psuppose h
-     | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ;
-       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
-     | 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;
-       "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 :
-    [[ -> 0
-     | "*" -> 1
-     | "**" -> 2
-     | "***" -> 3
-     ]]
-  ;
-  bare_proof_instr:
-    [[ c = cut_step -> c ;
-     | i = intro_step -> i ]]
-  ;
-  proof_instr :
-    [[ e=emphasis;i=bare_proof_instr -> {emph=e;instr=i}]]
-  ;
-END;;
-
-
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
index dac4a135..2f129637 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -1,29 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_ltac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Topconstr
-open Rawterm
+open Glob_term
 open Tacexpr
 open Vernacexpr
 open Pcoq
 open Prim
 open Tactic
+open Tok
 
 let fail_default_value = ArgArg 0
 
 let arg_of_expr = function
-    TacArg a -> a
+    TacArg (loc,a) -> a
   | e -> Tacexp (e:raw_tactic_expr)
 
 (* Tactics grammar rules *)
@@ -60,6 +57,7 @@ GEXTEND Gram
     | "3" RIGHTA
       [ IDENT "try"; ta = tactic_expr -> TacTry ta
       | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
+      | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta)
       | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
       | IDENT "progress"; ta = tactic_expr -> TacProgress ta
 (*To do: put Abstract in Refiner*)
@@ -87,20 +85,20 @@ GEXTEND Gram
       | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
 	  l = LIST0 message_token -> TacFail (n,l)
       | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg ->
-	  TacArg (TacExternal (loc,com,req,la))
+	  TacArg (loc,TacExternal (loc,com,req,la))
       | st = simple_tactic -> TacAtom (loc,st)
-      | a = may_eval_arg -> TacArg(a)
+      | a = may_eval_arg -> TacArg(loc,a)
       | IDENT "constr"; ":"; id = METAIDENT ->
-          TacArg(MetaIdArg (loc,false,id))
+          TacArg(loc,MetaIdArg (loc,false,id))
       | IDENT "constr"; ":"; c = Constr.constr ->
-          TacArg(ConstrMayEval(ConstrTerm c))
+          TacArg(loc,ConstrMayEval(ConstrTerm c))
       | IDENT "ipattern"; ":"; ipat = simple_intropattern ->
-	  TacArg(IntroPattern ipat)
+	  TacArg(loc,IntroPattern ipat)
       | r = reference; la = LIST0 tactic_arg ->
-          TacArg(TacCall (loc,r,la)) ]
+          TacArg(loc,TacCall (loc,r,la)) ]
     | "0"
       [ "("; a = tactic_expr; ")" -> a
-      | a = tactic_atom -> TacArg a ] ]
+      | a = tactic_atom -> TacArg (loc,a) ] ]
   ;
   (* binder_tactic: level 5 of tactic_expr *)
   binder_tactic:
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index c4fd3bb5..307e1779 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -1,22 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(*i $Id: g_prim.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pcoq
 open Names
 open Libnames
 open Topconstr
+open Tok
+open Compat
 
 let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"]
-let _ = List.iter (fun s -> Lexer.add_token("",s)) prim_kw
+let _ = List.iter Lexer.add_keyword prim_kw
 
 open Prim
 open Nametab
@@ -45,7 +43,7 @@ GEXTEND Gram
     [ [ s = IDENT -> id_of_string s ] ]
   ;
   pattern_ident:
-    [ [ s = LEFTQMARK; id = ident -> id ] ]
+    [ [ LEFTQMARK; id = ident -> id ] ]
   ;
   pattern_identref:
     [ [ id = pattern_ident -> (loc, id) ] ]
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index f1dad3b2..9abb8cd1 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -1,16 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_proofs.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-
 open Pcoq
 open Pp
 open Tactic
@@ -20,6 +15,7 @@ open Topconstr
 open Vernacexpr
 open Prim
 open Constr
+open Tok
 
 let thm_token = G_vernac.thm_token
 
@@ -34,12 +30,19 @@ GEXTEND Gram
   ;
   opt_hintbases:
   [ [ -> []
-    | ":"; l = LIST1 IDENT -> l ] ]
+    | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ]
   ;
   command:
     [ [ IDENT "Goal"; c = lconstr -> VernacGoal c
-      | IDENT "Proof" -> VernacProof (Tacexpr.TacId [])
-      | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta
+      | IDENT "Proof" -> VernacProof (None,None)
+      | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn
+      | IDENT "Proof"; "with"; ta = tactic; 
+        l = OPT [ "using"; l = LIST0 identref  -> l ] ->
+          VernacProof (Some ta, l)
+      | IDENT "Proof"; "using"; l = LIST0 identref; 
+        ta = OPT [ "with"; ta = tactic -> ta ] ->
+          VernacProof (ta,Some l)
+      | IDENT "Proof"; c = lconstr -> VernacExactProof c
       | IDENT "Abort" -> VernacAbort None
       | IDENT "Abort"; IDENT "All" -> VernacAbortAll
       | IDENT "Abort"; id = identref -> VernacAbort (Some id)
@@ -59,15 +62,19 @@ GEXTEND Gram
       | IDENT "Resume" -> VernacResume None
       | IDENT "Resume"; id = identref -> VernacResume (Some id)
       | IDENT "Restart" -> VernacRestart
-      | IDENT "Proof"; c = lconstr -> VernacExactProof c
       | IDENT "Undo" -> VernacUndo 1
       | IDENT "Undo"; n = natural -> VernacUndo n
       | IDENT "Undo"; IDENT "To"; n = natural -> VernacUndoTo n
       | IDENT "Focus" -> VernacFocus None
       | IDENT "Focus"; n = natural -> VernacFocus (Some n)
       | IDENT "Unfocus" -> VernacUnfocus
-      | IDENT "Show" -> VernacShow (ShowGoal None)
-      | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n))
+      | IDENT "BeginSubproof" -> VernacSubproof None
+      | IDENT "BeginSubproof"; n = natural -> VernacSubproof (Some n)
+      | IDENT "EndSubproof" -> VernacEndSubproof
+      | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals)
+      | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n))
+      | IDENT "Show"; IDENT "Goal"; n = string ->
+          VernacShow (ShowGoal (GoalId n))
       | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural ->
 	  VernacShow (ShowGoalImplicitly n)
       | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
@@ -80,34 +87,22 @@ GEXTEND Gram
       | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
       | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id)
       | 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 ->
-	  VernacShow (ExplainTree l)
-      | IDENT "Go"; n = natural -> VernacGo (GoTo n)
-      | IDENT "Go"; IDENT "top" -> VernacGo GoTop
-      | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev
-      | IDENT "Go"; IDENT "next" -> VernacGo GoNext
       | IDENT "Guarded" -> VernacCheckGuard
-(* Hints for Auto and EAuto *)
+      (* Hints for Auto and EAuto *)
       | IDENT "Create"; IDENT "HintDb" ;
 	  id = IDENT ; b = [ "discriminated" -> true | -> false ] ->
 	    VernacCreateHintDb (use_module_locality (), id, b)
+      | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases ->
+	  VernacRemoveHints (use_module_locality (), dbnames, ids)
       | IDENT "Hint"; local = obsolete_locality; h = hint;
 	  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 <-" *)
+      (* Declare "Resolve" explicitly so as to be able to later extend with
+         "Resolve ->" and "Resolve <-" *)
       | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural;
 	  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 ->
-	  VernacExtend ("PrintConstr",
-	    [Genarg.in_gen Genarg.rawwit_constr c])
       ] ];
 
   obsolete_locality:
@@ -134,6 +129,6 @@ GEXTEND Gram
     ;
   constr_body:
     [ [ ":="; c = lconstr -> c
-      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Rawterm.CastConv (Term.DEFAULTcast,t)) ] ]
+      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Glob_term.CastConv (Term.DEFAULTcast,t)) ] ]
   ;
 END
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index be20f891..f1b3ffed 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -1,122 +1,104 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_tactic.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Util
 open Tacexpr
-open Rawterm
+open Glob_term
 open Genarg
 open Topconstr
 open Libnames
 open Termops
+open Tok
+open Compat
 
 let all_with delta = make_red_flag [FBeta;FIota;FZeta;delta]
 
 let tactic_kw = [ "->"; "<-" ; "by" ]
-let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw
+let _ = List.iter Lexer.add_keyword tactic_kw
+
+let err () = raise Stream.Failure
 
 (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
 (* admissible notation "(x t)" *)
 let test_lpar_id_coloneq =
   Gram.Entry.of_parser "lpar_id_coloneq"
     (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("IDENT",s)] ->
-                  (match Stream.npeek 3 strm with
-	            | [_; _; ("", ":=")] -> ()
-	            | _ -> raise Stream.Failure)
-	      | _ -> raise Stream.Failure)
-	| _ -> raise Stream.Failure)
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+	            | KEYWORD ":=" -> ()
+	            | _ -> err ())
+	      | _ -> err ())
+	| _ -> err ())
 
 (* idem for (x:=t) and (1:=t) *)
 let test_lpar_idnum_coloneq =
   Gram.Entry.of_parser "test_lpar_idnum_coloneq"
     (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; (("IDENT"|"INT"),_)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":=")] -> ()
-                    | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ | INT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+                    | KEYWORD ":=" -> ()
+                    | _ -> err ())
+              | _ -> err ())
+        | _ -> err ())
 
 (* idem for (x:t) *)
 let test_lpar_id_colon =
   Gram.Entry.of_parser "lpar_id_colon"
     (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("IDENT",id)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":")] -> ()
-                    | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+                    | KEYWORD ":" -> ()
+                    | _ -> err ())
+              | _ -> err ())
+        | _ -> err ())
 
 (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *)
 let check_for_coloneq =
   Gram.Entry.of_parser "lpar_id_colon"
     (fun strm ->
       let rec skip_to_rpar p n =
-	match list_last (Stream.npeek n strm) with
-        | ("","(") -> skip_to_rpar (p+1) (n+1)
-        | ("",")") -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1)
-	| ("",".") -> raise Stream.Failure
+	match get_tok (list_last (Stream.npeek n strm)) with
+        | KEYWORD "(" -> skip_to_rpar (p+1) (n+1)
+        | KEYWORD ")" -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1)
+	| KEYWORD "." -> err ()
 	| _ -> skip_to_rpar p (n+1) in
       let rec skip_names n =
-	match list_last (Stream.npeek n strm) with
-        | ("IDENT",_) | ("","_") -> skip_names (n+1)
-	| ("",":") -> skip_to_rpar 0 (n+1) (* skip a constr *)
-	| _ -> raise Stream.Failure in
+	match get_tok (list_last (Stream.npeek n strm)) with
+        | IDENT _ | KEYWORD "_" -> skip_names (n+1)
+	| KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *)
+	| _ -> err () in
       let rec skip_binders n =
-	match list_last (Stream.npeek n strm) with
-        | ("","(") -> skip_binders (skip_names (n+1))
-        | ("IDENT",_) | ("","_") -> skip_binders (n+1)
-	| ("",":=") -> ()
-	| _ -> raise Stream.Failure in
-      match Stream.npeek 1 strm with
-      | [("","(")] -> skip_binders 2
-      | _ -> raise Stream.Failure)
-
-let guess_lpar_ipat s strm =
-  match Stream.npeek 1 strm with
-    | [("","(")] ->
-        (match Stream.npeek 2 strm with
-          | [_; ("",("("|"["))] -> ()
-          | [_; ("IDENT",_)] ->
-              (match Stream.npeek 3 strm with
-                | [_; _; ("", s')] when s = s' -> ()
-                | _ -> raise Stream.Failure)
-          | _ -> raise Stream.Failure)
-    | _ -> raise Stream.Failure
-
-let guess_lpar_coloneq =
-  Gram.Entry.of_parser "guess_lpar_coloneq" (guess_lpar_ipat ":=")
-
-let guess_lpar_colon =
-  Gram.Entry.of_parser "guess_lpar_colon" (guess_lpar_ipat ":")
+	match get_tok (list_last (Stream.npeek n strm)) with
+        | KEYWORD "(" -> skip_binders (skip_names (n+1))
+        | IDENT _ | KEYWORD "_" -> skip_binders (n+1)
+	| KEYWORD ":=" -> ()
+	| _ -> err () in
+      match get_tok (stream_nth 0 strm) with
+      | KEYWORD "(" -> skip_binders 2
+      | _ -> err ())
 
 let lookup_at_as_coma =
   Gram.Entry.of_parser "lookup_at_as_coma"
     (fun strm ->
-      match Stream.npeek 1 strm with
-	| [("",(","|"at"|"as"))] -> ()
-	| _ -> raise Stream.Failure)
+      match get_tok (stream_nth 0 strm) with
+	| KEYWORD (","|"at"|"as") -> ()
+	| _ -> err ())
 
 open Constr
 open Prim
@@ -183,8 +165,8 @@ let mkCLambdaN_simple bl c =
 let loc_of_ne_list l = join_loc (fst (List.hd l)) (fst (list_last l))
 
 let map_int_or_var f = function
-  | Rawterm.ArgArg x -> Rawterm.ArgArg (f x)
-  | Rawterm.ArgVar _ as y -> y
+  | Glob_term.ArgArg x -> Glob_term.ArgArg (f x)
+  | Glob_term.ArgVar _ as y -> y
 
 let all_concl_occs_clause = { onhyps=Some[]; concl_occs=all_occurrences_expr }
 
@@ -222,12 +204,12 @@ GEXTEND Gram
   simple_intropattern;
 
   int_or_var:
-    [ [ n = integer  -> Rawterm.ArgArg n
-      | id = identref -> Rawterm.ArgVar id ] ]
+    [ [ n = integer  -> Glob_term.ArgArg n
+      | id = identref -> Glob_term.ArgVar id ] ]
   ;
   nat_or_var:
-    [ [ n = natural  -> Rawterm.ArgArg n
-      | id = identref -> Rawterm.ArgVar id ] ]
+    [ [ n = natural  -> Glob_term.ArgArg n
+      | id = identref -> Glob_term.ArgVar id ] ]
   ;
   (* An identifier or a quotation meta-variable *)
   id_or_meta:
@@ -236,12 +218,6 @@ GEXTEND Gram
       (* This is used in quotations *)
       | id = METAIDENT -> MetaId (loc,id) ] ]
   ;
-  (* A number or a quotation meta-variable *)
-  num_or_meta:
-    [ [ n = integer -> AI n
-      |	id = METAIDENT -> MetaId (loc,id)
-      ] ]
-  ;
   open_constr:
     [ [ c = constr -> ((),c) ] ]
   ;
@@ -451,7 +427,7 @@ GEXTEND Gram
   ;
   hintbases:
     [ [ "with"; "*" -> None
-      | "with"; l = LIST1 IDENT -> Some l
+      | "with"; l = LIST1 [ x = IDENT -> x] -> Some l
       | -> Some [] ] ]
   ;
   auto_using:
@@ -656,9 +632,9 @@ GEXTEND Gram
       | "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 ->
+      | IDENT "constructor"; n = nat_or_var; l = with_bindings ->
 	  TacConstructor (false,n,l)
-      | IDENT "econstructor"; n = num_or_meta; l = with_bindings ->
+      | IDENT "econstructor"; n = nat_or_var; l = with_bindings ->
 	  TacConstructor (true,n,l)
       | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor (false,t)
       | IDENT "econstructor"; t = OPT tactic -> TacAnyConstructor (true,t)
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index d761ed64..ac81786b 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_vernac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-
 open Pp
+open Compat
+open Tok
 open Util
 open Names
 open Topconstr
 open Extend
 open Vernacexpr
 open Pcoq
-open Decl_mode
 open Tactic
 open Decl_kinds
 open Genarg
 open Ppextend
 open Goptions
+open Declaremods
 
 open Prim
 open Constr
@@ -32,39 +28,48 @@ open Vernac_
 open Module
 
 let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
-let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
+let _ = List.iter Lexer.add_keyword vernac_kw
 
 (* Rem: do not join the different GEXTEND into one, it breaks native *)
 (* compilation on PowerPC and Sun architectures *)
 
-let check_command = Gram.Entry.create "vernac:check_command"
+let check_command = Gram.entry_create "vernac:check_command"
 
-let tactic_mode = Gram.Entry.create "vernac:tactic_command"
-let proof_mode = Gram.Entry.create "vernac:proof_command"
-let noedit_mode = Gram.Entry.create "vernac:noedit_command"
+let tactic_mode = Gram.entry_create "vernac:tactic_command"
+let noedit_mode = Gram.entry_create "vernac:noedit_command"
+let subprf = Gram.entry_create "vernac:subprf"
 
-let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
-let thm_token = Gram.Entry.create "vernac:thm_token"
-let def_body = Gram.Entry.create "vernac:def_body"
-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 class_rawexpr = Gram.entry_create "vernac:class_rawexpr"
+let thm_token = Gram.entry_create "vernac:thm_token"
+let def_body = Gram.entry_create "vernac:def_body"
+let decl_notation = Gram.entry_create "vernac:decl_notation"
+let record_field = Gram.entry_create "vernac:record_field"
+let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion"
+let subgoal_command = Gram.entry_create "proof_mode:subgoal_command"
+let instance_name = Gram.entry_create "vernac:instance_name"
 
-let get_command_entry () =
-  match Decl_mode.get_current_mode () with
-      Mode_proof -> proof_mode
-    | Mode_tactic -> tactic_mode
-    | Mode_none -> noedit_mode
+let command_entry = ref noedit_mode
+let set_command_entry e = command_entry := e
+let get_command_entry () = !command_entry
+
+
+(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for
+    proof editing and changes nothing else). Then sets it as the default proof mode. *)
+let set_tactic_mode () = set_command_entry tactic_mode
+let set_noedit_mode () = set_command_entry noedit_mode
+let _ = Proof_global.register_proof_mode {Proof_global.
+					    name = "Classic" ;
+					    set = set_tactic_mode ;
+					    reset = set_noedit_mode
+					 }
 
 let default_command_entry =
   Gram.Entry.of_parser "command_entry"
-    (fun strm -> Gram.Entry.parse_token (get_command_entry ()) strm)
+    (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm)
 
 let no_hook _ _ = ()
 GEXTEND Gram
-  GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode;
+  GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command;
   vernac: FIRST
     [ [ IDENT "Time"; v = vernac -> VernacTime v
       | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v)
@@ -79,6 +84,7 @@ GEXTEND Gram
       | c = command; "." -> c
       | c = syntax; "." -> c
       | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
+      | c = subprf -> c
     ] ]
   ;
   vernac_aux: LAST
@@ -96,20 +102,27 @@ GEXTEND Gram
   [ [ gln = OPT[n=natural; ":" -> n];
       tac = subgoal_command -> tac gln ] ]
   ;
-  subgoal_command:
-    [ [ c = check_command; "." -> c
+
+  subprf:
+  [ [
+      "-" -> VernacBullet Dash
+    | "*" -> VernacBullet Star
+    | "+" -> VernacBullet Plus
+    | "{" -> VernacSubproof None
+    | "}" -> VernacEndSubproof
+    ] ]
+  ;
+
+
+
+  subgoal_command: 
+    [ [ c = check_command; "." -> fun g -> c g
       | tac = Tactic.tactic;
         use_dft_tac = [ "." -> false | "..." -> true ] ->
           (fun g ->
-            let g = match g with Some gl -> gl | _ -> 1 in
+            let g = Option.default 1 g in
             VernacSolve(g,tac,use_dft_tac)) ] ]
   ;
-  proof_mode:
-    [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ]
-  ;
-  proof_mode: LAST
-    [ [ c=subgoal_command -> c (Some 1) ] ]
-  ;
   located_vernac:
     [ [ v = vernac -> loc, v ] ]
   ;
@@ -117,20 +130,20 @@ END
 
 let test_plurial_form = function
   | [(_,([_],_))] ->
-      Flags.if_verbose warning
-   "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
+      Flags.if_verbose msg_warning
+   (str "Keywords Variables/Hypotheses/Parameters expect more than one assumption")
   | _ -> ()
 
 let test_plurial_form_types = function
   | [([_],_)] ->
-      Flags.if_verbose warning
-   "Keywords Implicit Types expect more than one type"
+      Flags.if_verbose msg_warning
+   (str "Keywords Implicit Types expect more than one type")
   | _ -> ()
 
 (* Gallina declarations *)
 GEXTEND Gram
   GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion
-    typeclass_context typeclass_constraint record_field decl_notation;
+    typeclass_constraint record_field decl_notation rec_definition;
 
   gallina:
       (* Definition, Theorem, Variable, Axiom, ... *)
@@ -144,10 +157,6 @@ GEXTEND Gram
       | stre = assumptions_token; nl = inline; bl = assum_list ->
 	  test_plurial_form bl;
 	  VernacAssumption (stre, nl, bl)
-      | IDENT "Boxed";"Definition";id = identref; b = def_body ->
-	  VernacDefinition ((Global,true,Definition), id, b, no_hook)
-      | 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 ->
           VernacDefinition (d, id, b, f)
       (* Gallina inductive declarations *)
@@ -156,14 +165,10 @@ GEXTEND Gram
 	  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" ->
-          VernacFixpoint (recs,false)
-       | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
-          VernacFixpoint (recs,Flags.boxed_definitions())
+      | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint recs
       | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
-          VernacCoFixpoint (corecs,false)
+          VernacCoFixpoint corecs
       | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l
       | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from";
 	l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ]
@@ -178,10 +183,6 @@ GEXTEND Gram
 	    VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]])
   ] ]
   ;
-  typeclass_context:
-    [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l
-    | -> [] ] ]
-  ;
   thm_token:
     [ [ "Theorem" -> Theorem
       | IDENT "Lemma" -> Lemma
@@ -193,13 +194,13 @@ GEXTEND Gram
   ;
   def_token:
     [ [ "Definition" ->
-	no_hook, (Global, Flags.boxed_definitions(), Definition)
+	no_hook, (Global, Definition)
       | IDENT "Let" ->
-	no_hook, (Local, Flags.boxed_definitions(), Definition)
+	no_hook, (Local, Definition)
       | IDENT "Example" ->
-	no_hook, (Global, Flags.boxed_definitions(), Example)
+	no_hook, (Global, Example)
       | IDENT "SubClass"  ->
-          Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ]
+          Class.add_subclass_hook, (use_locality_exp (), SubClass) ] ]
   ;
   assumption_token:
     [ [ "Hypothesis" -> (Local, Logical)
@@ -215,7 +216,9 @@ GEXTEND Gram
       | IDENT "Parameters" -> (Global, Definitional) ] ]
   ;
   inline:
-    [ ["Inline" -> true |  -> false] ]
+    [ [ IDENT "Inline"; "("; i = INT; ")" -> Some (int_of_string i)
+      | IDENT "Inline" -> Some (Flags.get_inline_level())
+      | -> None] ]
   ;
   finite_token:
     [ [ "Inductive" -> (Inductive_kw,Finite)
@@ -233,7 +236,7 @@ GEXTEND Gram
   def_body:
     [ [ bl = binders; ":="; red = reduce; c = lconstr ->
       (match c with
-          CCast(_,c, Rawterm.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t)
+          CCast(_,c, Glob_term.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t)
         | _ -> DefineBody (bl, red, c, None))
     | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
 	DefineBody (bl, red, c, Some t)
@@ -325,7 +328,8 @@ GEXTEND Gram
 *)
   (* ... with coercions *)
   record_field:
-    [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ]
+  [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ];
+      ntn = decl_notation -> (bd,pri),ntn ] ]
   ;
   record_binder_body:
     [ [ l = binders; oc = of_type_with_opt_coercion;
@@ -335,13 +339,13 @@ GEXTEND Gram
 	   (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
       | l = binders; ":="; b = lconstr -> fun id ->
          match b with
-	 | CCast(_,b, Rawterm.CastConv (_, t)) ->
-	     (false,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
+	 | CCast(_,b, Glob_term.CastConv (_, t)) ->
+	     (None,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
          | _ ->
-	     (false,DefExpr(id,mkCLambdaN loc l b,None)) ] ]
+	     (None,DefExpr(id,mkCLambdaN loc l b,None)) ] ]
   ;
   record_binder:
-    [ [ id = name -> (false,AssumExpr(id,CHole (loc, None)))
+    [ [ id = name -> (None,AssumExpr(id,CHole (loc, None)))
       | id = name; f = record_binder_body -> f id ] ]
   ;
   assum_list:
@@ -352,13 +356,13 @@ GEXTEND Gram
   ;
   simple_assum_coe:
     [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr ->
-        (oc,(idl,c)) ] ]
+        (oc <> None,(idl,c)) ] ]
   ;
 
   constructor_type:
     [[ l = binders;
       t= [ coe = of_type_with_opt_coercion; c = lconstr ->
-	            fun l id -> (coe,(id,mkCProdN loc l c))
+	            fun l id -> (coe <> None,(id,mkCProdN loc l c))
             |  ->
 		 fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ]
 	 -> t l
@@ -369,9 +373,12 @@ GEXTEND Gram
     [ [ id = identref; c=constructor_type -> c id ] ]
   ;
   of_type_with_opt_coercion:
-    [ [ ":>" -> true
-      | ":"; ">" -> true
-      | ":" -> false ] ]
+    [ [ ":>>" -> Some false
+	| ":>"; ">" -> Some false
+	| ":>" -> Some true
+	| ":"; ">"; ">" -> Some false
+	| ":"; ">" -> Some true
+	| ":" -> None ] ]
   ;
 END
 
@@ -410,7 +417,8 @@ GEXTEND Gram
       | 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";
+	  Flags.if_verbose
+            msg_warning (str "Include Type is deprecated; use Include instead");
           VernacInclude(e::l) ] ]
   ;
   export_token:
@@ -442,13 +450,33 @@ GEXTEND Gram
     [ [ ":="; mexpr = module_expr_inl; l = LIST0 ext_module_expr -> (mexpr::l)
       | -> [] ] ]
   ;
+  functor_app_annot:
+    [ [ IDENT "inline"; "at"; IDENT "level"; i = INT ->
+        [InlineAt (int_of_string i)], []
+      | IDENT "no"; IDENT "inline" -> [NoInline], []
+      | IDENT "scope"; sc1 = IDENT; IDENT "to"; sc2 = IDENT -> [], [sc1,sc2]
+      ] ]
+  ;
+  functor_app_annots:
+    [ [ "["; l = LIST1 functor_app_annot SEP ","; "]" ->
+        let inl,scs = List.split l in
+	let inl = match List.concat inl with
+	  | [] -> DefaultInline
+	  | [inl] -> inl
+	  | _ -> error "Functor application with redundant inline annotations"
+	in { ann_inline = inl; ann_scope_subst = List.concat scs }
+      | -> { ann_inline = DefaultInline; ann_scope_subst = [] }
+      ] ]
+  ;
   module_expr_inl:
-    [ [ "!"; me = module_expr -> (me,false)
-      | me = module_expr -> (me,true) ] ]
+    [ [ "!"; me = module_expr ->
+        (me, { ann_inline = NoInline; ann_scope_subst = []})
+      | me = module_expr; a = functor_app_annots -> (me,a) ] ]
   ;
   module_type_inl:
-    [ [ "!"; me = module_type -> (me,false)
-      | me = module_type -> (me,true) ] ]
+    [ [ "!"; me = module_type ->
+        (me, { ann_inline = NoInline; ann_scope_subst = []})
+      | me = module_type; a = functor_app_annots -> (me,a) ] ]
   ;
   (* Module binder  *)
   module_binder:
@@ -458,7 +486,7 @@ GEXTEND Gram
   (* Module expressions *)
   module_expr:
     [ [ me = module_expr_atom -> me
-      | me1 = module_expr; me2 = module_expr_atom -> CMapply (me1,me2)
+      | me1 = module_expr; me2 = module_expr_atom -> CMapply (loc,me1,me2)
       ] ]
   ;
   module_expr_atom:
@@ -474,8 +502,9 @@ GEXTEND Gram
   module_type:
     [ [ 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)
+      | mty = module_type; me = module_expr_atom -> CMapply (loc,mty,me)
+      | mty = module_type; "with"; decl = with_declaration ->
+          CMwith (loc,mty,decl)
       ] ]
   ;
 END
@@ -502,16 +531,16 @@ GEXTEND Gram
           d = def_body ->
           let s = coerce_reference_to_id qid in
 	  VernacDefinition
-	    ((Global,false,CanonicalStructure),(dummy_loc,s),d,
+	    ((Global,CanonicalStructure),(dummy_loc,s),d,
 	     (fun _ -> Recordops.declare_canonical_structure))
 
       (* Coercions *)
       | IDENT "Coercion"; qid = global; d = def_body ->
           let s = coerce_reference_to_id qid in
-	  VernacDefinition ((use_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+	  VernacDefinition ((use_locality_exp (),Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
       | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
            let s = coerce_reference_to_id qid in
-	  VernacDefinition ((enforce_locality_exp true,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+	  VernacDefinition ((enforce_locality_exp true,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 true, f, s, t)
@@ -535,22 +564,75 @@ GEXTEND Gram
 	  VernacContext c
 
       | IDENT "Instance"; namesup = instance_name; ":";
-	 expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200";
+	 expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200";
 	 pri = OPT [ "|"; i = natural -> i ] ;
-	 props = [ ":="; "{"; r = record_declaration; "}" -> r |
-	     ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] ->
-	   VernacInstance (false, not (use_non_locality ()),
+	 props = [ ":="; "{"; r = record_declaration; "}" -> Some r |
+	     ":="; c = lconstr -> Some c | -> None ] ->
+	   VernacInstance (false, not (use_section_locality ()),
 			   snd namesup, (fst namesup, expl, t), props, pri)
 
-      | IDENT "Existing"; IDENT "Instance"; is = global -> 
-	  VernacDeclareInstance (not (use_section_locality ()), is)
+      | IDENT "Existing"; IDENT "Instance"; id = global ->
+	  VernacDeclareInstances (not (use_section_locality ()), [id])
+      | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global ->
+	  VernacDeclareInstances (not (use_section_locality ()), ids)
 
       | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is
 
+      (* Arguments *)
+      | IDENT "Arguments"; qid = smart_global; 
+        impl = LIST1 [ l = LIST0
+        [ item = argument_spec ->
+            let id, r, s = item in [`Id (id,r,s,false,false)]
+        | "/" -> [`Slash]
+        | "("; items = LIST1 argument_spec; ")"; sc = OPT scope ->
+            let f x = match sc, x with
+            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | Some _, Some _ -> error "scope declared twice" in
+            List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items
+        | "["; items = LIST1 argument_spec; "]"; sc = OPT scope ->
+            let f x = match sc, x with
+            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | Some _, Some _ -> error "scope declared twice" in
+            List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items
+        | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope ->
+            let f x = match sc, x with
+            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | Some _, Some _ -> error "scope declared twice" in
+            List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items
+        ] -> l ] SEP ",";
+        mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] ->
+         let mods = match mods with None -> [] | Some l -> List.flatten l in
+         let impl = List.map List.flatten impl in
+         let rec aux n (narg, impl) = function
+           | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl
+           | `Slash :: tl -> aux (n+1) (n, impl) tl
+           | [] -> narg, impl in
+         let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in
+         let nargs, rest = List.hd nargs, List.tl nargs in
+         if List.exists ((<>) nargs) rest then
+           error "All arguments lists must have the same length";
+         let err_incompat x y =
+           error ("Options \""^x^"\" and \""^y^"\" are incompatible") in
+         if nargs > 0 && List.mem `SimplNeverUnfold mods then
+           err_incompat "simpl never" "/";
+         if List.mem `SimplNeverUnfold mods &&
+            List.mem `SimplDontExposeCase mods then
+           err_incompat "simpl never" "simpl nomatch";
+         VernacArguments (use_section_locality(), qid, impl, nargs, mods)
+
+     (* moved there so that camlp5 factors it with the previous rule *)
+     | IDENT "Arguments"; IDENT "Scope"; qid = smart_global;
+       "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" ->
+	   Flags.if_verbose
+             msg_warning (str "Arguments Scope is deprecated; use Arguments instead");
+	 VernacArgumentsScope (use_section_locality (),qid,scl)
+
       (* Implicit *)
       | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global;
 	   pos = LIST0 [ "["; l = LIST0 implicit_name; "]" ->
 	     List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] ->
+	   Flags.if_verbose
+             msg_warning (str "Implicit Arguments is deprecated; use Arguments instead");
 	   VernacDeclareImplicits (use_section_locality (),qid,pos)
 
       | IDENT "Implicit"; "Type"; bl = reserv_list ->
@@ -567,12 +649,33 @@ GEXTEND Gram
 		  idl = LIST1 identref -> Some idl ] ->
 	     VernacGeneralizable (use_non_locality (), gen) ] ]
   ;
+  arguments_modifier:
+    [ [ IDENT "simpl"; IDENT "nomatch" -> [`SimplDontExposeCase]
+      | IDENT "simpl"; IDENT "never" -> [`SimplNeverUnfold]
+      | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits]
+      | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits]
+      | IDENT "clear"; IDENT "scopes" -> [`ClearScopes]
+      | IDENT "rename" -> [`Rename]
+      | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" ->
+          [`ClearImplicits; `ClearScopes]
+      | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" ->
+          [`ClearImplicits; `ClearScopes]
+      ] ]
+  ;
   implicit_name:
     [ [ "!"; id = ident -> (id, false, true)
     | id = ident -> (id,false,false)
     | "["; "!"; id = ident; "]" -> (id,true,true)
     | "["; id = ident; "]" -> (id,true, false) ] ]
   ;
+  scope:
+    [ [ "%"; key = IDENT -> key ] ]
+  ;
+  argument_spec: [
+       [ b = OPT "!"; id = name ; s = OPT scope ->
+       snd id, b <> None, Option.map (fun x -> loc, x) s
+    ]
+  ];
   strategy_level:
     [ [ IDENT "expand" -> Conv_oracle.Expand
       | IDENT "opaque" -> Conv_oracle.Opaque
@@ -606,11 +709,11 @@ GEXTEND Gram
 
       (* 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";
+	 expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200";
 	 pri = OPT [ "|"; i = natural -> i ] ->
-	   VernacInstance (true, not (use_non_locality ()),
+	   VernacInstance (true, not (use_section_locality ()),
 			   snd namesup, (fst namesup, expl, t),
-			   CRecord (loc, None, []), pri)
+			   None, pri)
 
       (* System directory *)
       | IDENT "Pwd" -> VernacChdir None
@@ -627,9 +730,6 @@ GEXTEND Gram
       | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
 	  VernacDeclareMLModule (use_locality (), l)
 
-      | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string ->
-	  error "This command is deprecated, use Print Universes"
-
       | IDENT "Locate"; l = locatable -> VernacLocate l
 
       (* Managing load paths *)
@@ -668,18 +768,11 @@ GEXTEND Gram
 	  VernacSearch (SearchPattern c, l)
       | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
 	  VernacSearch (SearchRewrite c, l)
-      | IDENT "SearchAbout";
-	  sl = [ "[";
-	         l = LIST1 [
-		   b = positive_search_mark; s = ne_string; sc = OPT scope
-		   -> b, SearchString (s,sc)
-		 | b = positive_search_mark; p = constr_pattern
-		   -> b, SearchSubPattern p
-		 ]; "]" -> l
-   	       | p = constr_pattern -> [true,SearchSubPattern p]
-   	       | s = ne_string; sc = OPT scope -> [true,SearchString (s,sc)] ];
-	  l = in_or_out_modules ->
-	  VernacSearch (SearchAbout sl, l)
+      | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries ->
+	  let (sl,m) = l in VernacSearch (SearchAbout (s::sl), m)
+      (* compatibility format of SearchAbout, with "[ ... ]" *)
+      | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]";
+	  l = in_or_out_modules -> VernacSearch (SearchAbout sl, l)
 
       | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
 	  VernacAddMLPath (false, dir)
@@ -714,16 +807,13 @@ GEXTEND Gram
       | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
         -> VernacRemoveOption ([table;field], v)
       | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
-	  VernacRemoveOption ([table], v)
-
-      | IDENT "proof" -> VernacDeclProof
-      | "return" -> VernacReturn ]]
+	  VernacRemoveOption ([table], v) ]] 
   ;
   check_command: (* TODO: rapprocher Eval et Check *)
     [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr ->
           fun g -> VernacCheckMayEval (Some r, g, c)
       | IDENT "Compute"; c = lconstr ->
-	  fun g -> VernacCheckMayEval (Some Rawterm.CbvVm, g, c)
+	  fun g -> VernacCheckMayEval (Some Glob_term.CbvVm, g, c)
       | IDENT "Check"; c = lconstr ->
 	  fun g -> VernacCheckMayEval (None, g, c) ] ]
   ;
@@ -758,9 +848,10 @@ GEXTEND Gram
       | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s
       | IDENT "Scopes" -> PrintScopes
       | IDENT "Scope"; s = IDENT -> PrintScope s
-      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
+      | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s
       | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid
-      | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt
+      | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt)
+      | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt)
       | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid)
       | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ]
   ;
@@ -777,7 +868,7 @@ GEXTEND Gram
       | IDENT "Ltac"; qid = global -> LocateTactic qid ] ]
   ;
   option_value:
-    [ [ n  = integer   -> IntValue n
+    [ [ n  = integer   -> IntValue (Some n)
       | s  = STRING    -> StringValue s ] ]
   ;
   option_ref_value:
@@ -785,14 +876,17 @@ GEXTEND Gram
       | s  = STRING   -> StringRefValue s ] ]
   ;
   option_table:
-    [ [ fl = LIST1 IDENT -> fl ]]
+    [ [ fl = LIST1 [ x = IDENT -> x ] -> fl ]]
   ;
   as_dirpath:
     [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
   ;
-  in_or_out_modules:
+  ne_in_or_out_modules:
     [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
-      | IDENT "outside"; l = LIST1 global -> SearchOutside l
+      | IDENT "outside"; l = LIST1 global -> SearchOutside l ] ]
+  ;
+  in_or_out_modules:
+    [ [ m = ne_in_or_out_modules -> m
       | -> SearchOutside [] ] ]
   ;
   comment:
@@ -806,6 +900,20 @@ GEXTEND Gram
   scope:
     [ [ "%"; key = IDENT -> key ] ]
   ;
+  searchabout_query:
+    [ [ b = positive_search_mark; s = ne_string; sc = OPT scope ->
+            (b, SearchString (s,sc))
+      | b = positive_search_mark; p = constr_pattern ->
+            (b, SearchSubPattern p)
+      ] ]
+  ;
+  searchabout_queries:
+    [ [ m = ne_in_or_out_modules -> ([],m)
+      | s = searchabout_query; l = searchabout_queries ->
+        let (sl,m) = l in (s::sl,m)
+      | -> ([],SearchOutside [])
+      ] ]
+  ;
 END;
 
 GEXTEND Gram
@@ -862,10 +970,6 @@ GEXTEND Gram
      | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with";
        refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
 
-     | IDENT "Arguments"; IDENT "Scope"; qid = smart_global;
-       "["; scl = LIST0 opt_scope; "]" ->
-	 VernacArgumentsScope (use_section_locality (),qid,scl)
-
      | IDENT "Infix"; local = obsolete_locality;
 	 op = ne_lstring; ":="; p = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
@@ -912,16 +1016,17 @@ GEXTEND Gram
       | IDENT "next"; IDENT "level" -> NextLevel ] ]
   ;
   syntax_modifier:
-    [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
-      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at";
+    [ [ "at"; IDENT "level"; n = natural -> SetLevel n
+      | IDENT "left"; IDENT "associativity" -> SetAssoc LeftA
+      | IDENT "right"; IDENT "associativity" -> SetAssoc RightA
+      | IDENT "no"; IDENT "associativity" -> SetAssoc NonA
+      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
+      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s
+      | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at";
         lev = level -> SetItemLevel (x::l,lev)
-      | "at"; IDENT "level"; n = natural -> SetLevel n
-      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
-      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
-      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
+      | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
       | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
-      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
-      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ]
+    ] ]
   ;
   syntax_extension_type:
     [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference
@@ -930,9 +1035,6 @@ GEXTEND Gram
       | IDENT "closed"; IDENT "binder" -> ETBinder false
     ] ]
   ;
-  opt_scope:
-    [ [ "_" -> None | sc = IDENT -> Some sc ] ]
-  ;
   production_item:
     [ [ s = ne_string -> TacTerm s
       | nt = IDENT;
diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4
index b8fee3ff..c9e135ed 100644
--- a/parsing/g_xml.ml4
+++ b/parsing/g_xml.ml4
@@ -1,27 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo" i*)
-
-(* $Id: g_xml.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Term
 open Pcoq
-open Rawterm
+open Glob_term
 open Genarg
 open Tacexpr
 open Libnames
 
 open Nametab
 open Detyping
+open Tok
 
 (* Generic xml parser without raw data *)
 
@@ -33,7 +30,7 @@ let check_tags loc otag 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)
+let xml_eoi = (Gram.entry_create "xml_eoi" : xml Gram.entry)
 
 GEXTEND Gram
   GLOBAL: xml_eoi;
@@ -98,9 +95,9 @@ let inductive_of_cdata a = match global_of_cdata a with
 let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a))
 
 let sort_of_cdata (loc,a) = match a with
-  | "Prop" -> RProp Null
-  | "Set" -> RProp Pos
-  | "Type" -> RType None
+  | "Prop" -> GProp Null
+  | "Set" -> GProp Pos
+  | "Type" -> GType None
   | _ -> user_err_loc (loc,"",str "sort expected.")
 
 let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al)
@@ -138,63 +135,64 @@ let compute_branches_lengths ind =
 let compute_inductive_nargs ind =
   Inductiveops.inductive_nargs (Global.env()) ind
 
-(* Interpreting constr as a rawconstr *)
+(* Interpreting constr as a glob_constr *)
 
 let rec interp_xml_constr = function
   | XmlTag (loc,"REL",al,[]) ->
-      RVar (loc, get_xml_ident al)
+      GVar (loc, get_xml_ident 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
       let ctx = List.map interp_xml_decl decls in
-      List.fold_right (fun (na,t) b -> RLambda (loc, na, Explicit, t, b))
+      List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b))
 	ctx (interp_xml_target body)
   | XmlTag (loc,"PROD",al,(_::_ as xl)) ->
       let body,decls = list_sep_last xl in
       let ctx = List.map interp_xml_decl decls in
-      List.fold_right (fun (na,t) b -> RProd (loc, na, Explicit, t, b))
+      List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b))
 	ctx (interp_xml_target body)
   | XmlTag (loc,"LETIN",al,(_::_ as xl)) ->
       let body,defs = list_sep_last xl in
       let ctx = List.map interp_xml_def defs in
-      List.fold_right (fun (na,t) b -> RLetIn (loc, na, t, b))
+      List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b))
         ctx (interp_xml_target body)
   | XmlTag (loc,"APPLY",_,x::xl) ->
-      RApp (loc, interp_xml_constr x, List.map interp_xml_constr xl)
+      GApp (loc, interp_xml_constr x, List.map interp_xml_constr xl)
   | XmlTag (loc,"instantiate",_,
       (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) ->
-      RApp (loc, interp_xml_constr x, List.map interp_xml_arg xl)
+      GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl)
   | XmlTag (loc,"META",al,xl) ->
-      REvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl))
+      GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl))
   | XmlTag (loc,"CONST",al,[]) ->
-      RRef (loc, ConstRef (get_xml_constant al))
+      GRef (loc, ConstRef (get_xml_constant al))
   | XmlTag (loc,"MUTCASE",al,x::y::yl) ->
       let ind = get_xml_inductive al in
       let p = interp_xml_patternsType x in
       let tm = interp_xml_inductiveTerm y in
-      let brs = List.map interp_xml_pattern yl in
-      let brns = Array.to_list (compute_branches_lengths ind) in
-      let mat = simple_cases_matrix_of_branches ind brns brs in
+      let vars = compute_branches_lengths ind in
+      let brs = list_map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl
+      in
+      let mat = simple_cases_matrix_of_branches ind brs in
       let nparams,n = compute_inductive_nargs ind in
       let nal,rtn = return_type_of_predicate ind nparams n p in
-      RCases (loc,RegularStyle,rtn,[tm,nal],mat)
+      GCases (loc,RegularStyle,rtn,[tm,nal],mat)
   | XmlTag (loc,"MUTIND",al,[]) ->
-      RRef (loc, IndRef (get_xml_inductive al))
+      GRef (loc, IndRef (get_xml_inductive al))
   | XmlTag (loc,"MUTCONSTRUCT",al,[]) ->
-      RRef (loc, ConstructRef (get_xml_constructor al))
+      GRef (loc, ConstructRef (get_xml_constructor al))
   | XmlTag (loc,"FIX",al,xl) ->
       let li,lnct = List.split (List.map interp_xml_FixFunction xl) in
       let ln,lc,lt = list_split3 lnct in
       let lctx = List.map (fun _ -> []) ln in
-      RRec (loc, RFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt)
+      GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt)
   | XmlTag (loc,"COFIX",al,xl) ->
       let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in
-      RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
+      GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
   | XmlTag (loc,"CAST",al,[x1;x2]) ->
-      RCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2))
+      GCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2))
   | XmlTag (loc,"SORT",al,[]) ->
-      RSort (loc, get_xml_sort al)
+      GSort (loc, get_xml_sort al)
   | XmlTag (loc,s,_,_) ->
       user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".")
 
@@ -232,15 +230,15 @@ and interp_xml_recursionOrder x =
   let (locs, s) = get_xml_attr "type" al in
     match s with
 	"Structural" ->
-	  (match l with [] -> RStructRec
+	  (match l with [] -> GStructRec
 	     | _ -> error_expect_no_argument loc)
       | "WellFounded" ->
 	  (match l with
-	       [c] -> RWfRec (interp_xml_type c)
+	       [c] -> GWfRec (interp_xml_type c)
 	     | _ -> error_expect_one_argument loc)
       | "Measure" ->
 	  (match l with
-	       [m;r] -> RMeasureRec (interp_xml_type m, Some (interp_xml_type r))
+	       [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r))
 	     | _ -> error_expect_two_arguments loc)
       | _ ->
           user_err_loc (locs,"",str "Invalid recursion order.")
@@ -252,7 +250,7 @@ and interp_xml_FixFunction x =
 	interp_xml_recursionOrder x1),
        (get_xml_name al, interp_xml_type x2, interp_xml_body x3))
   | (loc,al,[x1;x2]) ->
-      ((Some (nmtoken (get_xml_attr "recIndex" al)), RStructRec),
+      ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec),
        (get_xml_name al, interp_xml_type x1, interp_xml_body x2))
   | (loc,_,_) ->
       error_expect_one_argument loc
@@ -277,5 +275,5 @@ let rec interp_xml_tactic_arg = function
 
 let parse_tactic_arg ch =
   interp_xml_tactic_arg
-    (Pcoq.Gram.Entry.parse xml_eoi
-        (Pcoq.Gram.parsable (Stream.of_channel ch)))
+    (Pcoq.Gram.entry_parse xml_eoi
+       (Pcoq.Gram.parsable (Stream.of_channel ch)))
diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib
index 248a8ad9..ba393e63 100644
--- a/parsing/grammar.mllib
+++ b/parsing/grammar.mllib
@@ -8,12 +8,15 @@ Flags
 Segmenttree
 Unicodetable
 Util
+Errors
 Bigint
 Dyn
 Hashcons
 Predicate
 Rtree
 Option
+Store
+Hashtbl_alt
 
 Names
 Univ
@@ -58,13 +61,14 @@ Namegen
 Evd
 Reductionops
 Inductiveops
-Rawterm
+Glob_term
 Detyping
 Pattern
 Topconstr
 Genarg
 Ppextend
 Tacexpr
+Tok
 Lexer
 Extend
 Vernacexpr
diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib
index 3eb27abb..eed6caea 100644
--- a/parsing/highparsing.mllib
+++ b/parsing/highparsing.mllib
@@ -4,4 +4,3 @@ G_prim
 G_proofs
 G_tactic
 G_ltac
-G_decl_mode
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index 50349e22..e351061d 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -1,20 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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: lexer.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
-open Token
+open Compat
+open Tok
 
 (* Dictionaries: trees annotated with string options, each node being a map
    from chars to dictionaries (the subtrees). A trie, in other words. *)
@@ -76,18 +71,37 @@ let ttree_remove ttree str =
 
 (* Errors occuring while lexing (explained as "Lexer error: ...") *)
 
-type error =
-  | Illegal_character
-  | Unterminated_comment
-  | Unterminated_string
-  | Undefined_token
-  | Bad_token of string
+module Error = struct
+
+  type t =
+    | Illegal_character
+    | Unterminated_comment
+    | Unterminated_string
+    | Undefined_token
+    | Bad_token of string
+    | UnsupportedUnicode of int
+
+  exception E of t
+
+  let to_string x =
+    "Syntax Error: Lexer: " ^
+      (match x with
+	 | Illegal_character -> "Illegal character"
+	 | Unterminated_comment -> "Unterminated comment"
+	 | Unterminated_string -> "Unterminated string"
+	 | Undefined_token -> "Undefined token"
+	 | Bad_token tok -> Format.sprintf "Bad token %S" tok
+	 | UnsupportedUnicode x ->
+	     Printf.sprintf "Unsupported Unicode character (0x%x)" x)
 
-exception Error of error
+  let print ppf x = Format.fprintf ppf "%s@." (to_string x)
 
-let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str)
+end
+open Error
 
-let bad_token str = raise (Error (Bad_token str))
+let err loc str = Loc.raise (make_loc loc) (Error.E str)
+
+let bad_token str = raise (Error.E (Bad_token str))
 
 (* Lexer conventions on tokens *)
 
@@ -96,9 +110,9 @@ type token_kind =
   | AsciiChar
   | EmptyStream
 
-let error_unsupported_unicode_character n cs =
+let error_unsupported_unicode_character n unicode cs =
   let bp = Stream.count cs in
-  err (bp,bp+n) (Bad_token "Unsupported Unicode character")
+  err (bp,bp+n) (UnsupportedUnicode unicode)
 
 let error_utf8 cs =
   let bp = Stream.count cs in
@@ -147,7 +161,8 @@ let lookup_utf8_tail c cs =
       | _ -> error_utf8 cs
     in
     try classify_unicode unicode, n
-    with UnsupportedUtf8 -> njunk n cs; error_unsupported_unicode_character n cs
+    with UnsupportedUtf8 ->
+      njunk n cs; error_unsupported_unicode_character n unicode cs
 
 let lookup_utf8 cs =
   match Stream.peek cs with
@@ -155,14 +170,26 @@ let lookup_utf8 cs =
     | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs)
     | None -> EmptyStream
 
-let check_special_token str =
+let unlocated f x =
+  try f x with Loc.Exc_located (_,exc) -> raise exc
+
+let check_keyword str =
   let rec loop_symb = parser
     | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
-    | [< _ = Stream.empty >] -> ()
-    | [< '_ ; s >] -> loop_symb s
+    | [< s >] ->
+	match unlocated lookup_utf8 s with
+	| Utf8Token (_,n) -> njunk n s; loop_symb s
+	| AsciiChar -> Stream.junk s; loop_symb s
+	| EmptyStream -> ()
   in
   loop_symb (Stream.of_string str)
 
+let check_keyword_to_add s =
+  try check_keyword s
+  with Error.E (UnsupportedUnicode unicode) ->
+    Flags.if_verbose msg_warning
+      (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x which will not be parsable." s unicode))
+
 let check_ident str =
   let rec loop_id intail = parser
     | [< ' ('a'..'z' | 'A'..'Z' | '_'); s >] ->
@@ -170,7 +197,7 @@ let check_ident str =
     | [< ' ('0'..'9' | ''') when intail; s >] ->
         loop_id true s
     | [< s >] ->
-	match lookup_utf8 s with
+	match unlocated lookup_utf8 s with
 	| Utf8Token (UnicodeLetter, n) -> njunk n s; loop_id true s
 	| Utf8Token (UnicodeIdentPart, n) when intail -> njunk n s; loop_id true s
 	| EmptyStream -> ()
@@ -178,9 +205,8 @@ let check_ident str =
   in
   loop_id false (Stream.of_string str)
 
-let check_keyword str =
-  try check_special_token str
-  with Error _ -> check_ident str
+let is_ident str =
+  try let _ = check_ident str in true with Error.E _ -> false
 
 (* Keyword and symbol dictionary *)
 let token_tree = ref empty_ttree
@@ -190,22 +216,15 @@ let is_keyword s =
   with Not_found -> false
 
 let add_keyword str =
-  check_keyword str;
-  token_tree := ttree_add !token_tree str
+  if not (is_keyword str) then
+    begin
+      check_keyword_to_add str;
+      token_tree := ttree_add !token_tree str
+    end
 
 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
-  | "METAIDENT" | "LEFTQMARK" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI"
-      -> ()
-  | _ ->
-      raise (Token.Error ("\
-the constructor \"" ^ con ^ "\" is not recognized by Lexer"))
-
-
 (* Freeze and unfreeze the state of the lexer *)
 type frozen_t = ttree
 
@@ -249,17 +268,22 @@ let rec number len = parser
   | [< ' ('0'..'9' as c); s >] -> number (store len c) s
   | [< >] -> len
 
-let escape len c = store len c
-
 let rec string in_comments bp len = parser
   | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] ->
       if esc then string in_comments bp (store len '"') s else len
+  | [< ''('; s >] ->
+      (parser
+        | [< ''*'; s >] ->
+            string (Option.map succ in_comments) bp (store (store len '(') '*') s
+        | [< >] ->
+	    string in_comments bp (store len '(') s) s
   | [< ''*'; s >] ->
       (parser
         | [< '')'; s >] ->
-	    if in_comments then
+            if in_comments = Some 0 then
 	      msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment.");
-	    string in_comments bp (store (store len '*') ')') s
+            let in_comments = Option.map pred in_comments in
+ 	    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
@@ -348,7 +372,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 true bp2 0 s);
+      else ignore (string (Some 0) bp2 0 s);
       comment bp s
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment
   | [< 'z; s >] -> real_push_char z; comment bp s
@@ -394,61 +418,68 @@ 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
+  | Some c -> KEYWORD c
 
 (* Must be a special token *)
 let process_chars bp c cs =
   let t = progress_from_byte None (-1) !token_tree cs c in
   let ep = Stream.count cs in
   match t with
-    | Some t -> (("", t), (bp, ep))
+    | Some t -> (KEYWORD t, (bp, ep))
     | None ->
 	let ep' = bp + utf8_char_size cs c in
 	njunk (ep' - ep) cs;
 	err (bp, ep') Undefined_token
 
-let parse_after_dollar bp =
-  parser
-  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ->
-      ("METAIDENT", get_buff len)
-  | [< s >] ->
-      match lookup_utf8 s with
-      | Utf8Token (UnicodeLetter, n) ->
-	  ("METAIDENT", get_buff (ident_tail (nstore n 0 s) s))
-      | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '$' s)
+let token_of_special c s = match c with
+  | '$' -> METAIDENT s
+  | '.' -> FIELD s
+  | _ -> assert false
 
-(* Parse what follows a dot *)
-let parse_after_dot bp c =
+(* Parse what follows a dot / a dollar *)
+
+let parse_after_special c bp =
   parser
-  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ->
-      ("FIELD", get_buff len)
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail (store 0 d) >] ->
+      token_of_special c (get_buff len)
   | [< s >] ->
       match lookup_utf8 s with
       | Utf8Token (UnicodeLetter, n) ->
-	  ("FIELD", get_buff (ident_tail (nstore n 0 s) s))
-      | AsciiChar | Utf8Token _ | EmptyStream ->
-	  fst (process_chars bp c s)
+	  token_of_special c (get_buff (ident_tail (nstore n 0 s) s))
+      | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s)
 
 (* Parse what follows a question mark *)
+
 let parse_after_qmark bp s =
   match Stream.peek s with
-    |Some ('a'..'z' | 'A'..'Z' | '_') -> ("LEFTQMARK", "")
-    |None -> ("","?")
+    | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK
+    | None -> KEYWORD "?"
     | _ ->
 	match lookup_utf8 s with
-	  | Utf8Token (UnicodeLetter, _) -> ("LEFTQMARK", "")
+	  | Utf8Token (UnicodeLetter, _) -> LEFTQMARK
 	  | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s)
 
+let blank_or_eof cs =
+  match Stream.peek cs with
+    | None -> true
+    | Some (' ' | '\t' | '\n' |'\r') -> true
+    | _ -> false
 
 (* Parse a token in a char stream *)
+
 let rec next_token = parser bp
   | [< '' ' | '\t' | '\n' |'\r' as c; s >] ->
       comm_loc bp; push_char c; next_token s
-  | [< ''$'; t = parse_after_dollar bp >] ep ->
+  | [< ''$' as c; t = parse_after_special c bp >] ep ->
       comment_stop bp; (t, (ep, bp))
-  | [< ''.' as c; t = parse_after_dot bp c >] ep ->
+  | [< ''.' as c; t = parse_after_special c bp; s >] ep ->
       comment_stop bp;
-      if Flags.do_beautify() & t=("",".") then between_com := true;
+      (* We enforce that "." should either be part of a larger keyword,
+         for instance ".(", or followed by a blank or eof. *)
+      if t = KEYWORD "." then begin
+	if not (blank_or_eof s) then err (bp,ep+1) Undefined_token;
+	if Flags.do_beautify() then between_com := true;
+      end;
       (t, (bp,ep))
   | [< ''?'; s >] ep ->
       let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp))
@@ -456,13 +487,13 @@ let rec next_token = parser bp
        len = ident_tail (store 0 c); s >] ep ->
       let id = get_buff len in
       comment_stop bp;
-      (try ("", find_keyword id s) with Not_found -> ("IDENT", id)), (bp, ep)
+      (try find_keyword 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 false bp 0 >] ep ->
+      (INT (get_buff len), (bp, ep))
+  | [< ''\"'; len = string None bp 0 >] ep ->
       comment_stop bp;
-      (("STRING", get_buff len), (bp, ep))
+      (STRING (get_buff len), (bp, ep))
   | [< ' ('(' as c);
       t = parser
         | [< ''*'; s >] ->
@@ -479,62 +510,53 @@ 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 s) with Not_found -> ("IDENT",id)), (bp, ep)
+	    (try find_keyword id s with Not_found -> IDENT id), (bp, ep)
 	| AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) ->
 	    let t = process_chars bp (Stream.next s) s in
 	    comment_stop bp; t
 	| EmptyStream ->
-	    comment_stop bp; (("EOI", ""), (bp, bp + 1))
+	    comment_stop bp; (EOI, (bp, bp + 1))
+
+(* (* Debug: uncomment this for tracing tokens seen by coq...*)
+let next_token s =
+  let (t,(bp,ep)) = next_token s in Printf.eprintf "[%s]\n%!" (Tok.to_string t);
+  (t,(bp,ep))
+*)
 
 (* Location table system for creating tables associating a token count
    to its location in a char stream (the source) *)
 
 let locerr () = invalid_arg "Lexer: location function"
 
-let tsz = 256   (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *)
-
-let loct_create () = ref [| [| |] |]
+let loct_create () = Hashtbl.create 207
 
 let loct_func loct i =
-  match
-    if i < 0 || i/tsz >= Array.length !loct then None
-    else if !loct.(i/tsz) = [| |] then None
-    else !loct.(i/tsz).(i mod tsz)
-  with
-    | Some loc -> Util.make_loc loc
-    | _ -> locerr ()
-
-let loct_add loct i loc =
-  while i/tsz >= Array.length !loct do
-    let new_tmax = Array.length !loct * 2 in
-    let new_loct = Array.make new_tmax [| |] in
-    Array.blit !loct 0 new_loct 0 (Array.length !loct);
-    loct := new_loct;
-  done;
-  if !loct.(i/tsz) = [| |] then !loct.(i/tsz) <- Array.make tsz None;
-  !loct.(i/tsz).(i mod tsz) <- Some loc
-
-let current_location_table = ref (ref [| [| |] |])
-
-let location_function n =
-  loct_func !current_location_table n
+  try Hashtbl.find loct i with Not_found -> locerr ()
 
-let func cs =
-  let loct = loct_create () in
-  let ts =
-    Stream.from
-      (fun i ->
-         let (tok, loc) = next_token cs in
-	   loct_add loct i loc; Some tok)
-  in
-    current_location_table := loct;
-    (ts, loct_func loct)
+let loct_add loct i loc = Hashtbl.add loct i loc
+
+let current_location_table = ref (loct_create ())
 
-type location_table = (int * int) option array array ref
+type location_table = (int, loc) Hashtbl.t
 let location_table () = !current_location_table
 let restore_location_table t = current_location_table := t
+let location_function n = loct_func !current_location_table n
 
-(* Names of tokens, for this lexer, used in Grammar error messages *)
+(** {6 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
+
+type te = Tok.t
+
+(** Names of tokens, for this lexer, used in Grammar error messages *)
 
 let token_text = function
   | ("", t) -> "'" ^ t ^ "'"
@@ -547,43 +569,65 @@ let token_text = function
   | (con, "") -> con
   | (con, prm) -> con ^ " \"" ^ prm ^ "\""
 
-(* 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 func cs =
+  let loct = loct_create () in
+  let ts =
+    Stream.from
+      (fun i ->
+         let (tok, loc) = next_token cs in
+	 loct_add loct i (make_loc loc); Some tok)
+  in
+  current_location_table := loct;
+  (ts, loct_func loct)
 
 let lexer = {
   Token.tok_func = func;
-  Token.tok_using = add_token;
+  Token.tok_using =
+    (fun pat -> match Tok.of_pattern pat with
+       | KEYWORD s -> add_keyword s
+       | _ -> ());
   Token.tok_removing = (fun _ -> ());
-  Token.tok_match = default_match;
+  Token.tok_match = Tok.match_pattern;
   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 }
+ELSE (* official camlp4 for ocaml >= 3.10 *)
+
+module M_ = Camlp4.ErrorHandler.Register (Error)
+
+module Loc = Loc
+module Token = struct
+  include Tok (* Cf. tok.ml *)
+  module Loc = Loc
+  module Error = Camlp4.Struct.EmptyError
+  module Filter = struct
+    type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t
+    type t = unit
+    let mk _is_kwd = ()
+    let keyword_added () kwd _ = add_keyword kwd
+    let keyword_removed () _ = ()
+    let filter () x = x
+    let define_filter () _ = ()
+  end
+end
+
+let mk () _init_loc(*FIXME*) cs =
+  let loct = loct_create () in
+  let rec self =
+    parser i
+       [< (tok, loc) = next_token; s >] ->
+          let loc = make_loc loc in
+            loct_add loct i loc;
+            [< '(tok, loc); self s >]
+      | [< >] -> [< >]
+  in current_location_table := loct; self cs
 
 END
 
-(* Terminal symbols interpretation *)
+(** Terminal symbols interpretation *)
 
 let is_ident_not_keyword s =
-  match s.[0] with
-    | 'a'..'z' | 'A'..'Z' | '_' -> not (is_keyword s)
-    | _ -> false
+  is_ident s && not (is_keyword s)
 
 let is_number s =
   let rec aux i =
@@ -613,6 +657,6 @@ let strip s =
 let terminal s =
   let s = strip s in
   if s = "" then failwith "empty token";
-  if is_ident_not_keyword s then ("IDENT", s)
-  else if is_number s then ("INT", s)
-  else ("", s)
+  if is_ident_not_keyword s then IDENT s
+  else if is_number s then INT s
+  else KEYWORD s
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 93fc4231..1899f7f4 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -1,37 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lexer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 
-type error =
-  | Illegal_character
-  | Unterminated_comment
-  | Unterminated_string
-  | Undefined_token
-  | Bad_token of string
-
-exception Error of error
-
-val add_token : string * string -> unit
+val add_keyword : string -> unit
 val remove_keyword : string -> unit
 val is_keyword : string -> bool
 
 val location_function : int -> loc
 
-(* for coqdoc *)
+(** for coqdoc *)
 type location_table
 val location_table : unit -> location_table
 val restore_location_table : location_table -> unit
 
 val check_ident : string -> unit
+val is_ident : string -> bool
 val check_keyword : string -> unit
 
 type frozen_t
@@ -45,8 +35,8 @@ val restore_com_state: com_state -> unit
 
 val set_xml_output_comment : (string -> unit) -> unit
 
-val terminal : string -> string * string
+val terminal : string -> Tok.t
 
-(* The lexer of Coq *)
+(** The lexer of Coq: *)
 
-val lexer : Compat.lexer
+include Compat.LexerSig
diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib
index c0c1817d..84a08d54 100644
--- a/parsing/parsing.mllib
+++ b/parsing/parsing.mllib
@@ -6,7 +6,6 @@ G_xml
 Ppconstr
 Printer
 Pptactic
-Ppdecl_proof
 Tactic_printer
 Printmod
 Prettyp
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index ff5213ef..075440f1 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -1,77 +1,96 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*)
-
-(*i $Id: pcoq.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
+open Compat
+open Tok
 open Util
 open Names
 open Extend
 open Libnames
-open Rawterm
+open Glob_term
 open Topconstr
 open Genarg
 open Tacexpr
 open Extrawit
 open Ppextend
 
-(* The parser of Coq *)
+(** The parser of Coq *)
+
+module G = GrammarMake (Lexer)
+
+(* TODO: this is a workaround, since there isn't such
+   [warning_verbose] in new camlp4. In camlp5, this ref
+   gets hidden by [Gramext.warning_verbose] *)
+let warning_verbose = ref true
 
 IFDEF CAMLP5 THEN
+open Gramext
+ELSE
+open G
+END
 
-module L =
-  struct
-    type te = string * string
-    let lexer = Lexer.lexer
-  end
+(** Compatibility with Camlp5 6.x *)
 
-module G = Grammar.GMake(L)
+IFDEF CAMLP5_6_00 THEN
+let slist0sep x y = Slist0sep (x, y, false)
+let slist1sep x y = Slist1sep (x, y, false)
+ELSE
+let slist0sep x y = Slist0sep (x, y)
+let slist1sep x y = Slist1sep (x, y)
+END
 
+let gram_token_of_token tok =
+IFDEF CAMLP5 THEN
+ Stoken (Tok.to_pattern tok)
 ELSE
+ match tok with
+  | KEYWORD s -> Skeyword s
+  | tok -> Stoken ((=) tok, to_string tok)
+END
 
-module L =
-  struct
-    let lexer = Lexer.lexer
-  end
+let gram_token_of_string s = gram_token_of_token (Lexer.terminal s)
 
-module G = Grammar.Make(L)
+let camlp4_verbosity silent f x =
+  let a = !warning_verbose in
+  warning_verbose := silent;
+  f x;
+  warning_verbose := a
 
-END
+let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x
 
-let grammar_delete e pos reinit rls =
-  List.iter
-    (fun (n,ass,lev) ->
 
-      (* Caveat: deletion is not the converse of extension: when an
-	 empty level is extended, deletion removes the level instead
-	 of keeping it empty. This has an effect on the empty levels 8,
-	 99 and 200. We didn't find a good solution to this problem
-	 (e.g. using G.extend to know if the level exists results in a
-	 printed error message as side effect). As a consequence an
-	 extension at 99 or 8 (and for pattern 200 too) inside a section
-         corrupts the parser. *)
+(** General entry keys *)
 
-      List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
-    (List.rev 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
-      else Gramext.After (string_of_int (int_of_string lev + 1)) in
-    G.extend e (Some pos) [Some lev,reinit,[]];
+(** This intermediate abstract representation of entries can
+   both be reified into mlexpr for the ML extensions and
+   dynamically interpreted as entries for the Coq level extensions
+*)
+
+type prod_entry_key =
+  | Alist1 of prod_entry_key
+  | Alist1sep of prod_entry_key * string
+  | Alist0 of prod_entry_key
+  | Alist0sep of prod_entry_key * string
+  | Aopt of prod_entry_key
+  | Amodifiers of prod_entry_key
+  | Aself
+  | Anext
+  | Atactic of int
+  | Agram of G.internal_entry
+  | Aentry of string * string
+
+(** [grammar_object] is the superclass of all grammar entries *)
 
-(* grammar_object is the superclass of all grammar entries *)
 module type Gramobj =
 sig
   type grammar_object
-  val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e
+  val weaken_entry : 'a G.entry -> grammar_object G.entry
 end
 
 module Gramobj : Gramobj =
@@ -80,9 +99,11 @@ struct
   let weaken_entry e = Obj.magic e
 end
 
+(** Grammar entries with associated types *)
+
 type entry_type = argument_type
 type grammar_object = Gramobj.grammar_object
-type typed_entry = argument_type * grammar_object G.Entry.e
+type typed_entry = argument_type * grammar_object G.entry
 let in_typed_entry t e = (t,Gramobj.weaken_entry e)
 let type_of_typed_entry (t,e) = t
 let object_of_typed_entry (t,e) = e
@@ -91,8 +112,8 @@ let weaken_entry x = Gramobj.weaken_entry x
 module type Gramtypes =
 sig
   open Decl_kinds
-  val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry
-  val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e
+  val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry
+  val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry
 end
 
 module Gramtypes : Gramtypes =
@@ -107,82 +128,107 @@ end
 
 open Gramtypes
 
-type camlp4_rule =
-    Compat.token Gramext.g_symbol list * Gramext.g_action
+(** Grammar extensions *)
+
+(** NB: [extend_statment =
+         gram_position option * single_extend_statment list]
+    and [single_extend_statment =
+         string option * gram_assoc option * production_rule list]
+    and [production_rule = symbol list * action]
 
-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
+    In [single_extend_statement], first two parameters are name and
+    assoc iff a level is created *)
 
 type ext_kind =
   | ByGrammar of
-      grammar_object G.Entry.e * Gramext.position option *
-      camlp4_entry_rules list * Gramext.g_assoc option
-  | ByGEXTEND of (unit -> unit) * (unit -> unit)
+      grammar_object G.entry
+      * gram_assoc option (** for reinitialization if ever needed *)
+      * G.extend_statment
+  | ByEXTEND of (unit -> unit) * (unit -> unit)
+
+(** The list of extensions *)
 
 let camlp4_state = ref []
 
-(* The apparent parser of Coq; encapsulate G to keep track of the
-   extensions. *)
+(** Deletion
+
+   Caveat: deletion is not the converse of extension: when an
+   empty level is extended, deletion removes the level instead
+   of keeping it empty. This has an effect on the empty levels 8,
+   99 and 200. We didn't find a good solution to this problem
+   (e.g. using G.extend to know if the level exists results in a
+   printed error message as side effect). As a consequence an
+   extension at 99 or 8 (and for pattern 200 too) inside a section
+   corrupts the parser. *)
+
+let grammar_delete e reinit (pos,rls) =
+  List.iter
+    (fun (n,ass,lev) ->
+      List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
+    (List.rev rls);
+  if reinit <> None then
+    let lev = match pos with Some (Level n) -> n | _ -> assert false in
+    let pos =
+      if lev = "200" then First
+      else After (string_of_int (int_of_string lev + 1)) in
+    maybe_uncurry (G.extend e) (Some pos, [Some lev,reinit,[]])
+
+(** The apparent parser of Coq; encapsulate G to keep track
+    of the extensions. *)
+
 module Gram =
   struct
     include G
-    let extend e pos rls =
-      camlp4_state :=
-      (ByGEXTEND ((fun () -> grammar_delete e pos None rls),
-                  (fun () -> G.extend e pos rls)))
-      :: !camlp4_state;
-      G.extend e pos rls
+    let extend e =
+      maybe_curry
+	(fun ext ->
+	   camlp4_state :=
+	     (ByEXTEND ((fun () -> grammar_delete e None ext),
+			(fun () -> maybe_uncurry (G.extend e) ext)))
+	   :: !camlp4_state;
+	   maybe_uncurry (G.extend e) ext)
     let delete_rule e pil =
       (* spiwack: if you use load an ML module which contains GDELETE_RULE
 	  in a section, God kills a kitty. As it would corrupt remove_grammars.
           There does not seem to be a good way to undo a delete rule. As deleting
 	  takes fewer arguments than extending. The production rule isn't returned
 	  by delete_rule. If we could retrieve the necessary information, then
-	  ByGEXTEND provides just the framework we need to allow this in section.
+	  ByEXTEND provides just the framework we need to allow this in section.
 	  I'm not entirely sure it makes sense, but at least it would be more correct.
           *)
       G.delete_rule e pil
   end
 
-IFDEF CAMLP5_6_02_1 THEN
-let entry_print x = Gram.Entry.print !Pp_control.std_ft x
-ELSE
-let entry_print = Gram.Entry.print
-END
+(** This extension command is used by the Grammar constr *)
 
-let camlp4_verbosity silent f x =
-  let a = !Gramext.warning_verbose in
-  Gramext.warning_verbose := silent;
-  f x;
-  Gramext.warning_verbose := a
-
-(* This extension command is used by the Grammar constr *)
+let grammar_extend e reinit ext =
+  camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state;
+  camlp4_verbose (maybe_uncurry (G.extend e)) ext
 
-let grammar_extend te pos reinit rls =
-  camlp4_state := ByGrammar (weaken_entry te,pos,rls,reinit) :: !camlp4_state;
-  camlp4_verbosity (Flags.is_verbose ()) (G.extend te pos) rls
+(** Remove extensions
 
-(* n is the number of extended entries (not the number of Grammar commands!)
+   [n] is the number of extended entries (not the number of Grammar commands!)
    to remove. *)
+
 let rec remove_grammars n =
   if n>0 then
     (match !camlp4_state with
        | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove"
-       | ByGrammar(g,pos,rls,reinit)::t ->
-           grammar_delete g pos reinit rls;
+       | ByGrammar(g,reinit,ext)::t ->
+           grammar_delete g reinit ext;
            camlp4_state := t;
            remove_grammars (n-1)
-       | ByGEXTEND (undo,redo)::t ->
+       | ByEXTEND (undo,redo)::t ->
            undo();
            camlp4_state := t;
            remove_grammars n;
            redo();
-           camlp4_state := ByGEXTEND (undo,redo) :: !camlp4_state)
+           camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state)
+
+(** An entry that checks we reached the end of the input. *)
 
-(* An entry that checks we reached the end of the input. *)
 let eoi_entry en =
-  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_eoi") in
+  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in
   GEXTEND Gram
     e: [ [ x = en; EOI -> x ] ]
     ;
@@ -190,7 +236,7 @@ let eoi_entry en =
   e
 
 let map_entry f en =
-  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_map") in
+  let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in
   GEXTEND Gram
     e: [ [ x = en -> f x ] ]
     ;
@@ -201,7 +247,7 @@ let map_entry f en =
    (use eoi_entry) *)
 
 let parse_string f x =
-  let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm)
+  let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm)
 
 type gram_universe = string * (string, typed_entry) Hashtbl.t
 
@@ -228,17 +274,10 @@ let get_univ s =
 
 let get_entry (u, utab) s = Hashtbl.find utab s
 
-let get_entry_type (u, utab) s =
-  try
-    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
+  let e = in_typed_entry etyp (Gram.entry_create ename) in
   Hashtbl.add utab s e; e
 
 let create_entry (u, utab) s etyp =
@@ -257,10 +296,10 @@ 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 *)
+(* For entries extensible only via the ML name, Gram.entry_create is enough *)
 
 let make_gen_entry (u,univ) rawwit s =
-  let e = Gram.Entry.create (u ^ ":" ^ s) in
+  let e = Gram.entry_create (u ^ ":" ^ s) in
   Hashtbl.add univ s (inGramObj rawwit e); e
 
 (* Initial grammar entries *)
@@ -269,44 +308,43 @@ module Prim =
   struct
     let gec_gen x = make_gen_entry uprim x
 
-    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Entries that can be refered via the string -> Gram.entry table *)
     (* Typically for tactic or vernac extensions *)
     let preident = gec_gen rawwit_pre_ident "preident"
     let ident = gec_gen rawwit_ident "ident"
     let natural = gec_gen rawwit_int "natural"
     let integer = gec_gen rawwit_int "integer"
-    let bigint = Gram.Entry.create "Prim.bigint"
+    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"
+    let by_notation = Gram.entry_create "by_notation"
+    let smart_global = Gram.entry_create "smart_global"
 
     (* parsed like ident but interpreted as a term *)
     let var = gec_gen rawwit_var "var"
 
-    let name = Gram.Entry.create "Prim.name"
-    let identref = Gram.Entry.create "Prim.identref"
+    let name = Gram.entry_create "Prim.name"
+    let identref = Gram.entry_create "Prim.identref"
     let pattern_ident = gec_gen rawwit_pattern_ident "pattern_ident"
-    let pattern_identref = Gram.Entry.create "pattern_identref"
+    let pattern_identref = Gram.entry_create "pattern_identref"
 
     (* A synonym of ident - maybe ident will be located one day *)
-    let base_ident = Gram.Entry.create "Prim.base_ident"
+    let base_ident = Gram.entry_create "Prim.base_ident"
 
-    let qualid = Gram.Entry.create "Prim.qualid"
-    let fullyqualid = Gram.Entry.create "Prim.fullyqualid"
-    let dirpath = Gram.Entry.create "Prim.dirpath"
+    let qualid = Gram.entry_create "Prim.qualid"
+    let fullyqualid = Gram.entry_create "Prim.fullyqualid"
+    let dirpath = Gram.entry_create "Prim.dirpath"
 
-    let ne_string = Gram.Entry.create "Prim.ne_string"
-    let ne_lstring = Gram.Entry.create "Prim.ne_lstring"
+    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
-    let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr)
 
-    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Entries that can be refered via the string -> Gram.entry table *)
     let constr = gec_constr "constr"
     let operconstr = gec_constr "operconstr"
     let constr_eoi = eoi_entry constr
@@ -315,31 +353,31 @@ module 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 pattern = Gram.entry_create "constr:pattern"
     let constr_pattern = gec_constr "constr_pattern"
     let lconstr_pattern = gec_constr "lconstr_pattern"
-    let closed_binder = Gram.Entry.create "constr:closed_binder"
-    let binder = Gram.Entry.create "constr:binder"
-    let binders = Gram.Entry.create "constr:binders"
-    let open_binders = Gram.Entry.create "constr:open_binders"
-    let binders_fixannot = Gram.Entry.create "constr:binders_fixannot"
-    let typeclass_constraint = Gram.Entry.create "constr:typeclass_constraint"
-    let record_declaration = Gram.Entry.create "constr:record_declaration"
-    let appl_arg = Gram.Entry.create "constr:appl_arg"
+    let closed_binder = Gram.entry_create "constr:closed_binder"
+    let binder = Gram.entry_create "constr:binder"
+    let binders = Gram.entry_create "constr:binders"
+    let open_binders = Gram.entry_create "constr:open_binders"
+    let binders_fixannot = Gram.entry_create "constr:binders_fixannot"
+    let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint"
+    let record_declaration = Gram.entry_create "constr:record_declaration"
+    let appl_arg = Gram.entry_create "constr:appl_arg"
   end
 
 module Module =
   struct
-    let module_expr = Gram.Entry.create "module_expr"
-    let module_type = Gram.Entry.create "module_type"
+    let module_expr = Gram.entry_create "module_expr"
+    let module_type = Gram.entry_create "module_type"
   end
 
 module Tactic =
   struct
     (* Main entry for extensions *)
-    let simple_tactic = Gram.Entry.create "tactic:simple_tactic"
+    let simple_tactic = Gram.entry_create "tactic:simple_tactic"
 
-    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Entries that can be refered via the string -> Gram.entry table *)
     (* Typically for tactic user extensions *)
     let open_constr =
       make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr"
@@ -358,9 +396,9 @@ module Tactic =
       make_gen_entry utactic rawwit_intro_pattern "simple_intropattern"
 
     (* Main entries for ltac *)
-    let tactic_arg = Gram.Entry.create "tactic:tactic_arg"
-    let tactic_expr = Gram.Entry.create "tactic:tactic_expr"
-    let binder_tactic = Gram.Entry.create "tactic:binder_tactic"
+    let tactic_arg = Gram.entry_create "tactic:tactic_arg"
+    let tactic_expr = Gram.entry_create "tactic:tactic_expr"
+    let binder_tactic = Gram.entry_create "tactic:binder_tactic"
 
     let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic"
 
@@ -371,7 +409,7 @@ module Tactic =
 
 module Vernac_ =
   struct
-    let gec_vernac s = Gram.Entry.create ("vernac:" ^ s)
+    let gec_vernac s = Gram.entry_create ("vernac:" ^ s)
 
     (* The different kinds of vernacular commands *)
     let gallina = gec_vernac "gallina"
@@ -379,12 +417,11 @@ module Vernac_ =
     let command = gec_vernac "command"
     let syntax = gec_vernac "syntax_command"
     let vernac = gec_vernac "Vernac.vernac"
-    let proof_instr = Gram.Entry.create "proofmode:instr"
-
     let vernac_eoi = eoi_entry vernac
-
+    let rec_definition = gec_vernac "Vernac.rec_definition"
     (* Main vernac entry *)
-    let main_entry = Gram.Entry.create "vernac"
+    let main_entry = Gram.entry_create "vernac"
+
     GEXTEND Gram
     main_entry:
       [ [ a = vernac -> Some (loc,a) | EOI -> None ] ]
@@ -411,23 +448,24 @@ let main_entry = Vernac_.main_entry
 let constr_level = string_of_int
 
 let default_levels =
-  [200,Gramext.RightA,false;
-   100,Gramext.RightA,false;
-   99,Gramext.RightA,true;
-   90,Gramext.RightA,false;
-   10,Gramext.RightA,false;
-   9,Gramext.RightA,false;
-   8,Gramext.RightA,true;
-   1,Gramext.LeftA,false;
-   0,Gramext.RightA,false]
+  [200,RightA,false;
+   100,RightA,false;
+   99,RightA,true;
+   90,RightA,false;
+   10,RightA,false;
+   9,RightA,false;
+   8,RightA,true;
+   1,LeftA,false;
+   0,RightA,false]
 
 let default_pattern_levels =
-  [200,Gramext.RightA,true;
-   100,Gramext.RightA,false;
-   99,Gramext.RightA,true;
-   10,Gramext.LeftA,false;
-   1,Gramext.LeftA,false;
-   0,Gramext.RightA,false]
+  [200,RightA,true;
+   100,RightA,false;
+   99,RightA,true;
+   10,LeftA,false;
+   9,RightA,false;
+   1,LeftA,false;
+   0,RightA,false]
 
 let level_stack =
   ref [(default_levels, default_pattern_levels)]
@@ -438,19 +476,19 @@ let level_stack =
 open Ppextend
 
 let admissible_assoc = function
-  | Gramext.LeftA, Some (Gramext.RightA | Gramext.NonA) -> false
-  | Gramext.RightA, Some Gramext.LeftA -> false
+  | LeftA, Some (RightA | NonA) -> false
+  | RightA, Some LeftA -> false
   | _ -> true
 
 let create_assoc = function
-  | None -> Gramext.RightA
+  | None -> RightA
   | Some a -> a
 
 let error_level_assoc p current expected =
   let pr_assoc = function
-    | Gramext.LeftA -> str "left"
-    | Gramext.RightA -> str "right"
-    | Gramext.NonA -> str "non" in
+    | LeftA -> str "left"
+    | RightA -> str "right"
+    | NonA -> str "non" in
   errorlabstrm ""
     (str "Level " ++ int p ++ str " is already declared " ++
      pr_assoc current ++ str " associative while it is now expected to be " ++
@@ -484,18 +522,18 @@ let find_position_gen forpat ensure assoc lev =
 	let assoc = create_assoc assoc in
         if !init = None then
 	  (* Create the entry *)
-	  (if !after = None then Some Gramext.First
-	   else Some (Gramext.After (constr_level (Option.get !after)))),
+	  (if !after = None then Some First
+	   else Some (After (constr_level (Option.get !after)))),
 	   Some assoc, Some (constr_level n), None
         else
 	  (* The reinit flag has been updated *)
-	   Some (Gramext.Level (constr_level n)), None, None, !init
+	   Some (Level (constr_level n)), None, None, !init
       with
 	  (* Nothing has changed *)
           Exit ->
             level_stack := current :: !level_stack;
 	    (* Just inherit the existing associativity and name (None) *)
-	    Some (Gramext.Level (constr_level n)), None, None, None
+	    Some (Level (constr_level n)), None, None, None
 
 let remove_levels n =
   level_stack := list_skipn n !level_stack
@@ -524,8 +562,8 @@ let synchronize_level_positions () =
 
 (* 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
-  | None | Some Gramext.LeftA -> Gramext.LeftA
+  | Some NonA | Some RightA -> RightA
+  | None | Some LeftA -> LeftA
 
 (* [adjust_level assoc from prod] where [assoc] and [from] are the name
    and associativity of the level where to add the rule; the meaning of
@@ -540,20 +578,20 @@ let adjust_level assoc from = function
   | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true))
 (* Compute production name on the right side *)
   (* If NonA or LeftA on the right-hand side, set to NEXT *)
-  | (NumLevel n,BorderProd (Right,Some (Gramext.NonA|Gramext.LeftA))) ->
+  | (NumLevel n,BorderProd (Right,Some (NonA|LeftA))) ->
       Some None
   (* If RightA on the right-hand side, set to the explicit (current) level *)
-  | (NumLevel n,BorderProd (Right,Some Gramext.RightA)) ->
+  | (NumLevel n,BorderProd (Right,Some RightA)) ->
       Some (Some (n,true))
 (* Compute production name on the left side *)
   (* If NonA on the left-hand side, adopt the current assoc ?? *)
-  | (NumLevel n,BorderProd (Left,Some Gramext.NonA)) -> None
+  | (NumLevel n,BorderProd (Left,Some NonA)) -> None
   (* If the expected assoc is the current one, set to SELF *)
   | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc ->
       None
   (* Otherwise, force the level, n or n-1, according to expected assoc *)
   | (NumLevel n,BorderProd (Left,Some a)) ->
-      if a = Gramext.LeftA then Some (Some (n,true)) else Some None
+      if a = LeftA then Some (Some (n,true)) else Some None
   (* None means NEXT *)
   | (NextLevel,_) -> Some None
 (* Compute production name elsewhere *)
@@ -604,7 +642,7 @@ let interp_constr_prod_entry_key ass from forpat en =
 let is_self from e =
   match from, e with
       ETConstr(n,()), ETConstr(NumLevel n',
-        BorderProd(Right, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false
+        BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false
     | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n'
     | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint
       | ETPattern, ETPattern) -> true
@@ -618,69 +656,73 @@ let is_binder_level from e =
     | _ -> false
 
 let make_sep_rules tkl =
-  Gramext.srules
-    [List.map (fun x -> Gramext.Stoken x) tkl,
-     List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
-       (Gramext.action (fun loc -> ()))]
+  Gram.srules'
+    [List.map gram_token_of_token tkl,
+     List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl
+       (Gram.action (fun loc -> ()))]
 
 let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
   if is_binder_level from typ then
     if forpat then
-      Gramext.Snterml (Gram.Entry.obj Constr.pattern,"200")
+      Snterml (Gram.Entry.obj Constr.pattern,"200")
     else
-      Gramext.Snterml (Gram.Entry.obj Constr.operconstr,"200")
+      Snterml (Gram.Entry.obj Constr.operconstr,"200")
   else if is_self from typ then
-    Gramext.Sself
+      Sself
   else
     match typ with
     | ETConstrList (typ',[]) ->
-        Gramext.Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
+        Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
     | ETConstrList (typ',tkl) ->
-        Compat.slist1sep
+        slist1sep
           (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
           (make_sep_rules tkl)
     | ETBinderList (false,[]) ->
-        Gramext.Slist1
+        Slist1
 	  (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
     | ETBinderList (false,tkl) ->
-        Compat.slist1sep
+        slist1sep
           (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
           (make_sep_rules tkl)
+
     | _ ->
     match interp_constr_prod_entry_key assoc from forpat typ with
-      | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj)
-      | (eobj,Some None,_) -> Gramext.Snext
+      | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj)
+      | (eobj,Some None,_) -> Snext
       | (eobj,Some (Some (lev,cur)),_) ->
-          Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev)
+          Snterml (Gram.Entry.obj eobj,constr_level lev)
 
-(**********************************************************************)
-(* Binding general entry keys to symbol                               *)
+(** Binding general entry keys to symbol *)
 
 let rec symbol_of_prod_entry_key = function
-  | Alist1 s -> Gramext.Slist1 (symbol_of_prod_entry_key s)
+  | Alist1 s -> Slist1 (symbol_of_prod_entry_key s)
   | Alist1sep (s,sep) ->
-      Compat.slist1sep (symbol_of_prod_entry_key s) (Gramext.Stoken ("", sep))
-  | Alist0 s -> Gramext.Slist0 (symbol_of_prod_entry_key s)
+      slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
+  | Alist0 s -> Slist0 (symbol_of_prod_entry_key s)
   | Alist0sep (s,sep) ->
-      Compat.slist0sep (symbol_of_prod_entry_key s) (Gramext.Stoken ("", sep))
-  | Aopt s -> Gramext.Sopt (symbol_of_prod_entry_key s)
+      slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
+  | Aopt s -> Sopt (symbol_of_prod_entry_key s)
   | Amodifiers s ->
-       Gramext.srules
-        [([], Gramext.action(fun _loc -> []));
-         ([Gramext.Stoken ("", "(");
-           Compat.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)
+       Gram.srules'
+        [([], Gram.action (fun _loc -> []));
+         ([gram_token_of_string "(";
+           slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string ",");
+           gram_token_of_string ")"],
+	   Gram.action (fun _ l _ _loc -> l))]
+  | Aself -> Sself
+  | Anext -> Snext
+  | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic)
   | Atactic n ->
-      Gramext.Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
-  | Agram s -> Gramext.Snterm s
+      Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
+  | Agram s -> Snterm s
   | Aentry (u,s) ->
-      Gramext.Snterm (Gram.Entry.obj
+      Snterm (Gram.Entry.obj
 	(object_of_typed_entry (get_entry (get_univ u) s)))
 
+let level_of_snterml = function
+  | Snterml (_,l) -> int_of_string l
+  | _ -> failwith "level_of_snterml"
+
 (**********************************************************************)
 (* Interpret entry names of the form "ne_constr_list" as entry keys   *)
 
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 61d8f4f6..bba0e560 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -1,32 +1,28 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Names
-open Rawterm
+open Glob_term
 open Extend
 open Vernacexpr
 open Genarg
 open Topconstr
 open Tacexpr
 open Libnames
+open Compat
 
-(**********************************************************************)
-(* The parser of Coq                                                  *)
+(** The parser of Coq *)
 
-module Gram : Grammar.S with type te = Compat.token
+module Gram : GrammarSig
 
-val entry_print : 'a Gram.Entry.e -> unit
+(** The parser of Coq is built from three kinds of rule declarations:
 
-(**********************************************************************)
-(* 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
@@ -34,7 +30,7 @@ val entry_print : 'a Gram.Entry.e -> unit
      VERNAC EXTEND (see e.g. file extratactics.ml4)
 *)
 
-(* Dynamic extension of rules
+(** Dynamic extension of rules
 
     For constr notations, dynamic addition of new rules is done in
     several steps:
@@ -100,54 +96,49 @@ val entry_print : 'a Gram.Entry.e -> unit
 
 *)
 
-(* The superclass of all grammar entries *)
-type grammar_object
-
-type camlp4_rule =
-    Compat.token Gramext.g_symbol list * Gramext.g_action
+val gram_token_of_token : Tok.t -> Gram.symbol
+val gram_token_of_string : string -> Gram.symbol
 
-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
+(** The superclass of all grammar entries *)
+type grammar_object
 
-(* Add one extension at some camlp4 position of some camlp4 entry *)
+(** 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
+  grammar_object Gram.entry ->
+  gram_assoc option (** for reinitialization if ever needed *) ->
+  Gram.extend_statment -> unit
 
-(* Remove the last n extensions *)
+(** Remove the last n extensions *)
 val remove_grammars : int -> unit
 
 
 
 
-(* The type of typed grammar objects *)
+(** The type of typed grammar objects *)
 type typed_entry
 
-(* The possible types for extensible grammars *)
+(** 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 object_of_typed_entry : typed_entry -> grammar_object Gram.entry
+val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry
 
-(* Temporary activate camlp4 verbosity *)
+(** Temporary activate camlp4 verbosity *)
 
 val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
 
-(* Parse a string *)
+(** Parse a string *)
 
-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
+val parse_string : 'a Gram.entry -> string -> 'a
+val eoi_entry : 'a Gram.entry -> 'a Gram.entry
+val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry
 
-(**********************************************************************)
-(* Table of Coq statically defined grammar entries                    *)
+(** Table of Coq statically defined grammar entries *)
 
 type gram_universe
 
-(* There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
+(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
 
 val get_univ : string -> gram_universe
 
@@ -156,142 +147,156 @@ val uconstr : gram_universe
 val utactic : gram_universe
 val uvernac : gram_universe
 
-(*
-val get_entry : gram_universe -> string -> typed_entry
-val get_entry_type : gram_universe -> string -> entry_type
-*)
-
 val create_entry : gram_universe -> string -> entry_type -> typed_entry
 val create_generic_entry : string -> ('a, rlevel) abstract_argument_type ->
-  'a Gram.Entry.e
+  'a Gram.entry
 
 module Prim :
   sig
     open Util
     open Names
     open Libnames
-    val preident : string Gram.Entry.e
-    val ident : identifier Gram.Entry.e
-    val name : name located Gram.Entry.e
-    val identref : identifier located Gram.Entry.e
-    val pattern_ident : identifier Gram.Entry.e
-    val pattern_identref : identifier located Gram.Entry.e
-    val base_ident : identifier Gram.Entry.e
-    val natural : int Gram.Entry.e
-    val bigint : Bigint.bigint Gram.Entry.e
-    val integer : int Gram.Entry.e
-    val string : string Gram.Entry.e
-    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
+    val preident : string Gram.entry
+    val ident : identifier Gram.entry
+    val name : name located Gram.entry
+    val identref : identifier located Gram.entry
+    val pattern_ident : identifier Gram.entry
+    val pattern_identref : identifier located Gram.entry
+    val base_ident : identifier Gram.entry
+    val natural : int Gram.entry
+    val bigint : Bigint.bigint Gram.entry
+    val integer : int Gram.entry
+    val string : string Gram.entry
+    val qualid : qualid located Gram.entry
+    val fullyqualid : identifier list located Gram.entry
+    val reference : reference Gram.entry
+    val by_notation : (loc * string * string option) Gram.entry
+    val smart_global : reference or_by_notation Gram.entry
+    val dirpath : dir_path Gram.entry
+    val ne_string : string Gram.entry
+    val ne_lstring : string located Gram.entry
+    val var : identifier located Gram.entry
   end
 
 module Constr :
   sig
-    val constr : constr_expr Gram.Entry.e
-    val constr_eoi : constr_expr Gram.Entry.e
-    val lconstr : constr_expr Gram.Entry.e
-    val binder_constr : constr_expr Gram.Entry.e
-    val operconstr : constr_expr Gram.Entry.e
-    val ident : identifier Gram.Entry.e
-    val global : reference Gram.Entry.e
-    val sort : rawsort Gram.Entry.e
-    val pattern : cases_pattern_expr Gram.Entry.e
-    val constr_pattern : constr_expr Gram.Entry.e
-    val lconstr_pattern : constr_expr Gram.Entry.e
-    val closed_binder : local_binder list Gram.Entry.e
-    val binder : local_binder list Gram.Entry.e (* closed_binder or variable *)
-    val binders : local_binder list Gram.Entry.e
-    val open_binders : local_binder list Gram.Entry.e
-    val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e
-    val typeclass_constraint : (name located * bool * constr_expr) Gram.Entry.e
-    val record_declaration : constr_expr Gram.Entry.e
-    val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e
+    val constr : constr_expr Gram.entry
+    val constr_eoi : constr_expr Gram.entry
+    val lconstr : constr_expr Gram.entry
+    val binder_constr : constr_expr Gram.entry
+    val operconstr : constr_expr Gram.entry
+    val ident : identifier Gram.entry
+    val global : reference Gram.entry
+    val sort : glob_sort Gram.entry
+    val pattern : cases_pattern_expr Gram.entry
+    val constr_pattern : constr_expr Gram.entry
+    val lconstr_pattern : constr_expr Gram.entry
+    val closed_binder : local_binder list Gram.entry
+    val binder : local_binder list Gram.entry (* closed_binder or variable *)
+    val binders : local_binder list Gram.entry (* list of binder *)
+    val open_binders : local_binder list Gram.entry
+    val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry
+    val typeclass_constraint : (name located * bool * constr_expr) Gram.entry
+    val record_declaration : constr_expr Gram.entry
+    val appl_arg : (constr_expr * explicitation located option) Gram.entry
   end
 
 module Module :
   sig
-    val module_expr : module_ast Gram.Entry.e
-    val module_type : module_ast Gram.Entry.e
+    val module_expr : module_ast Gram.entry
+    val module_type : module_ast Gram.entry
   end
 
 module Tactic :
   sig
-    open Rawterm
-    val open_constr : open_constr_expr Gram.Entry.e
-    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,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
-    val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e
-    val simple_intropattern : Genarg.intro_pattern_expr located Gram.Entry.e
-    val tactic_arg : raw_tactic_arg Gram.Entry.e
-    val tactic_expr : raw_tactic_expr Gram.Entry.e
-    val binder_tactic : raw_tactic_expr Gram.Entry.e
-    val tactic : raw_tactic_expr Gram.Entry.e
-    val tactic_eoi : raw_tactic_expr Gram.Entry.e
+    open Glob_term
+    val open_constr : open_constr_expr Gram.entry
+    val casted_open_constr : open_constr_expr Gram.entry
+    val constr_with_bindings : constr_expr with_bindings Gram.entry
+    val bindings : constr_expr bindings Gram.entry
+    val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry
+    val quantified_hypothesis : quantified_hypothesis Gram.entry
+    val int_or_var : int or_var Gram.entry
+    val red_expr : raw_red_expr Gram.entry
+    val simple_tactic : raw_atomic_tactic_expr Gram.entry
+    val simple_intropattern : Genarg.intro_pattern_expr located Gram.entry
+    val tactic_arg : raw_tactic_arg Gram.entry
+    val tactic_expr : raw_tactic_expr Gram.entry
+    val binder_tactic : raw_tactic_expr Gram.entry
+    val tactic : raw_tactic_expr Gram.entry
+    val tactic_eoi : raw_tactic_expr Gram.entry
   end
 
 module Vernac_ :
   sig
     open Decl_kinds
-    val gallina : vernac_expr Gram.Entry.e
-    val gallina_ext : vernac_expr Gram.Entry.e
-    val command : vernac_expr Gram.Entry.e
-    val syntax : vernac_expr Gram.Entry.e
-    val vernac : vernac_expr Gram.Entry.e
-    val vernac_eoi : vernac_expr Gram.Entry.e
-    val proof_instr : Decl_expr.raw_proof_instr Gram.Entry.e
+    val gallina : vernac_expr Gram.entry
+    val gallina_ext : vernac_expr Gram.entry
+    val command : vernac_expr Gram.entry
+    val syntax : vernac_expr Gram.entry
+    val vernac : vernac_expr Gram.entry
+    val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry
+    val vernac_eoi : vernac_expr Gram.entry
   end
 
-(* The main entry: reads an optional vernac command *)
-val main_entry : (loc * vernac_expr) option Gram.Entry.e
+(** The main entry: reads an optional vernac command *)
+val main_entry : (loc * vernac_expr) option Gram.entry
 
-(**********************************************************************)
-(* Mapping formal entries into concrete ones                          *)
+(** Mapping formal entries into concrete ones *)
 
-(* Binding constr entry keys to entries and symbols *)
+(** Binding constr entry keys to entries and symbols *)
 
-val interp_constr_entry_key : bool (* true for cases_pattern *) ->
-  constr_entry_key -> grammar_object Gram.Entry.e * int option
+val interp_constr_entry_key : bool (** true for cases_pattern *) ->
+  constr_entry_key -> grammar_object Gram.entry * int option
 
-val symbol_of_constr_prod_entry_key : Gramext.g_assoc option ->
+val symbol_of_constr_prod_entry_key : gram_assoc option ->
   constr_entry_key -> bool -> constr_prod_entry_key ->
-    Compat.token Gramext.g_symbol
+    Gram.symbol
+
+(** General entry keys *)
 
-(* Binding general entry keys to symbols *)
+(** This intermediate abstract representation of entries can
+   both be reified into mlexpr for the ML extensions and
+   dynamically interpreted as entries for the Coq level extensions
+*)
+
+type prod_entry_key =
+  | Alist1 of prod_entry_key
+  | Alist1sep of prod_entry_key * string
+  | Alist0 of prod_entry_key
+  | Alist0sep of prod_entry_key * string
+  | Aopt of prod_entry_key
+  | Amodifiers of prod_entry_key
+  | Aself
+  | Anext
+  | Atactic of int
+  | Agram of Gram.internal_entry
+  | Aentry of string * string
+
+(** Binding general entry keys to symbols *)
 
 val symbol_of_prod_entry_key :
-  Gram.te prod_entry_key -> Gram.te Gramext.g_symbol
+  prod_entry_key -> Gram.symbol
 
-(**********************************************************************)
-(* Interpret entry names of the form "ne_constr_list" as entry keys   *)
+(** 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
+val interp_entry_name : bool (** true to fail on unknown entry *) ->
+  int option -> string -> string -> entry_type * prod_entry_key
 
-(**********************************************************************)
-(* Registering/resetting the level of a constr entry                  *)
+(** 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 *
-    (* for reinitialization: *) Gramext.g_assoc option
+  bool (** true if for creation in pattern entry; false if in constr entry *) ->
+  gram_assoc option -> int option ->
+    gram_position option * gram_assoc option * string option *
+    (** for reinitialization: *) gram_assoc option
 
 val synchronize_level_positions : unit -> unit
 
 val register_empty_levels : bool -> int list ->
-    (Gramext.position option * Gramext.g_assoc option *
-     string option * Gramext.g_assoc option) list
+    (gram_position option * gram_assoc option *
+     string option * gram_assoc option) list
 
 val remove_levels : int -> unit
+
+val level_of_snterml : Gram.symbol -> int
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
index bcca937b..4970ca13 100644
--- a/parsing/ppconstr.ml
+++ b/parsing/ppconstr.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppconstr.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Util
 open Pp
@@ -19,19 +17,15 @@ open Ppextend
 open Topconstr
 open Term
 open Pattern
-open Rawterm
+open Glob_term
 open Constrextern
 open Termops
 (*i*)
 
-let sep_p = fun _ -> str"."
 let sep_v = fun _ -> str"," ++ spc()
-let sep_pp = fun _ -> str":"
-let sep_bar = fun _ -> spc() ++ str"| "
 let pr_tight_coma () = str "," ++ cut ()
 
 let latom = 0
-let lannot = 100
 let lprod = 200
 let llambda = 200
 let lif = 200
@@ -110,18 +104,14 @@ let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
 
 let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
 
-let pr_optc pr = function
-  | None -> mt ()
-  | Some x -> pr_sep_com spc pr x
-
 let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
 
 let pr_universe = Univ.pr_uni
 
-let pr_rawsort = function
-  | RProp Term.Null -> str "Prop"
-  | RProp Term.Pos -> str "Set"
-  | RType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u)
+let pr_glob_sort = function
+  | GProp Term.Null -> str "Prop"
+  | GProp Term.Pos -> str "Set"
+  | GType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u)
 
 let pr_id = pr_id
 let pr_name = pr_name
@@ -187,6 +177,8 @@ let rec pr_patt sep inh p =
   | CPatCstr (_,c,[]) -> pr_reference c, latom
   | CPatCstr (_,c,args) ->
       pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
+  | CPatCstrExpl (_,c,args) ->
+      str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
   | CPatAtom (_,None) -> str "_", latom
   | CPatAtom (_,Some r) -> pr_reference r, latom
   | CPatOr (_,pl) ->
@@ -315,85 +307,6 @@ let split_product na' = function
       rename na na' t (CProdN(loc,(nal,bk,t)::bl,c))
   | _ -> anomaly "ill-formed fixpoint body"
 
-let merge_binders (na1,bk1,ty1) cofun (na2,bk2,ty2) codom =
-  let na =
-    match snd na1, snd na2 with
-        Anonymous, Name id ->
-          if occur_var_constr_expr id cofun then
-            failwith "avoid capture"
-          else na2
-      | Name id, Anonymous ->
-          if occur_var_constr_expr id codom then
-            failwith "avoid capture"
-          else na1
-      | Anonymous, Anonymous -> na1
-      | Name id1, Name id2 ->
-          if id1 <> id2 then failwith "not same name" else na1 in
-  let ty =
-    match ty1, ty2 with
-        CHole _, _ -> ty2
-      | _, CHole _ -> ty1
-      | _ ->
-          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) ->
-        merge_binders bvar cofun ((dummy_loc,Anonymous),default_binder_kind,a) b
-    | CProdN(loc,[([na],bk,ty)],c') ->
-        merge_binders bvar cofun (na,bk,ty) c'
-    | CProdN(loc,([na],bk,ty)::bl,c') ->
-        merge_binders bvar cofun (na,bk,ty) (CProdN(loc,bl,c'))
-    | CProdN(loc,(na::nal,bk,ty)::bl,c') ->
-        merge_binders bvar cofun (na,bk,ty) (CProdN(loc,(nal,bk,ty)::bl,c'))
-    | _ -> failwith "not a product"
-
-(* Note: binder sharing is lost *)
-let rec strip_domains (nal,bk,ty) cofun c =
-  match nal with
-      [] -> assert false
-    | [na] ->
-        let bnd, c' = strip_domain (na,bk,ty) cofun c in
-        ([bnd],None,c')
-    | na::nal ->
-        let f = CLambdaN(dummy_loc,[(nal,bk,ty)],cofun) in
-        let bnd, c1 = strip_domain (na,bk,ty) f c in
-        (try
-          let bl, rest, c2 = strip_domains (nal,bk,ty) cofun c1 in
-          (bnd::bl, rest, c2)
-        with Failure _ -> ([bnd],Some (nal,bk,ty), c1))
-
-(* Re-share binders *)
-let rec factorize_binders = function
-  | ([] | [_] as l) -> l
-  | LocalRawAssum (nal,k,ty) as d :: (LocalRawAssum (nal',k',ty')::l as l') ->
-      (try
-	let _ = Constrextern.check_same_type ty ty' in
-	factorize_binders (LocalRawAssum (nal@nal',k,ty)::l)
-      with _ ->
-	d :: factorize_binders l')
-  | d :: l -> d :: factorize_binders l
-
-(* Extract lambdas when a type constraint occurs *)
-let rec extract_def_binders c ty =
-  match c with
-    | CLambdaN(loc,bvar::lams,b) ->
-        (try
-          let f = CLambdaN(loc,lams,b) in
-          let bvar', rest, ty' = strip_domains bvar f ty in
-          let c' =
-            match rest, lams with
-                None,[] -> b
-              | None, _ -> f
-              | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in
-          let (bl,c2,ty2) = extract_def_binders c' ty' in
-          (factorize_binders (bvar'@bl), c2, ty2)
-        with Failure _ ->
-          ([],c,ty))
-    | _ -> ([],c,ty)
-
 let rec split_fix n typ def =
   if n = 0 then ([],typ,def)
   else
@@ -436,21 +349,6 @@ let pr_recursive pr_decl id = function
         (pr_decl true) dl ++
       fnl() ++ str "for " ++ pr_id id
 
-let is_var id = function
-  | CRef (Ident (_,id')) when id=id' -> true
-  | _ -> false
-
-let tm_clash = function
-  | (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)))
-      when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
-	nal
-      -> Some id
-  | _ -> None
-
 let pr_asin pr (na,indnalopt) =
   (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
     | Some na -> spc () ++ str "as " ++  pr_lname na
@@ -468,8 +366,6 @@ let pr_case_type pr po =
     | Some p ->
         spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
 
-let pr_return_type pr po = pr_case_type pr po
-
 let pr_simple_return_type pr na po =
   (match na with
     | Some (_,Name id) ->
@@ -621,9 +517,9 @@ let pr pr sep inherited a =
   | CHole _ -> str "_", latom
   | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom
   | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
-  | CSort (_,s) -> pr_rawsort s, latom
+  | CSort (_,s) -> pr_glob_sort s, latom
   | CCast (_,a,CastConv (k,b)) ->
-      let s = match k with VMcast -> "<:" | DEFAULTcast -> ":" in
+      let s = match k with VMcast -> "<:" | DEFAULTcast | REVERTcast -> ":" in
       hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b),
       lcast
   | CCast (_,a,CastCoerce) ->
@@ -636,44 +532,11 @@ let pr pr sep inherited a =
   | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom
   | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
   | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
-  | CDynamic _ -> str "<dynamic>", latom
   in
   let loc = constr_loc a in
   pr_with_comments loc
     (sep() ++ if prec_less prec inherited then strm else surround strm)
 
-
-let rec strip_context n iscast t =
-  if n = 0 then
-    [], if iscast then match t with CCast (_,c,_) -> c | _ -> t else t
-  else match t with
-    | CLambdaN (loc,(nal,bk,t)::bll,c) ->
-	let n' = List.length nal in
-	if n' > n then
-	  let nal1,nal2 = list_chop n nal in
-	  [LocalRawAssum (nal1,bk,t)], CLambdaN (loc,(nal2,bk,t)::bll,c)
-	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
-    | CProdN (loc,(nal,bk,t)::bll,c) ->
-	let n' = List.length nal in
-	if n' > n then
-	  let nal1,nal2 = list_chop n nal in
-	  [LocalRawAssum (nal1,bk,t)], CProdN (loc,(nal2,bk,t)::bll,c)
-	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
-    | 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) ->
-	let bl', c = strip_context (n-1) iscast c in
-	LocalRawDef (na,b) :: bl', c
-    | _ -> anomaly "strip_context"
-
 type term_pr = {
   pr_constr_expr   : constr_expr -> std_ppcmds;
   pr_lconstr_expr  : constr_expr -> std_ppcmds;
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index d27b318a..f9ed3af0 100644
--- a/parsing/ppconstr.mli
+++ b/parsing/ppconstr.mli
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppconstr.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Environ
 open Term
 open Libnames
 open Pcoq
-open Rawterm
+open Glob_term
 open Topconstr
 open Names
 open Util
@@ -23,9 +21,6 @@ val extract_lam_binders :
   constr_expr -> local_binder list * constr_expr
 val extract_prod_binders :
   constr_expr -> local_binder list * constr_expr
-val extract_def_binders :
-  constr_expr -> constr_expr ->
-  local_binder list * constr_expr * constr_expr
 val split_fix :
   int -> constr_expr -> constr_expr ->
   local_binder list *  constr_expr * constr_expr
@@ -61,7 +56,7 @@ val pr_may_eval :
   ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
   ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds
 
-val pr_rawsort : rawsort -> std_ppcmds
+val pr_glob_sort : glob_sort -> std_ppcmds
 
 val pr_binders : local_binder list -> std_ppcmds
 val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
@@ -80,7 +75,7 @@ type term_pr = {
 val set_term_pr : term_pr -> unit
 val default_term_pr : term_pr
 
-(* The modular constr printer.
+(** 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]
@@ -89,7 +84,7 @@ val default_term_pr : term_pr
     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"
+      | CSort (_,GProp Null) -> str "Omega"
       | t -> modular_constr_pr pr s p t
     Which has the same type. We can turn a modular printer into a printer by
     taking its fixpoint. *)
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index f63d6659..3305acb7 100644
--- a/parsing/pptactic.ml
+++ b/parsing/pptactic.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pptactic.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Names
 open Namegen
 open Util
 open Tacexpr
-open Rawterm
+open Glob_term
 open Topconstr
 open Genarg
 open Libnames
@@ -21,7 +19,6 @@ open Pattern
 open Ppextend
 open Ppconstr
 open Printer
-open Termops
 
 let pr_global x = Nametab.pr_global_env Idset.empty x
 
@@ -42,8 +39,8 @@ type 'a raw_extra_genarg_printer =
     'a -> std_ppcmds
 
 type 'a glob_extra_genarg_printer =
-    (rawconstr_and_expr -> std_ppcmds) ->
-    (rawconstr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
     (tolerability -> glob_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
@@ -92,8 +89,6 @@ let pr_quantified_hypothesis = function
   | AnonHyp n -> int n
   | NamedHyp id -> pr_id id
 
-let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
-
 let pr_binding prc = function
   | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
   | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
@@ -132,11 +127,6 @@ let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s)
 
 let with_evars ev s = if ev then "e" ^ s else s
 
-let out_bindings = function
-  | ImplicitBindings l -> ImplicitBindings (List.map snd l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (fun (loc,id,c) -> (loc,id,snd c)) l)
-  | NoBindings -> NoBindings
-
 let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c
 
 let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) =
@@ -150,7 +140,7 @@ let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generi
   | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x)
   | VarArgType -> pr_located pr_id (out_gen rawwit_var x)
   | RefArgType -> prref (out_gen rawwit_ref x)
-  | SortArgType -> pr_rawsort (out_gen rawwit_sort x)
+  | SortArgType -> pr_glob_sort (out_gen rawwit_sort x)
   | ConstrArgType -> prc (out_gen rawwit_constr x)
   | ConstrMayEvalArgType ->
       pr_may_eval prc prlc (pr_or_by_notation prref) prpat
@@ -193,7 +183,7 @@ let rec pr_glob_generic prc prlc prtac prpat x =
   | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x)
   | VarArgType -> pr_located pr_id (out_gen globwit_var x)
   | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x)
-  | SortArgType -> pr_rawsort (out_gen globwit_sort x)
+  | SortArgType -> pr_glob_sort (out_gen globwit_sort x)
   | ConstrArgType -> prc (out_gen globwit_constr x)
   | ConstrMayEvalArgType ->
       pr_may_eval prc prlc
@@ -296,8 +286,6 @@ let pr_extend prc prlc prtac prpat =
 (**********************************************************************)
 (* The tactic printer                                                 *)
 
-let sep_v = fun _ -> str"," ++ spc()
-
 let strip_prod_binders_expr n ty =
   let rec strip_ty acc n ty =
     match ty with
@@ -318,8 +306,6 @@ let pr_ltac_or_var pr = function
   | ArgArg x -> pr x
   | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
 
-let pr_arg pr x = spc () ++ pr x
-
 let pr_ltac_constant sp =
   pr_qualid (Nametab.shortest_qualid_of_tactic sp)
 
@@ -328,12 +314,6 @@ let pr_evaluable_reference_env env = function
   | 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
-
-let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
-
 let pr_esubst prc l =
   let pr_qhyp = function
       (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
@@ -358,10 +338,6 @@ let pr_bindings prlc prc = pr_bindings_gen false prlc prc
 let pr_with_bindings prlc prc (c,bl) =
   hov 1 (prc c ++ pr_bindings prlc prc bl)
 
-let pr_with_constr prc = function
-  | None -> mt ()
-  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
-
 let pr_with_induction_names = function
   | None, None -> mt ()
   | eqpat, ipat ->
@@ -411,11 +387,11 @@ let pr_by_tactic prt = function
   | tac -> spc() ++ str "by " ++ prt tac
 
 let pr_hyp_location pr_id = function
-  | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
-  | occs, InHypTypeOnly ->
+  | occs, Termops.InHyp -> spc () ++ pr_with_occurrences pr_id occs
+  | occs, Termops.InHypTypeOnly ->
       spc () ++
       pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs
-  | occs, InHypValueOnly ->
+  | occs, Termops.InHypValueOnly ->
       spc () ++
       pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs
 
@@ -443,15 +419,6 @@ let pr_clauses default_is_concl pr_id = function
 	 (if occs = no_occurrences_expr then mt ()
 	  else pr_with_occurrences (fun () -> str" |- *") (occs,())))
 
-let pr_clause_pattern pr_id = function
-  | (None, []) -> mt ()
-  | (glopt,l) ->
-      str " in" ++
-      prlist
-        (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
@@ -512,7 +479,7 @@ let pr_funvar = function
 
 let pr_let_clause k pr (id,(bl,t)) =
   hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++
-         str " :=" ++ brk (1,1) ++ pr (TacArg t))
+         str " :=" ++ brk (1,1) ++ pr (TacArg (dummy_loc,t)))
 
 let pr_let_clauses recflag pr = function
   | hd::tl ->
@@ -548,20 +515,6 @@ let pr_auto_using prc = function
   | l -> spc () ++
       hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
 
-let pr_autoarg_adding = function
-  | [] -> mt ()
-  | l ->
-      spc () ++ str "adding [" ++
-        hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
-
-let pr_autoarg_destructing = function
-  | true -> spc () ++ str "destructing"
-  | false -> mt ()
-
-let pr_autoarg_usingTDB = function
-  | true -> spc () ++ str "using tdb"
-  | false -> mt ()
-
 let pr_then () = str ";"
 
 let ltop = (5,E)
@@ -835,7 +788,7 @@ and pr_atom1 = function
   | TacAnyConstructor (ev,None) as t -> pr_atom0 t
   | TacConstructor (ev,n,l) ->
       hov 1 (str (with_evars ev "constructor") ++
-             pr_or_metaid pr_intarg n ++ pr_bindings l)
+             pr_or_var pr_intarg n ++ pr_bindings l)
 
   (* Conversion *)
   | TacReduce (r,h) ->
@@ -935,6 +888,10 @@ let rec pr_tac inherited tac =
       hov 1 (str "do " ++ pr_or_var int n ++ spc () ++
              pr_tac (ltactical,E) t),
       ltactical
+  | TacTimeout (n,t) ->
+      hov 1 (str "timeout " ++ pr_or_var int n ++ spc () ++
+             pr_tac (ltactical,E) t),
+      ltactical
   | TacRepeat t ->
       hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t),
       ltactical
@@ -949,8 +906,8 @@ let rec pr_tac inherited tac =
              pr_tac (lorelse,E) t2),
       lorelse
   | 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
+      hov 1 (str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
+      prlist (pr_arg (pr_message_token pr_ident)) l), latom
   | TacFirst tl ->
       str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
   | TacSolve tl ->
@@ -965,20 +922,20 @@ let rec pr_tac inherited tac =
       latom
   | TacAtom (loc,t) ->
       pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom
-  | TacArg(Tacexp e) -> pr_tac_level (latom,E) e, latom
-  | TacArg(ConstrMayEval (ConstrTerm c)) ->
+  | TacArg(_,Tacexp e) -> pr_tac_level (latom,E) e, latom
+  | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
       str "constr:" ++ pr_constr c, latom
-  | TacArg(ConstrMayEval c) ->
+  | TacArg(_,ConstrMayEval c) ->
       pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval
-  | TacArg(TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
-  | TacArg(Integer n) -> int n, latom
-  | TacArg(TacCall(loc,f,[])) -> pr_ref f, latom
-  | TacArg(TacCall(loc,f,l)) ->
+  | TacArg(_,TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
+  | TacArg(_,Integer n) -> int n, latom
+  | TacArg(_,TacCall(loc,f,[])) -> pr_ref f, latom
+  | TacArg(_,TacCall(loc,f,l)) ->
       pr_with_comments loc
         (hov 1 (pr_ref f ++ spc () ++
          prlist_with_sep spc pr_tacarg l)),
       lcall
-  | TacArg a -> pr_tacarg a, latom
+  | TacArg (_,a) -> pr_tacarg a, latom
   in
   if prec_less prec inherited then strm
   else str"(" ++ strm ++ str")"
@@ -997,15 +954,15 @@ and pr_tacarg = function
       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)
+      str "ltac:" ++ pr_tac (latom,E) (TacArg (dummy_loc,a))
 
 in (pr_tac, pr_match_rule)
 
-let strip_prod_binders_rawterm n (ty,_) =
+let strip_prod_binders_glob_constr n (ty,_) =
   let rec strip_ty acc n ty =
     if n=0 then (List.rev acc, (ty,None)) else
       match ty with
-          Rawterm.RProd(loc,na,Explicit,a,b) ->
+          Glob_term.GProd(loc,na,Explicit,a,b) ->
             strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
         | _ -> error "Cannot translate fix tactic: not enough products" in
   strip_ty [] n ty
@@ -1039,33 +996,27 @@ let rec raw_printers =
 and pr_raw_tactic_level env n (t:raw_tactic_expr) =
   fst (make_pr_tac raw_printers env) n t
 
-and pr_raw_match_rule env t =
-  snd (make_pr_tac raw_printers 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)
+  pr_and_constr_expr ((if b then pr_lglob_constr_env else pr_glob_constr_env)
     (Global.env())) c
 
 let rec glob_printers =
     (pr_glob_tactic_level,
-     (fun env -> pr_and_constr_expr (pr_rawconstr_env env)),
-     (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)),
+     (fun env -> pr_and_constr_expr (pr_glob_constr_env env)),
+     (fun env -> pr_and_constr_expr (pr_lglob_constr_env env)),
      pr_pat_and_constr_expr,
      (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
      (fun env -> pr_or_var (pr_inductive env)),
      pr_ltac_or_var (pr_located pr_ltac_constant),
      pr_lident,
      pr_glob_extend,
-     strip_prod_binders_rawterm)
+     strip_prod_binders_glob_constr)
 
 and pr_glob_tactic_level env n (t:glob_tactic_expr) =
   fst (make_pr_tac glob_printers env) n t
 
-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
 
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
index 40880f58..d85f1ec3 100644
--- a/parsing/pptactic.mli
+++ b/parsing/pptactic.mli
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pptactic.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Genarg
 open Tacexpr
 open Pretyping
 open Proof_type
 open Topconstr
-open Rawterm
+open Glob_term
 open Pattern
 open Ppextend
 open Environ
@@ -32,8 +30,8 @@ type 'a raw_extra_genarg_printer =
     'a -> std_ppcmds
 
 type 'a glob_extra_genarg_printer =
-    (rawconstr_and_expr -> std_ppcmds) ->
-    (rawconstr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
     (tolerability -> glob_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
@@ -43,7 +41,7 @@ type 'a extra_genarg_printer =
     (tolerability -> glob_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
-  (* if the boolean is false then the extension applies only to old syntax *)
+  (** if the boolean is false then the extension applies only to old syntax *)
 val declare_extra_genarg_pprule :
   ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) ->
   ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) ->
@@ -51,7 +49,7 @@ val declare_extra_genarg_pprule :
 
 type grammar_terminals = string option list
 
-  (* if the boolean is false then the extension applies only to old syntax *)
+  (** if the boolean is false then the extension applies only to old syntax *)
 val declare_extra_tactic_pprule :
   string * argument_type list * (int * grammar_terminals) -> unit
 
@@ -72,9 +70,9 @@ val pr_raw_extend:
     string -> raw_generic_argument list -> std_ppcmds
 
 val pr_glob_extend:
-  (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) ->
+  (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) ->
   (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-  (rawconstr_pattern_and_expr -> std_ppcmds) -> int ->
+  (glob_constr_pattern_and_expr -> std_ppcmds) -> int ->
     string -> glob_generic_argument list -> std_ppcmds
 
 val pr_extend :
diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml
index 44ac445d..c858439e 100644
--- a/parsing/ppvernac.ml
+++ b/parsing/ppvernac.ml
@@ -1,23 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppvernac.ml 14657 2011-11-16 08:46:33Z herbelin $ *)
-
 open Pp
 open Names
 open Nameops
 open Nametab
+open Compat
 open Util
 open Extend
 open Vernacexpr
 open Ppconstr
 open Pptactic
-open Rawterm
+open Glob_term
 open Genarg
 open Pcoq
 open Libnames
@@ -25,6 +24,7 @@ open Ppextend
 open Topconstr
 open Decl_kinds
 open Tacinterp
+open Declaremods
 
 let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
 
@@ -85,27 +85,12 @@ let rec match_vernac_rule tys = function
       else match_vernac_rule tys rls
 
 let sep = fun _ -> spc()
-let sep_p = fun _ -> str"."
-let sep_v = fun _ -> str","
 let sep_v2 = fun _ -> str"," ++ spc()
-let sep_pp = fun _ -> str":"
 
 let pr_ne_sep sep pr = function
     [] -> mt()
   | l -> sep() ++ pr l
 
-let pr_entry_prec = function
-  | Some Gramext.LeftA -> str"LEFTA "
-  | Some Gramext.RightA -> str"RIGHTA "
-  | Some Gramext.NonA -> str"NONA "
-  | None -> mt()
-
-let pr_prec = function
-  | Some Gramext.LeftA -> str", left associativity"
-  | Some Gramext.RightA -> str", right associativity"
-  | Some Gramext.NonA -> str", no associativity"
-  | None -> mt()
-
 let pr_set_entry_type = function
   | ETName -> str"ident"
   | ETReference -> str"global"
@@ -169,11 +154,6 @@ let pr_explanation (e,b,f) =
   let a = if f then str"!" ++ a else a in
     if b then str "[" ++ a ++ str "]" else a
 
-let pr_class_rawexpr = function
-  | FunClass -> str"Funclass"
-  | SortClass -> str"Sortclass"
-  | RefClass qid -> pr_smart_global qid
-
 let pr_option_ref_value = function
   | QualidRefValue id -> pr_reference id
   | StringRefValue s -> qs s
@@ -184,7 +164,9 @@ let pr_printoption table b =
 
 let pr_set_option a b =
   let pr_opt_value = function
-    | IntValue n -> spc() ++ int n
+    | IntValue None -> assert false
+    (* This should not happen because of the grammar *)
+    | IntValue (Some n) -> spc() ++ int n
     | StringValue s -> spc() ++ str s
     | BoolValue b -> mt()
   in pr_printoption a None ++ pr_opt_value b
@@ -238,18 +220,31 @@ let pr_with_declaration pr_c = function
 
 let rec pr_module_ast pr_c = function
   | CMident qid -> spc () ++ pr_located pr_qualid qid
-  | CMwith (mty,decl) ->
+  | CMwith (_,mty,decl) ->
       let m = pr_module_ast pr_c mty in
       let p = pr_with_declaration pr_c decl in
       m ++ spc() ++ str"with" ++ spc() ++ p
-  | CMapply (me1,(CMident _ as me2)) ->
+  | CMapply (_,me1,(CMident _ as me2)) ->
       pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2
-  | CMapply (me1,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_annot { ann_inline = ann; ann_scope_subst = scl } =
+  let sep () = if scl=[] then mt () else str "," in
+  if ann = DefaultInline && scl = [] then mt ()
+  else
+    str " [" ++
+    (match ann with
+      | DefaultInline -> mt ()
+      | NoInline -> str "no inline" ++ sep ()
+      | InlineAt i -> str "inline at level " ++ int i ++ sep ()) ++
+    prlist_with_sep (fun () -> str ", ")
+      (fun (sc1,sc2) -> str ("scope "^sc1^" to "^sc2)) scl ++
+    str "]"
+
+let pr_module_ast_inl pr_c (mast,ann) =
+  pr_module_ast pr_c mast ++ pr_annot ann
 
 let pr_of_module_type prc = function
   | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty
@@ -267,7 +262,7 @@ let pr_module_vardecls pr_c (export,idl,(mty,inl)) =
   let lib_dir = Lib.library_dp() in
   List.iter (fun (_,id) ->
     Declaremods.process_module_bindings [id]
-      [make_mbid lib_dir (string_of_id id),
+      [make_mbid lib_dir id,
        (Modintern.interp_modtype (Global.env()) mty, inl)]) idl;
   (* Builds the stream *)
   spc() ++
@@ -291,9 +286,6 @@ 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)
-
 let pr_binders_arg =
   pr_ne_sep spc pr_binders
 
@@ -331,7 +323,7 @@ let pr_onescheme (idop,schem) =
     ) ++
     hov 0 ((if dep then str"Induction for" else str"Minimality for")
     ++ spc() ++ pr_smart_global ind) ++ spc() ++
-    hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
+    hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s)
   | CaseScheme (dep,ind,s) ->
     (match idop with
       | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
@@ -339,7 +331,7 @@ let pr_onescheme (idop,schem) =
     ) ++
     hov 0 ((if dep then str"Elimination for" else str"Case for")
     ++ spc() ++ pr_smart_global ind) ++ spc() ++
-    hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
+    hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s)
   | EqualityScheme ind ->
     (match idop with
       | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
@@ -402,9 +394,9 @@ let pr_syntax_modifier = function
       prlist_with_sep sep_v2 str l ++
       spc() ++ str"at level" ++ spc() ++ int n
   | SetLevel n -> str"at level" ++ spc() ++ int n
-  | SetAssoc Gramext.LeftA -> str"left associativity"
-  | SetAssoc Gramext.RightA -> str"right associativity"
-  | SetAssoc Gramext.NonA -> str"no associativity"
+  | SetAssoc LeftA -> str"left associativity"
+  | SetAssoc RightA -> str"right associativity"
+  | SetAssoc NonA -> str"no associativity"
   | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
   | SetOnlyParsing -> str"only parsing"
   | SetFormat s -> str"format " ++ pr_located qs s
@@ -422,21 +414,6 @@ let pr_grammar_tactic_rule n (_,pil,t) =
     hov 0 (prlist_with_sep sep pr_production_item pil ++
     spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
 
-let pr_box b = let pr_boxkind = function
-  | PpHB n -> str"h" ++ spc() ++ int n
-  | PpVB n -> str"v" ++ spc() ++ int n
-  | PpHVB n -> str"hv" ++ spc() ++ int n
-  | 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"
-  | Some pprim,Any -> qs pprim
-  | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p
-  | _ -> mt()
-
 let pr_statement head (id,(bl,c,guard)) =
   assert (id<>None);
   hov 1
@@ -453,22 +430,27 @@ let make_pr_vernac pr_constr pr_lconstr =
 let pr_constrarg c = spc () ++ pr_constr c in
 let pr_lconstrarg c = spc () ++ pr_lconstr c in
 let pr_intarg n = spc () ++ int n in
-(* let pr_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in *)
-let pr_record_field (x, ntn) =
+let pr_oc = function 
+    None -> str" :"
+  | Some true -> str" :>"
+  | Some false -> str" :>>"
+in
+let pr_record_field ((x, pri), ntn) =
   let prx = match x with
     | (oc,AssumExpr (id,t)) ->
 	hov 1 (pr_lname id ++
-		  (if oc then str" :>" else str" :") ++ spc() ++
-		  pr_lconstr_expr t)
+	       pr_oc oc ++ spc() ++
+	       pr_lconstr_expr t)
     | (oc,DefExpr(id,b,opt)) -> (match opt with
       | Some t ->
           hov 1 (pr_lname id ++
-                    (if oc then str" :>" else str" :") ++ spc() ++
-                    pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
+                 pr_oc oc ++ spc() ++
+                 pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
       | None ->
           hov 1 (pr_lname id ++ str" :=" ++ spc() ++
                     pr_lconstr b)) in
-    prx ++ prlist (pr_decl_notation pr_constr) ntn
+  let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
+    prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
 in
 let pr_record_decl b c fs =
     pr_opt pr_lident c ++ str"{"  ++
@@ -490,16 +472,13 @@ let rec pr_vernac = function
   | 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 ->
-      let pr_goable = function
-	| GoTo i -> int i
-	| GoTop -> str"top"
-	| GoNext -> str"next"
-	| GoPrev -> str"prev"
-      in str"Go" ++ spc() ++  pr_goable g
   | VernacShow s ->
+      let pr_goal_reference = function
+        | OpenSubgoals -> mt ()
+        | NthGoal n -> spc () ++ int n
+        | GoalId n -> spc () ++ str n in
       let pr_showable = function
-	| ShowGoal n -> str"Show" ++ pr_opt int n
+	| ShowGoal n -> str"Show" ++ pr_goal_reference n
 	| ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n
 	| ShowProof -> str"Show Proof"
 	| ShowNode -> str"Show Node"
@@ -510,8 +489,6 @@ let rec pr_vernac = function
 	| ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro")
 	| 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
       in pr_showable s
   | VernacCheckGuard -> str"Guarded"
 
@@ -655,7 +632,7 @@ let rec pr_vernac = function
       (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
 
 
-  | VernacFixpoint (recs,b) ->
+  | VernacFixpoint recs ->
       let pr_onerec = function
         | ((loc,id),ro,bl,type_,def),ntn ->
             let annot = pr_guard_annot bl ro in
@@ -664,19 +641,17 @@ let rec pr_vernac = function
             ++ 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 0 (str start ++ spc() ++
+      hov 0 (str "Fixpoint" ++ spc() ++
         prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs)
 
-  | VernacCoFixpoint (corecs,b) ->
+  | VernacCoFixpoint corecs ->
       let pr_onecorec (((loc,id),bl,c,def),ntn) =
         pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
         spc() ++ pr_lconstr_expr c ++
         pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
 	prlist (pr_decl_notation pr_constr) ntn
       in
-      let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in
-      hov 0 (str start ++ spc() ++
+      hov 0 (str "CoFixpoint" ++ spc() ++
       prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)
   | VernacScheme l ->
       hov 2 (str"Scheme" ++ spc() ++
@@ -721,7 +696,7 @@ let rec pr_vernac = function
 (* 	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()) ++ *)
+(* 	  (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_glob_sort (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 ) *)
@@ -735,8 +710,9 @@ let rec pr_vernac = function
 	 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 () ++
-	 pr_constr_expr props)
+	 (match props with
+	  | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p
+	  | None -> mt()))
 
  | VernacContext l ->
      hov 1 (
@@ -744,9 +720,10 @@ let rec pr_vernac = function
 	 pr_and_type_binders_arg l ++ spc () ++ str "]")
 
 
- | VernacDeclareInstance (glob, id) ->
+ | VernacDeclareInstances (glob, ids) ->
      hov 1 (pr_non_locality (not glob) ++
-	       str"Existing" ++ spc () ++ str"Instance" ++ spc () ++ pr_reference id)
+               str"Existing" ++ spc () ++ str(plural (List.length ids) "Instance") ++
+               spc () ++ prlist_with_sep spc pr_reference ids)
 
  | VernacDeclareClass id ->
      hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id)
@@ -780,20 +757,12 @@ let rec pr_vernac = function
   | VernacSolve (i,tac,deftac) ->
       (if i = 1 then mt() else int i ++ str ": ") ++
       pr_raw_tactic tac
-      ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt ()
-      with UserError _|Stdpp.Exc_located _ -> mt())
+      ++ (try if deftac then str ".." else mt ()
+      with UserError _|Loc.Exc_located _ -> mt())
 
   | VernacSolveExistential (i,c) ->
       str"Existential " ++ int i ++ pr_lconstrarg c
 
-  (* MMode *)
-
-  | VernacProofInstr instr -> anomaly "Not implemented"
-  | VernacDeclProof -> str "proof"
-  | VernacReturn -> str "return"
-
-  (* /MMode *)
-
   (* Auxiliary file and library management *)
   | VernacRequireFrom (exp,spe,f) -> hov 2
       (str"Require" ++ spc() ++ pr_require_token exp ++
@@ -838,8 +807,12 @@ let rec pr_vernac = function
         (pr_locality local ++ str "Ltac " ++
         prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l)
   | VernacCreateHintDb (local,dbname,b) ->
-      hov 1 (pr_locality local ++ str "Create " ++ str "HintDb " ++ 
+      hov 1 (pr_locality local ++ str "Create HintDb " ++ 
 		str dbname ++ (if b then str" discriminated" else mt ()))
+  | VernacRemoveHints (local, dbnames, ids) ->
+      hov 1 (pr_locality local ++ str "Remove Hints " ++
+	       prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ 
+	       pr_opt_hintbases dbnames)
   | VernacHints (local,dbnames,h) ->
       pr_hints local dbnames h pr_constr pr_constr_pattern_expr
   | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) ->
@@ -856,6 +829,32 @@ let rec pr_vernac = function
 	prlist_with_sep spc (fun imps ->
 	  str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
 	  impls)
+  | VernacArguments (local, q, impl, nargs, mods) ->
+      hov 2 (pr_section_locality local ++ str"Arguments" ++ spc() ++
+        pr_smart_global q ++
+      let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
+      let pr_if b x = if b then x else str "" in
+      let pr_br imp max x = match imp, max with
+        | true, false -> str "[" ++ x ++ str "]"
+        | true, true -> str "{" ++ x ++ str "}"
+        | _ -> x in
+      let rec aux n l =
+        match n, l with
+        | 0, l -> spc () ++ str"/" ++ aux ~-1 l
+        | _, [] -> mt()
+        | n, (id,k,s,imp,max) :: tl ->
+            spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
+            aux (n-1) tl in
+      prlist_with_sep (fun () -> str", ") (aux nargs) impl ++
+      if mods <> [] then str" : " else str"" ++
+      prlist_with_sep (fun () -> str", " ++ spc()) (function
+        | `SimplDontExposeCase -> str "simpl nomatch"
+        | `SimplNeverUnfold -> str "simpl never"
+        | `DefaultImplicits -> str "default implicits"
+        | `Rename -> str "rename"
+        | `ClearImplicits -> str "clear implicits"
+        | `ClearScopes -> str "clear scopes")
+        mods)
   | VernacReserve bl ->
       let n = List.length (List.flatten (List.map fst bl)) in
       hov 2 (str"Implicit Type" ++
@@ -933,7 +932,7 @@ let rec pr_vernac = function
 	| 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
+	| PrintUniverses (b, fopt) -> Printf.ksprintf str "Print %sUniverses" (if b then "Sorted " else "") ++ pr_opt str fopt
 	| PrintName qid -> str"Print" ++ spc()  ++ pr_smart_global qid
 	| PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid
 	| PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid
@@ -967,8 +966,21 @@ let rec pr_vernac = function
 
   (* 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 (None, None) -> str "Proof"
+  | VernacProof (None, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l
+  | VernacProof (Some te, None) -> str "Proof with" ++ spc() ++ pr_raw_tactic te
+  | VernacProof (Some te, Some l) -> 
+      str "Proof using" ++spc()++ prlist pr_lident l ++ spc() ++
+      str "with" ++ spc() ++pr_raw_tactic te
+  | VernacProofMode s -> str ("Proof Mode "^s)
+  | VernacBullet b -> begin match b with
+      | Dash -> str"-"
+      | Star -> str"*"
+      | Plus -> str"+"
+  end ++ spc()
+  | VernacSubproof None -> str "BeginSubproof"
+  | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i
+  | VernacEndSubproof -> str "EndSubproof"
 
 and pr_extend s cl =
   let pr_arg a =
diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli
index e63cf7b0..7801de6a 100644
--- a/parsing/ppvernac.mli
+++ b/parsing/ppvernac.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppvernac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Genarg
 open Vernacexpr
@@ -17,7 +15,7 @@ open Nametab
 open Util
 open Ppconstr
 open Pptactic
-open Rawterm
+open Glob_term
 open Pcoq
 open Libnames
 open Ppextend
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index ea97a198..e30979bf 100644
--- a/parsing/prettyp.ml
+++ b/parsing/prettyp.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,8 +10,6 @@
  * on May-June 2006 for implementation of abstraction of pretty-printing of objects.
  *)
 
-(* $Id: prettyp.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -41,7 +39,6 @@ type object_pr = {
   print_module              : bool -> Names.module_path -> std_ppcmds;
   print_modtype             : module_path -> std_ppcmds;
   print_named_decl          : identifier * constr option * types -> std_ppcmds;
-  print_leaf_entry          : bool -> Libnames.object_name * Libobject.obj -> Pp.std_ppcmds;
   print_library_entry       : bool -> (object_name * Lib.node) -> std_ppcmds option;
   print_context             : bool -> int option -> Lib.library_segment -> std_ppcmds;
   print_typed_value_in_env  : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds;
@@ -122,6 +119,11 @@ let print_impargs_list prefix l =
 	    then print_one_impargs_list imps
 	    else [str "No implicit arguments"]))])]) l)
 
+let print_renames_list prefix l =
+  if l = [] then [] else
+  [add_colon prefix ++ str "Arguments are renamed to " ++
+    hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))]
+
 let need_expansion impl ref =
   let typ = Global.type_of_global ref in
   let ctx = (prod_assum typ) in
@@ -154,6 +156,45 @@ let print_argument_scopes prefix = function
       str "]")]
   | _  -> []
 
+(*****************************)
+(** Printing simpl behaviour *)
+
+let print_simpl_behaviour ref =
+  match Tacred.get_simpl_behaviour ref with
+  | None -> []
+  | Some (recargs, nargs, flags) ->
+     let never = List.mem `SimplNeverUnfold flags in
+     let nomatch = List.mem `SimplDontExposeCase flags in
+     let pp_nomatch = spc() ++ if nomatch then
+       str "avoiding to expose match constructs" else str"" in
+     let pp_recargs = spc() ++ str "when the " ++
+       let rec aux = function
+         | [] -> mt()
+         | [x] -> str (ordinal (x+1))
+         | [x;y] -> str (ordinal (x+1)) ++ str " and " ++ str (ordinal (y+1))
+         | x::tl -> str (ordinal (x+1)) ++ str ", " ++ aux tl in
+       aux recargs ++ str (plural (List.length recargs) " argument") ++
+       str (plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++
+       str " to a constructor" in
+     let pp_nargs =
+       spc() ++ str "when applied to " ++ int nargs ++
+       str (plural nargs " argument") in
+     [hov 2 (str "The simpl tactic " ++
+     match recargs, nargs, never with
+     | _,_, true -> str "never unfolds " ++ pr_global ref
+     | [], 0, _ -> str "always unfolds " ++ pr_global ref
+     | _::_, n, _ when n < 0 ->
+        str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
+     | _::_, n, _ when n > List.fold_left max 0 recargs ->
+        str "unfolds " ++ pr_global ref ++ pp_recargs ++
+        str " and" ++ pp_nargs ++ pp_nomatch
+     | _::_, _, _ ->
+        str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
+     | [], n, _ when n > 0 ->
+        str "unfolds " ++ pr_global ref ++ pp_nargs ++ pp_nomatch
+     | _ -> str "unfolds " ++ pr_global ref ++ pp_nomatch )]
+;;
+
 (*********************)
 (** Printing Opacity *)
 
@@ -166,10 +207,11 @@ let opacity env = function
       Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v)))
   | ConstRef cst ->
       let cb = Environ.lookup_constant cst env in
-      if cb.const_body = None then None
-      else if cb.const_opaque then Some FullyOpaque
-      else Some
-        (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst)))
+      (match cb.const_body with
+	| Undef _ -> None
+	| OpaqueDef _ -> Some FullyOpaque
+	| Def _ -> Some
+          (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst))))
   | _ -> None
 
 let print_opacity ref =
@@ -194,6 +236,8 @@ let print_opacity ref =
 let print_name_infos ref =
   let impls = implicits_of_global ref in
   let scopes = Notation.find_arguments_scope ref in
+  let renames =
+    try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in
   let type_info_for_implicit =
     if need_expansion (select_impargs_size 0 impls) ref then
       (* Need to reduce since implicits are computed with products flattened *)
@@ -202,6 +246,7 @@ let print_name_infos ref =
     else
       [] in
   type_info_for_implicit @
+  print_renames_list (mt()) renames @
   print_impargs_list (mt()) impls @
   print_argument_scopes (mt()) scopes
 
@@ -226,6 +271,12 @@ let print_inductive_implicit_args =
     implicits_of_global (fun l -> positions_of_implicits l <> [])
     print_impargs_list
 
+let print_inductive_renames =
+  print_args_data_of_inductive_ids
+    (fun r -> try List.hd (Arguments_renaming.arguments_names r) with _ -> [])
+    ((<>) Anonymous)
+    print_renames_list
+
 let print_inductive_argument_scopes =
   print_args_data_of_inductive_ids
     Notation.find_arguments_scope ((<>) None) print_argument_scopes
@@ -337,89 +388,14 @@ let assumptions_for_print lna =
 (*********************)
 (* *)
 
-let print_params env params =
-  if params = [] then mt () else pr_rel_context env params ++ brk(1,2)
-
-let print_constructors envpar names types =
-  let pc =
-    prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
-      (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c)
-      (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
-  in
-  hv 0 (str "  " ++ pc)
-
-let build_inductive sp tyi =
-  let (mib,mip) = Global.lookup_inductive (sp,tyi) in
-  let params = mib.mind_params_ctxt in
-  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
-    | 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
-  let cstrtypes = type_of_constructors env (sp,tyi) in
-  let cstrtypes =
-    Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
-  let cstrnames = mip.mind_consnames in
-  (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes)
-
-let print_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
-  hov 0 (
-    pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++
-    str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++
-  brk(0,2) ++ print_constructors envpar cstrnames cstrtypes
-
-let pr_mutual_inductive finite indl =
-  hov 0 (
-    str (if finite then "Inductive " else "CoInductive ") ++
-    prlist_with_sep (fun () -> fnl () ++ str"  with ")
-      print_one_inductive indl)
-
-let get_fields =
-  let rec prodec_rec l subst c =
-    match kind_of_term c with
-    | Prod (na,t,c) ->
-	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
-	prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c
-    | LetIn (na,b,_,c) ->
-	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
-	prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c
-    | _               -> List.rev l
-  in
-  prodec_rec [] []
-
-let pr_record (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 fields = get_fields cstrtypes.(0) in
-  hov 0 (
-    hov 0 (
-      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)) ++
-    brk(1,2) ++
-    hv 2 (str "{ " ++
-      prlist_with_sep (fun () -> str ";" ++ brk(2,0))
-        (fun (id,b,c) ->
-	  pr_id id ++ str (if b then " : " else " := ") ++
-	  pr_lconstr_env envpar c) fields) ++ str" }")
-
 let gallina_print_inductive sp =
-  let (mib,mip) = Global.lookup_inductive (sp,0) in
+  let env = Global.env() in
+  let mib = Environ.lookup_mind sp env in
   let mipv = mib.mind_packets in
-  let names = list_tabulate (fun x -> (sp,x)) (Array.length mipv) in
-  (if mib.mind_record & not !Flags.raw_print then
-    pr_record (List.hd names)
-  else
-    pr_mutual_inductive mib.mind_finite names) ++ fnl () ++
+  pr_mutual_inductive_body env sp mib ++ fnl () ++
   with_line_skip
-    (print_inductive_implicit_args sp mipv @
+    (print_inductive_renames sp mipv @
+     print_inductive_implicit_args sp mipv @
      print_inductive_argument_scopes sp mipv)
 
 let print_named_decl id =
@@ -442,7 +418,7 @@ let ungeneralized_type_of_constant_type = function
 
 let print_constant with_values sep sp =
   let cb = Global.lookup_constant sp in
-  let val_0 = cb.const_body in
+  let val_0 = body_of_constant cb in
   let typ = ungeneralized_type_of_constant_type cb.const_type in
   hov 0 (
     match val_0 with
@@ -462,13 +438,13 @@ let gallina_print_constant_with_infos sp =
 let gallina_print_syntactic_def kn =
   let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn
   and (vars,a) = Syntax_def.search_syntactic_definition kn in
-  let c = Topconstr.rawconstr_of_aconstr dummy_loc a in
+  let c = Topconstr.glob_constr_of_aconstr dummy_loc a in
   hov 2
     (hov 4
        (str "Notation " ++ pr_qualid qid ++
         prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++ 
         spc () ++ str ":=") ++
-     spc () ++ Constrextern.without_symbols pr_rawconstr c) ++ fnl ()
+     spc () ++ Constrextern.without_symbols pr_glob_constr c) ++ fnl ()
 
 let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) =
   let sep = if with_values then " = " else " : "
@@ -508,18 +484,9 @@ let gallina_print_library_entry with_values ent =
 	Some (str " >>>>>>> Module " ++ pr_name oname)
     | (oname,Lib.ClosedModule _) ->
         Some (str " >>>>>>> Closed Module " ++ pr_name oname)
-    | (oname,Lib.OpenedModtype _) ->
-	Some (str " >>>>>>> Module Type " ++ pr_name oname)
-    | (oname,Lib.ClosedModtype _) ->
-        Some (str " >>>>>>> Closed Module Type " ++ pr_name oname)
     | (_,Lib.FrozenState _) ->
 	None
 
-let gallina_print_leaf_entry with_values c =
-  match gallina_print_leaf_entry with_values c with
-    | None    -> mt ()
-    | Some pp -> pp ++ fnl()
-
 let gallina_print_context with_values =
   let rec prec n = function
     | h::rest when n = None or Option.get n > 0 ->
@@ -545,7 +512,6 @@ let default_object_pr = {
   print_module              = gallina_print_module;
   print_modtype             = gallina_print_modtype;
   print_named_decl          = gallina_print_named_decl;
-  print_leaf_entry          = gallina_print_leaf_entry;
   print_library_entry       = gallina_print_library_entry;
   print_context             = gallina_print_context;
   print_typed_value_in_env  = gallina_print_typed_value_in_env;
@@ -562,7 +528,6 @@ let print_syntactic_def x = !object_pr.print_syntactic_def x
 let print_module x  = !object_pr.print_module  x
 let print_modtype x = !object_pr.print_modtype x
 let print_named_decl x = !object_pr.print_named_decl x
-let print_leaf_entry x = !object_pr.print_leaf_entry x
 let print_library_entry x = !object_pr.print_library_entry x
 let print_context x = !object_pr.print_context x
 let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x
@@ -596,31 +561,28 @@ let print_full_pure_context () =
   | ((_,kn),Lib.Leaf lobj)::rest ->
       let pp = match object_tag lobj with
       | "CONSTANT" ->
-	  let con = Global.constant_of_delta (constant_of_kn kn) in
+	  let con = Global.constant_of_delta_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
-	    | None ->
-		str (if cb.const_opaque then "Axiom " else "Parameter ") ++
+	    match cb.const_body with
+	      | Undef _ ->
+		str "Parameter " ++
 		print_basename con ++ str " : " ++ cut () ++ pr_ltype typ
-	    | Some v ->
-		if cb.const_opaque then
-		  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 "  : " ++ pr_ltype typ ++ cut () ++ str " := " ++
-		  print_body val_0) ++ str "." ++ fnl () ++ fnl ()
+	      | OpaqueDef lc ->
+		str "Theorem " ++ print_basename con ++ cut () ++
+		str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++
+		str "Proof " ++ pr_lconstr (Declarations.force_opaque lc)
+	      | Def c ->
+		str "Definition " ++ print_basename con ++ cut () ++
+		str "  : " ++ pr_ltype typ ++ cut () ++ str " := " ++
+		pr_lconstr (Declarations.force c))
+          ++ str "." ++ fnl () ++ fnl ()
       | "INDUCTIVE" ->
-	  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 -> (mind,x)) (Array.length mipv) in
-	  pr_mutual_inductive mib.mind_finite names ++ str "." ++
-	  fnl () ++ fnl ()
+	  let mind = Global.mind_of_delta_kn kn in
+	  let mib = Global.lookup_mind mind in
+	  pr_mutual_inductive_body (Global.env()) mind mib ++
+	    str "." ++ fnl () ++ fnl ()
       | "MODULE" ->
 	  (* TODO: make it reparsable *)
 	  let (mp,_,l) = repr_kn kn in
@@ -641,16 +603,6 @@ 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
-      frec (n-1) (vec.(n)::lf)
-    else
-      frec (n-1) lf
-  in
-  frec (Array.length vec -1) []
-
 (* This is designed to print the contents of an opened section *)
 let read_sec_context r =
   let loc,qid = qualid_of_reference r in
@@ -708,7 +660,7 @@ let print_opaque_name qid =
   match global qid with
     | ConstRef cst ->
 	let cb = Global.lookup_constant cst in
-        if cb.const_body <> None then
+        if constant_has_body cb then
 	  print_constant_with_infos cst
         else
 	  error "Not a defined constant."
@@ -727,6 +679,7 @@ let print_about_any k =
       pr_infos_list
        ([print_ref false ref; blankline] @
 	print_name_infos ref @
+	print_simpl_behaviour ref @
 	print_opacity ref @
 	[hov 0 (str "Expands to: " ++ pr_located_qualid k)])
   | Syntactic kn ->
@@ -744,15 +697,6 @@ let print_about = function
   | Genarg.AN ref ->
       print_about_any (locate_any_name ref)
 
-let unfold_head_fconst =
-  let rec unfrec k = match kind_of_term k with
-    | 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
-  unfrec
-
 (* for debug *)
 let inspect depth =
   print_context false (Some depth) (Lib.contents_after None)
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index fef66a63..6d9c6ecc 100644
--- a/parsing/prettyp.mli
+++ b/parsing/prettyp.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: prettyp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
@@ -19,9 +16,8 @@ open Reductionops
 open Libnames
 open Nametab
 open Genarg
-(*i*)
 
-(* A Pretty-Printer for the Calculus of Inductive Constructions. *)
+(** A Pretty-Printer for the Calculus of Inductive Constructions. *)
 
 val assumptions_for_print : name list -> Termops.names_context
 
@@ -37,29 +33,27 @@ val print_judgment : env -> unsafe_judgment -> std_ppcmds
 val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds
 val print_eval :
   reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds
-(* 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 or_by_notation -> std_ppcmds
 val print_opaque_name : reference -> std_ppcmds
 val print_about : reference or_by_notation -> std_ppcmds
 val print_impargs : reference or_by_notation -> std_ppcmds
 
-(* Pretty-printing functions for classes and coercions *)
+(** Pretty-printing functions for classes and coercions *)
 val print_graph : unit -> std_ppcmds
 val print_classes : unit -> std_ppcmds
 val print_coercions : unit -> std_ppcmds
 val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds
 val print_canonical_projections : unit -> std_ppcmds
 
-(* Pretty-printing functions for type classes and instances *)
+(** Pretty-printing functions for type classes and instances *)
 val print_typeclasses : unit -> std_ppcmds
 val print_instances : global_reference -> std_ppcmds
 val print_all_instances : unit -> std_ppcmds
 
 val inspect : int -> std_ppcmds
 
-(* Locate *)
+(** Locate *)
 val print_located_qualid : reference -> std_ppcmds
 
 type object_pr = {
@@ -70,7 +64,6 @@ type object_pr = {
   print_module              : bool -> Names.module_path -> std_ppcmds;
   print_modtype             : module_path -> std_ppcmds;
   print_named_decl          : identifier * constr option * types -> std_ppcmds;
-  print_leaf_entry          : bool -> Libnames.object_name * Libobject.obj -> Pp.std_ppcmds;
   print_library_entry       : bool -> (object_name * Lib.node) -> std_ppcmds option;
   print_context             : bool -> int option -> Lib.library_segment -> std_ppcmds;
   print_typed_value_in_env  : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds;
diff --git a/parsing/printer.ml b/parsing/printer.ml
index 75cdead9..0b9ce918 100644
--- a/parsing/printer.ml
+++ b/parsing/printer.ml
@@ -1,19 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: printer.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Nameops
 open Term
-open Termops
 open Sign
 open Environ
 open Global
@@ -22,18 +19,18 @@ open Libnames
 open Nametab
 open Evd
 open Proof_type
-open Decl_mode
 open Refiner
 open Pfedit
 open Ppconstr
 open Constrextern
 open Tacexpr
 
-let emacs_str s alts =
-  match !Flags.print_emacs, !Flags.print_emacs_safechar with
-    | true, true -> alts
-    | true , false -> s
-    | false,_ -> ""
+open Store.Field
+
+let emacs_str s =
+  if !Flags.print_emacs then s else ""
+let delayed_emacs_cmd s =
+  if !Flags.print_emacs then s () else str ""
 
 (**********************************************************************)
 (** Terms                                                             *)
@@ -63,7 +60,7 @@ let pr_constr_under_binders_env_gen pr env (ids,c) =
   (* 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
+  pr (Termops.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
@@ -88,30 +85,30 @@ let pr_ljudge_env env j =
 
 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 =
-  pr_constr_expr (extern_rawconstr (vars_of_env env) c)
+let pr_lglob_constr_env env c =
+  pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c)
+let pr_glob_constr_env env c =
+  pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c)
 
-let pr_lrawconstr c =
-  pr_lconstr_expr (extern_rawconstr Idset.empty c)
-let pr_rawconstr c =
-  pr_constr_expr (extern_rawconstr Idset.empty c)
+let pr_lglob_constr c =
+  pr_lconstr_expr (extern_glob_constr Idset.empty c)
+let pr_glob_constr c =
+  pr_constr_expr (extern_glob_constr Idset.empty c)
 
 let pr_cases_pattern t =
   pr_cases_pattern_expr (extern_cases_pattern Idset.empty t)
 
 let pr_lconstr_pattern_env env c =
-  pr_lconstr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c)
+  pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c)
 let pr_constr_pattern_env env c =
-  pr_constr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c)
+  pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c)
 
 let pr_lconstr_pattern t =
-  pr_lconstr_pattern_expr (extern_constr_pattern empty_names_context t)
+  pr_lconstr_pattern_expr (extern_constr_pattern Termops.empty_names_context t)
 let pr_constr_pattern t =
-  pr_constr_pattern_expr (extern_constr_pattern empty_names_context t)
+  pr_constr_pattern_expr (extern_constr_pattern Termops.empty_names_context t)
 
-let pr_sort s = pr_rawsort (extern_sort s)
+let pr_sort s = pr_glob_sort (extern_sort s)
 
 let _ = Termops.set_print_constr pr_lconstr_env
 
@@ -121,7 +118,7 @@ let _ = Termops.set_print_constr pr_lconstr_env
 let pr_global_env = pr_global_env
 let pr_global = pr_global_env Idset.empty
 
-let pr_constant env cst = pr_global_env (vars_of_env env) (ConstRef cst)
+let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst)
 let pr_existential env ev = pr_lconstr_env env (mkEvar ev)
 let pr_inductive env ind = pr_lconstr_env env (mkInd ind)
 let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
@@ -129,8 +126,8 @@ let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
 let pr_evaluable_reference ref =
   pr_global (Tacred.global_of_evaluable_reference ref)
 
-(*let pr_rawterm t =
-  pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)*)
+(*let pr_glob_constr t =
+  pr_lconstr (Constrextern.extern_glob_constr Idset.empty t)*)
 
 (*open Pattern
 
@@ -222,7 +219,7 @@ let pr_context_limit n env =
 	   else
              let pidt = pr_var_decl env d in
 	     (i+1, (pps ++ fnl () ++
-		      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
+		      str (emacs_str "") ++
 		      pidt)))
         env ~init:(0,(mt ()))
     in
@@ -231,7 +228,7 @@ let pr_context_limit n env =
         (fun env d pps ->
            let pnat = pr_rel_decl env d in
 	   (pps ++ fnl () ++
-	      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
+	      str (emacs_str "") ++
 	      pnat))
         env ~init:(mt ())
     in
@@ -243,18 +240,6 @@ let pr_context_of env = match Flags.print_hyps_limit () with
 
 (* display goal parts (Proof mode) *)
 
-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 ++
-		 fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") ++
-		 pr_var_decl env d
-	     else
-	       pps)
-          env ~init:(mt ()))
-
-
 let pr_predicate pr_elt (b, elts) =
   let pr_elts = prlist_with_sep spc pr_elt elts in
     if b then
@@ -270,39 +255,34 @@ 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 () ++
-      str (emacs_str (String.make 1 (Char.chr 253)) "") in
-    hv 0 (prlist_with_sep mt pr_one metas)
-
 (* display complete goal *)
-let default_pr_goal g =
-  let env = evar_unfiltered_env g in
+let default_pr_goal gs =
+  let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in
+  let env = Goal.V82.unfiltered_env sigma g in
   let preamb,thesis,penv,pc =
-    if g.evar_extra = None then
-          mt (), mt (),
-	  pr_context_of env,
-	  pr_ltype_env_at_top env g.evar_concl
-    else
-      (str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
-      (str "thesis := "  ++ fnl ()),
-       pr_context_of env,
-       pr_ltype_env_at_top env g.evar_concl
+    mt (), mt (),
+    pr_context_of env,
+    pr_ltype_env_at_top env (Goal.V82.concl sigma g)
   in
     preamb ++
     str"  " ++ hv 0 (penv ++ fnl () ++
-		       str (emacs_str (String.make 1 (Char.chr 253)) "")  ++
+		       str (emacs_str "")  ++
 		       str "============================" ++ fnl ()  ++
 		       thesis ++ str " " ++  pc) ++ fnl ()
 
+(* display a goal tag *)
+let pr_goal_tag g =
+  let s = " (ID " ^ Goal.uid g ^ ")" in
+  str (emacs_str s)
+
 (* display the conclusion of a goal *)
-let pr_concl n g =
-  let env = evar_env g in
-  let pc = pr_ltype_env_at_top env g.evar_concl in
-    str (emacs_str (String.make 1 (Char.chr 253)) "")  ++
-      str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" "  ++ pc
+let pr_concl n sigma g =
+  let (g,sigma) = Goal.V82.nf_evar sigma g in
+  let env = Goal.V82.env sigma g in
+  let pc = pr_ltype_env_at_top env (Goal.V82.concl sigma g) in
+    str (emacs_str "")  ++
+      str "subgoal " ++ int n ++ pr_goal_tag g ++
+      str " is:" ++ cut () ++ str" "  ++ pc
 
 (* display evar type: a context and a type *)
 let pr_evgl_sign gl =
@@ -316,6 +296,12 @@ let pr_evgl_sign gl =
   let pc = pr_lconstr gl.evar_concl in
   hov 0 (str"[" ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]" ++ spc () ++ warn)
 
+(* Print an existential variable *)
+
+let pr_evar (ev, evd) =
+  let pegl = pr_evgl_sign evd in
+  (hov 0 (str (string_of_existential ev)  ++ str " : " ++ pegl))
+
 (* Print an enumerated list of existential variables *)
 let rec pr_evars_int i = function
   | [] -> (mt ())
@@ -326,20 +312,42 @@ let rec pr_evars_int i = function
               str (string_of_existential ev)  ++ str " : " ++ pegl)) ++
       fnl () ++ pei
 
-let default_pr_subgoal n =
+let default_pr_subgoal n sigma =
   let rec prrec p = function
     | [] -> error "No such goal."
     | g::rest ->
        	if p = 1 then
-          let pg = default_pr_goal g in
-          v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg)
+          let pg = default_pr_goal { sigma=sigma ; it=g } in
+          v 0 (str "subgoal " ++ int n ++ pr_goal_tag g
+	       ++ str " is:" ++ cut () ++ pg)
        	else
 	  prrec (p-1) rest
   in
   prrec n
 
+let emacs_print_dependent_evars sigma seeds =
+  let evars () =
+    let evars = Evarutil.evars_of_evars_in_types_of_list sigma seeds in
+    let evars =
+      Intmap.fold begin fun e i s ->
+	let e' = str (string_of_existential e) in
+	match i with
+	| None -> s ++ str" " ++ e' ++ str " open,"
+	| Some i ->
+	  s ++ str " " ++ e' ++ str " using " ++
+	    Intset.fold begin fun d s ->
+	      str (string_of_existential d) ++ str " " ++ s
+	    end i (str ",")
+      end evars (str "")
+    in
+    cut () ++ 
+    str "(dependent evars:" ++ evars ++ str ")" ++ fnl ()
+  in
+  delayed_emacs_cmd evars
+
 (* Print open subgoals. Checks for uninstantiated existential variables *)
-let default_pr_subgoals close_cmd sigma = function
+(* spiwack: [seeds] is for printing dependent evars in emacs mode. *)
+let default_pr_subgoals close_cmd sigma seeds = function
   | [] ->
       begin
 	match close_cmd with
@@ -349,37 +357,45 @@ let default_pr_subgoals close_cmd sigma = function
 	| None ->
 	    let exl = Evarutil.non_instantiated sigma in
 	      if exl = [] then
-		(str"Proof completed." ++ fnl ())
+		(str"No more subgoals." ++ fnl ()
+		 ++ emacs_print_dependent_evars sigma seeds)
 	      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)
+		   ++ emacs_print_dependent_evars sigma seeds)
       end
   | [g] ->
-      let pg = default_pr_goal g in
-      v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
+      let pg = default_pr_goal { it = g ; sigma = sigma } in
+      v 0 (
+	str ("1 "^"subgoal") ++ pr_goal_tag g ++ cut () ++ pg
+	++ emacs_print_dependent_evars sigma seeds
+      )
   | g1::rest ->
       let rec pr_rec n = function
         | [] -> (mt ())
         | g::rest ->
-            let pc = pr_concl n g in
+            let pc = pr_concl n sigma g in
             let prest = pr_rec (n+1) rest in
             (cut () ++ pc ++ prest)
       in
-      let pg1 = default_pr_goal g1 in
+      let pg1 = default_pr_goal { it = g1 ; sigma = sigma } in
       let prest = pr_rec 2 rest in
-      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut ()
-	   ++ pg1 ++ prest ++ fnl ())
-
+      v 0 (
+	int(List.length rest+1) ++ str" subgoals" ++
+          str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut ()
+	++ pg1 ++ prest ++ fnl ()
+	++ emacs_print_dependent_evars sigma seeds
+      )
 
 (**********************************************************************)
 (* Abstraction layer                                                  *)
 
 
 type printer_pr = {
- pr_subgoals            : string option -> evar_map -> goal list -> std_ppcmds;
- pr_subgoal             : int -> goal list -> std_ppcmds;
- pr_goal                : goal -> std_ppcmds;
+ pr_subgoals            : string option -> evar_map -> evar list -> goal list -> std_ppcmds;
+ pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds;
+ pr_goal                : goal sigma -> std_ppcmds;
 }
 
 let default_printer_pr = {
@@ -400,25 +416,41 @@ let pr_goal     x = !printer_pr.pr_goal     x
 (**********************************************************************)
 
 let pr_open_subgoals () =
-  let pfts = get_pftreestate () in
-  let gls = fst (frontier (proof_of_pftreestate pfts)) in
-  match focus() with
-    | 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
-	  pr_subgoal n gls
-	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)
+  let p = Proof_global.give_me_the_proof () in
+  let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in
+  let seeds = Proof.V82.top_evars p in
+  begin match goals with
+  | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
+            begin match bgoals with
+	    | [] -> pr_subgoals None sigma seeds goals
+	    | _ -> pr_subgoals None bsigma seeds bgoals ++ fnl () ++ fnl () ++
+		      str"This subproof is complete, but there are still unfocused goals:"
+		(* spiwack: to stay compatible with the proof general and coqide,
+		    I use print the message after the goal. It would be better to have
+		    something like:
+ 		      str"This subproof is complete, but there are still unfocused goals:" 
+		      ++ fnl () ++ fnl () ++ pr_subgoals None bsigma bgoals
+		    instead. But it doesn't quite work.
+		*)
+	    end
+  | _ -> pr_subgoals None sigma seeds goals
+  end
 
 let pr_nth_open_subgoal n =
-  let pf = proof_of_pftreestate (get_pftreestate ()) in
-  pr_subgoal n (fst (frontier pf))
+  let pf = get_pftreestate () in
+  let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in
+  pr_subgoal n sigma gls
+
+let pr_goal_by_id id =
+  let p = Proof_global.give_me_the_proof () in
+  let g = Goal.get_by_uid id in
+  let pr gs = 
+    v 0 (str ("goal / evar " ^ id ^ " is:") ++ cut ()
+	 ++ pr_goal gs)
+  in
+  try
+    Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma})
+  with Not_found -> error "Invalid goal identifier."
 
 (* Elementary tactics *)
 
@@ -458,7 +490,7 @@ let pr_prim_rule = function
         | [] -> mt () in
       (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
   | Refine c ->
-      str(if occur_meta c then "refine " else "exact ") ++
+      str(if Termops.occur_meta c then "refine " else "exact ") ++
       Constrextern.with_meta_as_hole pr_constr c
 
   | Convert_concl (c,_) ->
@@ -570,3 +602,90 @@ let pr_instance_gmap insts =
   prlist_with_sep fnl (fun (gr, insts) ->
     prlist_with_sep fnl pr_instance (cmap_to_list insts))
     (Gmap.to_list insts)
+
+(** Inductive declarations *)
+
+open Declarations
+open Termops
+open Reduction
+open Inductive
+open Inductiveops
+
+let print_params env params =
+  if params = [] then mt () else pr_rel_context env params ++ brk(1,2)
+
+let print_constructors envpar names types =
+  let pc =
+    prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
+      (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c)
+      (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
+  in
+  hv 0 (str "  " ++ pc)
+
+let build_ind_type env mip =
+  match mip.mind_arity with
+    | Monomorphic ar -> ar.mind_user_arity
+    | Polymorphic ar ->
+      it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt
+
+let print_one_inductive env mib ((_,i) as ind) =
+  let mip = mib.mind_packets.(i) in
+  let params = mib.mind_params_ctxt in
+  let args = extended_rel_list 0 params in
+  let arity = hnf_prod_applist env (build_ind_type env mip) args in
+  let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in
+  let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
+  let envpar = push_rel_context params env in
+  hov 0 (
+    pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++
+    str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++
+  brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes
+
+let print_mutual_inductive env mind mib =
+  let inds = list_tabulate (fun x -> (mind,x)) (Array.length mib.mind_packets)
+  in
+  hov 0 (
+    str (if mib.mind_finite then "Inductive " else "CoInductive ") ++
+    prlist_with_sep (fun () -> fnl () ++ str"  with ")
+      (print_one_inductive env mib) inds)
+
+let get_fields =
+  let rec prodec_rec l subst c =
+    match kind_of_term c with
+    | Prod (na,t,c) ->
+	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
+	prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c
+    | LetIn (na,b,_,c) ->
+	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
+	prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c
+    | _               -> List.rev l
+  in
+  prodec_rec [] []
+
+let print_record env mind mib =
+  let mip = mib.mind_packets.(0) in
+  let params = mib.mind_params_ctxt in
+  let args = extended_rel_list 0 params in
+  let arity = hnf_prod_applist env (build_ind_type env mip) args in
+  let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in
+  let cstrtype = hnf_prod_applist env cstrtypes.(0) args in
+  let fields = get_fields cstrtype in
+  let envpar = push_rel_context params env in
+  hov 0 (
+    hov 0 (
+      str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++
+      print_params env params ++
+      str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++
+      str ":= " ++ pr_id mip.mind_consnames.(0)) ++
+    brk(1,2) ++
+    hv 2 (str "{ " ++
+      prlist_with_sep (fun () -> str ";" ++ brk(2,0))
+        (fun (id,b,c) ->
+	  pr_id id ++ str (if b then " : " else " := ") ++
+	  pr_lconstr_env envpar c) fields) ++ str" }")
+
+let pr_mutual_inductive_body env mind mib =
+  if mib.mind_record & not !Flags.raw_print then
+    print_record env mind mib
+  else
+    print_mutual_inductive env mind mib
diff --git a/parsing/printer.mli b/parsing/printer.mli
index 99ab3ca3..2d437c20 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -1,33 +1,29 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: printer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Names
 open Libnames
 open Term
 open Sign
 open Environ
-open Rawterm
+open Glob_term
 open Pattern
 open Nametab
 open Termops
 open Evd
 open Proof_type
-open Rawterm
+open Glob_term
 open Tacexpr
-(*i*)
 
-(* These are the entry points for printing terms, context, tac, ... *)
+(** These are the entry points for printing terms, context, tac, ... *)
 
-(* Terms *)
+(** Terms *)
 
 val pr_lconstr_env         : env -> constr -> std_ppcmds
 val pr_lconstr_env_at_top  : env -> constr -> std_ppcmds
@@ -58,11 +54,11 @@ val pr_type                : types -> std_ppcmds
 val pr_ljudge_env          : env -> unsafe_judgment -> std_ppcmds * std_ppcmds
 val pr_ljudge              : unsafe_judgment -> std_ppcmds * std_ppcmds
 
-val pr_lrawconstr_env      : env -> rawconstr -> std_ppcmds
-val pr_lrawconstr          : rawconstr -> std_ppcmds
+val pr_lglob_constr_env      : env -> glob_constr -> std_ppcmds
+val pr_lglob_constr          : glob_constr -> std_ppcmds
 
-val pr_rawconstr_env       : env -> rawconstr -> std_ppcmds
-val pr_rawconstr           : rawconstr -> std_ppcmds
+val pr_glob_constr_env       : env -> glob_constr -> std_ppcmds
+val pr_glob_constr           : glob_constr -> std_ppcmds
 
 val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds
 val pr_lconstr_pattern     : constr_pattern -> std_ppcmds
@@ -74,7 +70,7 @@ val pr_cases_pattern       : cases_pattern -> std_ppcmds
 
 val pr_sort                : sorts -> std_ppcmds
 
-(* Printing global references using names as short as possible *)
+(** Printing global references using names as short as possible *)
 
 val pr_global_env          : Idset.t -> global_reference -> std_ppcmds
 val pr_global              : global_reference -> std_ppcmds
@@ -85,7 +81,7 @@ val pr_constructor         : env -> constructor -> std_ppcmds
 val pr_inductive           : env -> inductive -> std_ppcmds
 val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds
 
-(* Contexts *)
+(** Contexts *)
 
 val pr_ne_context_of       : std_ppcmds -> env -> std_ppcmds
 
@@ -98,47 +94,56 @@ val pr_rel_context         : env -> rel_context -> std_ppcmds
 val pr_rel_context_of      : env -> std_ppcmds
 val pr_context_of          : env -> std_ppcmds
 
-(* Predicates *)
+(** Predicates *)
 
 val pr_predicate           : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds
 val pr_cpred               : Cpred.t -> std_ppcmds
 val pr_idpred              : Idpred.t -> std_ppcmds
 val pr_transparent_state   : transparent_state -> std_ppcmds
 
-(* Proofs *)
+(** Proofs *)
 
-val pr_goal                : goal -> std_ppcmds
-val pr_subgoals            : string option -> evar_map -> goal list -> std_ppcmds
-val pr_subgoal             : int -> goal list -> std_ppcmds
+val pr_goal                : goal sigma -> std_ppcmds
+val pr_subgoals            : string option -> evar_map -> evar list -> goal list -> std_ppcmds
+val pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds
+val pr_concl               : int -> evar_map -> goal -> std_ppcmds
 
 val pr_open_subgoals       : unit -> std_ppcmds
 val pr_nth_open_subgoal    : int -> std_ppcmds
+val pr_evar                : (evar * evar_info) -> std_ppcmds
 val pr_evars_int           : int -> (evar * evar_info) list -> std_ppcmds
 
 val pr_prim_rule           : prim_rule -> std_ppcmds
 
-(* Emacs/proof general support *)
-(* (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
+(** Emacs/proof general support 
+   (emacs_str s) outputs
+    - s if emacs mode,
+    - nothing otherwise.
+    This function was previously used to insert special chars like
+    [(String.make 1 (Char.chr 253))] to parenthesize sub-parts of the
+    proof context for proof by pointing. This part of the code is
+    removed for now because it interacted badly with utf8. We may put
+    it back some day using some xml-like tags instead of special
+    chars. See for example the <prompt> tag in the prompt when in
+    emacs mode. *)
+val emacs_str              : string -> string
 
-(* Backwards compatibility *)
+(** Backwards compatibility *)
 
-val prterm                 : constr -> std_ppcmds (* = pr_lconstr *)
+val prterm                 : constr -> std_ppcmds (** = pr_lconstr *)
 
 
-(* spiwack: printer function for sets of Environ.assumption.
+(** spiwack: printer function for sets of Environ.assumption.
             It is used primarily by the Print Assumption command. *)
 val pr_assumptionset :
   env -> Term.types Assumptions.ContextObjectMap.t ->std_ppcmds
 
+val pr_goal_by_id : string -> std_ppcmds
 
 type printer_pr = {
- pr_subgoals            : string option -> evar_map -> goal list -> std_ppcmds;
- pr_subgoal             : int -> goal list -> std_ppcmds;
- pr_goal                : goal -> std_ppcmds;
+ pr_subgoals            : string option -> evar_map -> evar list -> goal list -> std_ppcmds;
+ pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds;
+ pr_goal                : goal sigma -> std_ppcmds;
 };;
 
 val set_printer_pr : printer_pr -> unit
@@ -147,3 +152,8 @@ val default_printer_pr : printer_pr
 
 val pr_instance_gmap : (global_reference, Typeclasses.instance Names.Cmap.t) Gmap.t ->
   Pp.std_ppcmds
+
+(** Inductive declarations *)
+
+val pr_mutual_inductive_body :
+  env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
diff --git a/parsing/printmod.ml b/parsing/printmod.ml
index 6339ed8f..9cf76585 100644
--- a/parsing/printmod.ml
+++ b/parsing/printmod.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,6 +12,27 @@ open Names
 open Declarations
 open Nameops
 open Libnames
+open Goptions
+
+(** Note: there is currently two modes for printing modules.
+    - The "short" one, that just prints the names of the fields.
+    - The "rich" one, that also tries to print the types of the fields.
+    The short version used to be the default behavior, but now we print
+    types by default. The following option allows to change this.
+    Technically, the environments in this file are either None in
+    the "short" mode or (Some env) in the "rich" one.
+*)
+
+let short = ref false
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "short module printing";
+      optkey   = ["Short";"Module";"Printing"];
+      optread  = (fun () -> !short) ;
+      optwrite = ((:=) short) }
 
 let get_new_id locals id =
   let rec get_id l id =
@@ -47,92 +68,141 @@ let print_kn locals kn =
 	with
 	    Not_found -> print_modpath locals kn
 
-let rec flatten_app mexpr l = match mexpr with
-  | SEBapply (mexpr,marg,_) -> flatten_app mexpr (marg::l)
-  | mexpr -> mexpr::l
+let nametab_register_dir mp =
+  let id = id_of_string "FAKETOP" in
+  let fp = Libnames.make_path empty_dirpath id in
+  let dir = make_dirpath [id] in
+  Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath)));
+  fp
 
-let rec print_module name locals with_body mb =
-  let body = match with_body, mb.mod_expr with
-    | false, _
-    | true, None -> mt()
-    | true, Some mexpr ->
-	spc () ++ str ":= " ++ print_modexpr locals mexpr
-  in
+(** Nota: the [global_reference] we register in the nametab below
+    might differ from internal ones, since we cannot recreate here
+    the canonical part of constant and inductive names, but only
+    the user names. This works nonetheless since we search now
+    [Nametab.the_globrevtab] modulo user name. *)
 
-  let modtype = 
-    match mb.mod_type with
-    | t -> spc () ++ str": " ++ 
-	print_modtype locals t
+let nametab_register_body mp fp (l,body) =
+  let push id ref =
+    Nametab.push (Nametab.Until 1) (make_path (dirpath fp) id) ref
   in
-    hv 2 (str "Module " ++ name ++ modtype ++ body)
+  match body with
+    | SFBmodule _ -> () (* TODO *)
+    | SFBmodtype _ -> () (* TODO *)
+    | SFBconst _ ->
+      push (id_of_label l) (ConstRef (make_con mp empty_dirpath l))
+    | SFBmind mib ->
+      let mind = make_mind mp empty_dirpath l in
+      Array.iteri
+	(fun i mip ->
+	  push mip.mind_typename (IndRef (mind,i));
+	  Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1)))
+	    mip.mind_consnames)
+	mib.mind_packets
+
+let print_body is_impl env mp (l,body) =
+  let name = str (string_of_label l) in
+  hov 2 (match body with
+    | SFBmodule _ -> str "Module " ++ name
+    | SFBmodtype _ -> str "Module Type " ++ name
+    | SFBconst cb ->
+      (match cb.const_body with
+	| Def _ -> str "Definition "
+	| OpaqueDef _ when is_impl -> str "Theorem "
+	| _ -> str "Parameter ") ++ name ++
+      (match env with
+	  | None -> mt ()
+	  | Some env ->
+	    str " :" ++ spc () ++
+	    hov 0 (Printer.pr_ltype_env env
+		     (Typeops.type_of_constant_type env cb.const_type)) ++
+	    (match cb.const_body with
+	      | Def l when is_impl ->
+		spc () ++
+		hov 2 (str ":= " ++
+		       Printer.pr_lconstr_env env (Declarations.force l))
+	      | _ -> mt ()) ++
+            str ".")
+    | SFBmind mib ->
+      try
+	let env = Option.get env in
+	Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib
+      with _ ->
+	(if mib.mind_finite then str "Inductive " else str "CoInductive")
+	++ name)
+
+let print_struct is_impl env mp struc =
+  begin
+    (* If [mp] is a globally visible module, we simply import it *)
+    try Declaremods.really_import_module mp
+    with _ ->
+    (* Otherwise we try to emulate an import by playing with nametab *)
+      let fp = nametab_register_dir mp in
+      List.iter (nametab_register_body mp fp) struc
+  end;
+  prlist_with_sep spc (print_body is_impl env mp) struc
 
-and print_modtype locals mty =
+let rec flatten_app mexpr l = match mexpr with
+  | SEBapply (mexpr, SEBident arg,_) -> flatten_app mexpr (arg::l)
+  | SEBident mp -> mp::l
+  | _ -> assert false
+
+let rec print_modtype env mp locals mty =
   match mty with
     | SEBident kn -> print_kn locals kn
     | SEBfunctor (mbid,mtb1,mtb2) ->
-      (*    let 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 ++
-		 str ")" ++ spc() ++ print_modtype locals' mtb2)
-  | 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 mp1 = MPbound mbid in
+      let env' = Option.map
+	  (Modops.add_module (Modops.module_body_of_type mp1 mtb1)) env in
+      let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in
+      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals
+      in
+      (try Declaremods.process_module_seb_binding mbid seb1 with _ -> ());
+      hov 2 (str "Funsig" ++ spc () ++ str "(" ++
+	       pr_id (id_of_mbid mbid) ++ str ":" ++
+	       print_modtype env mp1 locals seb1 ++
+	       str ")" ++ spc() ++ print_modtype env' mp locals' mtb2)
+  | SEBstruct (sign) ->
+      let env' = Option.map
+	(Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in
+      hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++
+	    brk (1,-2) ++ str "End")
+  | SEBapply _ ->
+      let lapp = flatten_app mty [] in
       let fapp = List.hd lapp in
       let mapp = List.tl lapp in
-	hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++
-		 prlist_with_sep spc (print_modexpr locals) mapp ++ str")")
+      hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++
+		 prlist_with_sep spc (print_modpath locals) mapp ++ str")")
   | SEBwith(seb,With_definition_body(idl,cb))->
+      let env' = None in (* TODO: build a proper environment if env <> None *)
       let s = (String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++
+      hov 2 (print_modtype env' mp locals seb ++ spc() ++ str "with" ++ spc() ++
 	       str "Definition"++ spc() ++ str s ++ spc() ++  str ":="++ spc())
   | SEBwith(seb,With_module_body(idl,mp))->
       let s =(String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++
+      hov 2 (print_modtype env mp locals seb ++ spc() ++ str "with" ++ spc() ++
 	       str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc())
 
-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 "
-    | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
-  in
-    prlist_with_sep spc print_spec sign
-
-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 "
-    | 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
+let rec print_modexpr env mp 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
-      in *)
+      let mp' = MPbound mbid in
+      let env' = Option.map
+	(Modops.add_module (Modops.module_body_of_type mp' mty)) env in
+      let typ = Option.default mty.typ_expr mty.typ_expr_alg in
       let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
+      (try Declaremods.process_module_seb_binding mbid typ with _ -> ());
       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 ( 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"
+	     str ":" ++ print_modtype env mp' locals typ ++
+      str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr)
+  | SEBstruct struc ->
+      let env' = Option.map
+	(Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in
+      hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++
+	    brk (1,-2) ++ str "End")
+  | SEBapply _ ->
+      let lapp = flatten_app mexpr [] in
+      hov 3 (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")")
+  | SEBwith (_,_)-> anomaly "Not available yet"
 
 
 let rec printable_body dir =
@@ -146,13 +216,43 @@ let rec printable_body dir =
     with
 	Not_found -> true
 
+(** Since we might play with nametab above, we should reset to prior
+    state after the printing *)
 
-let print_module with_body mp =
+let print_modexpr' env mp mexpr =
+  States.with_state_protection (print_modexpr env mp []) mexpr
+let print_modtype' env mp mty =
+  States.with_state_protection (print_modtype env mp []) mty
+
+let print_module' env mp with_body mb =
   let name = print_modpath [] mp in
-    print_module name [] with_body (Global.lookup_module mp) ++ fnl ()
+  let body = match with_body, mb.mod_expr with
+    | false, _
+    | true, None -> mt()
+    | true, Some mexpr ->
+	spc () ++ str ":= " ++ print_modexpr' env mp mexpr
+  in
+  let modtype = brk (1,1) ++ str": " ++ print_modtype' env mp mb.mod_type
+  in
+  hv 0 (str "Module " ++ name ++ modtype ++ body)
+
+exception ShortPrinting
+
+let print_module with_body mp =
+  let me = Global.lookup_module mp in
+  try
+    if !short then raise ShortPrinting;
+    print_module' (Some (Global.env ())) mp with_body me ++ fnl ()
+  with _ ->
+    print_module' None mp with_body me ++ fnl ()
 
 let print_modtype kn =
   let mtb = Global.lookup_modtype kn in
   let name = print_kn [] kn in
-      str "Module Type " ++ name ++ str " = " ++
-	print_modtype [] mtb.typ_expr ++ fnl ()
+  hv 1
+    (str "Module Type " ++ name ++ str " =" ++ spc () ++
+     (try
+	if !short then raise ShortPrinting;
+	print_modtype' (Some (Global.env ())) kn mtb.typ_expr
+      with _ ->
+	print_modtype' None kn mtb.typ_expr))
diff --git a/parsing/printmod.mli b/parsing/printmod.mli
index 77ff34f1..a45bdb98 100644
--- a/parsing/printmod.mli
+++ b/parsing/printmod.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,7 +9,7 @@
 open Pp
 open Names
 
-(* false iff the module is an element of an open module type *)
+(** false iff the module is an element of an open module type *)
 val printable_body : dir_path -> bool
 
 val print_module : bool -> module_path -> std_ppcmds
diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4
index 3d203dbe..60543269 100644
--- a/parsing/q_constr.ml4
+++ b/parsing/q_constr.ml4
@@ -1,41 +1,41 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
+(*i camlp4deps: "tools/compat5b.cmo" i*)
 
-(* $Id: q_constr.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Rawterm
+open Glob_term
 open Term
 open Names
 open Pattern
 open Q_util
 open Util
+open Compat
 open Pcaml
+open PcamlSig
 
 let loc = dummy_loc
 let dloc = <:expr< Util.dummy_loc >>
 
 let apply_ref f l =
   <:expr<
-    Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
+    Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
   >>
 
 EXTEND
   GLOBAL: expr;
   expr:
     [ [ "PATTERN"; "["; c = constr; "]" ->
-      <:expr< snd (Pattern.pattern_of_rawconstr $c$) >> ] ]
+      <:expr< snd (Pattern.pattern_of_glob_constr $c$) >> ] ]
   ;
   sort:
-    [ [ "Set"  -> RProp Pos
-      | "Prop" -> RProp Null
-      | "Type" -> RType None ] ]
+    [ [ "Set"  -> GProp Pos
+      | "Prop" -> GProp Null
+      | "Type" -> GType None ] ]
   ;
   ident:
     [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ]
@@ -44,24 +44,24 @@ EXTEND
     [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ]
   ;
   string:
-    [ [ UIDENT | LIDENT ] ]
+    [ [ s = UIDENT -> s | s = LIDENT -> s ] ]
   ;
   constr:
     [ "200" RIGHTA
       [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr ->
-        <:expr< Rawterm.RProd ($dloc$,Name $id$,Rawterm.Explicit,$c1$,$c2$) >>
+        <:expr< Glob_term.GProd ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >>
       | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr ->
-        <:expr< Rawterm.RLambda ($dloc$,Name $id$,Rawterm.Explicit,$c1$,$c2$) >>
+        <:expr< Glob_term.GLambda ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >>
       | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr ->
-        <:expr< Rawterm.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
+        <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
       (* fix todo *)
       ]
     | "100" RIGHTA
       [ c1 = constr; ":"; c2 = SELF ->
-        <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
+        <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
     | "90" RIGHTA
       [ c1 = constr; "->"; c2 = SELF ->
-        <:expr< Rawterm.RProd ($dloc$,Anonymous,Rawterm.Explicit,$c1$,$c2$) >> ]
+        <:expr< Glob_term.GProd ($dloc$,Anonymous,Glob_term.Explicit,$c1$,$c2$) >> ]
     | "75" RIGHTA
       [ "~"; c = constr ->
         apply_ref <:expr< coq_not_ref >> [c] ]
@@ -71,15 +71,15 @@ EXTEND
     | "10" LEFTA
       [ f = constr; args = LIST1 NEXT ->
         let args = mlexpr_of_list (fun x -> x) args in
-        <:expr< Rawterm.RApp ($dloc$,$f$,$args$) >> ]
+        <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ]
     | "0"
-      [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >>
-      | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >>
-      | "_" -> <:expr< Rawterm.RHole ($dloc$, QuestionMark (Define False)) >>
-      | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >>
+      [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >>
+      | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >>
+      | "_" -> <:expr< Glob_term.GHole ($dloc$, QuestionMark (Define False)) >>
+      | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >>
       | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" ->
           apply_ref <:expr< coq_sumbool_ref >> [c1;c2]
-      | "%"; e = string -> <:expr< Rawterm.RRef ($dloc$,Lazy.force $lid:e$) >>
+      | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >>
       | c = match_constr -> c
       | "("; c = constr LEVEL "200"; ")" -> c ] ]
   ;
@@ -87,7 +87,7 @@ EXTEND
     [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type;
         "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" ->
           let br = mlexpr_of_list (fun x -> x) br in
-     <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >>
+     <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >>
     ] ]
   ;
   match_type:
@@ -108,13 +108,13 @@ EXTEND
     [ [ "%"; e = string; lip = LIST0 patvar ->
         let lp = mlexpr_of_list (fun (_,x) -> x) lip in
         let lid = List.flatten (List.map fst lip) in
-        lid, <:expr< Rawterm.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >>
+        lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >>
       | p = patvar -> p
       | "("; p = pattern; ")" -> p ] ]
   ;
   patvar:
-    [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >>
-      | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >>
+    [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >>
+      | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >>
     ] ]
   ;
   END;;
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
index d612dd55..7df97a07 100644
--- a/parsing/q_coqast.ml4
+++ b/parsing/q_coqast.ml4
@@ -1,19 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*)
-
-(* $Id: q_coqast.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Libnames
 open Q_util
+open Compat
 
 let is_meta s = String.length s > 0 && s.[0] == '$'
 
@@ -21,21 +18,8 @@ let purge_str s =
   if String.length s == 0 || s.[0] <> '$' then s
   else String.sub s 1 (String.length s - 1)
 
-IFDEF OCAML308 THEN DEFINE NOP END
-IFDEF OCAML309 THEN DEFINE NOP END
-IFDEF CAMLP5 THEN DEFINE NOP END
-
 let anti loc x =
-  let e =
-    let loc =
-      IFDEF NOP THEN
-        loc
-      ELSE
-	(1, snd loc - fst loc)
-      END
-    in <:expr< $lid:purge_str x$ >>
-  in
-  <:expr< $anti:e$ >>
+  expl_anti loc <:expr< $lid:purge_str x$ >>
 
 (* We don't give location for tactic quotation! *)
 let loc = dummy_loc
@@ -88,12 +72,12 @@ let mlexpr_of_or_metaid f = function
   | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >>
 
 let mlexpr_of_quantified_hypothesis = function
-  | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >>
-  | Rawterm.NamedHyp id ->  <:expr< Rawterm.NamedHyp $mlexpr_of_ident id$ >>
+  | Glob_term.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >>
+  | Glob_term.NamedHyp id ->  <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >>
 
 let mlexpr_of_or_var f = function
-  | Rawterm.ArgArg x -> <:expr< Rawterm.ArgArg $f x$ >>
-  | Rawterm.ArgVar id -> <:expr< Rawterm.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
+  | Glob_term.ArgArg x -> <:expr< Glob_term.ArgArg $f x$ >>
+  | Glob_term.ArgVar id -> <:expr< Glob_term.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
 
 let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident)
 
@@ -118,17 +102,17 @@ let mlexpr_of_clause cl =
            Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >>
 
 let mlexpr_of_red_flags {
-  Rawterm.rBeta = bb;
-  Rawterm.rIota = bi;
-  Rawterm.rZeta = bz;
-  Rawterm.rDelta = bd;
-  Rawterm.rConst = l
+  Glob_term.rBeta = bb;
+  Glob_term.rIota = bi;
+  Glob_term.rZeta = bz;
+  Glob_term.rDelta = bd;
+  Glob_term.rConst = l
 } = <:expr< {
-  Rawterm.rBeta = $mlexpr_of_bool bb$;
-  Rawterm.rIota = $mlexpr_of_bool bi$;
-  Rawterm.rZeta = $mlexpr_of_bool bz$;
-  Rawterm.rDelta = $mlexpr_of_bool bd$;
-  Rawterm.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$
+  Glob_term.rBeta = $mlexpr_of_bool bb$;
+  Glob_term.rIota = $mlexpr_of_bool bi$;
+  Glob_term.rZeta = $mlexpr_of_bool bz$;
+  Glob_term.rDelta = $mlexpr_of_bool bd$;
+  Glob_term.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$
 } >>
 
 let mlexpr_of_explicitation = function
@@ -136,8 +120,8 @@ let mlexpr_of_explicitation = function
   | 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 >>
+  | Glob_term.Implicit -> <:expr< Glob_term.Implicit >>
+  | Glob_term.Explicit -> <:expr< Glob_term.Explicit >>
 
 let mlexpr_of_binder_kind = function
   | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >>
@@ -174,25 +158,25 @@ let mlexpr_of_occ_constr =
   mlexpr_of_occurrences mlexpr_of_constr
 
 let mlexpr_of_red_expr = function
-  | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >>
-  | Rawterm.Hnf -> <:expr< Rawterm.Hnf >>
-  | Rawterm.Simpl o -> <:expr< Rawterm.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >>
-  | Rawterm.Cbv f ->
-      <:expr< Rawterm.Cbv $mlexpr_of_red_flags f$ >>
-  | Rawterm.Lazy f ->
-      <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >>
-  | Rawterm.Unfold l ->
+  | Glob_term.Red b -> <:expr< Glob_term.Red $mlexpr_of_bool b$ >>
+  | Glob_term.Hnf -> <:expr< Glob_term.Hnf >>
+  | Glob_term.Simpl o -> <:expr< Glob_term.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >>
+  | Glob_term.Cbv f ->
+      <:expr< Glob_term.Cbv $mlexpr_of_red_flags f$ >>
+  | Glob_term.Lazy f ->
+      <:expr< Glob_term.Lazy $mlexpr_of_red_flags f$ >>
+  | Glob_term.Unfold l ->
       let f1 = mlexpr_of_by_notation mlexpr_of_reference in
       let f = mlexpr_of_list (mlexpr_of_occurrences f1) in
-      <:expr< Rawterm.Unfold $f l$ >>
-  | Rawterm.Fold l ->
-      <:expr< Rawterm.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
-  | Rawterm.Pattern l ->
+      <:expr< Glob_term.Unfold $f l$ >>
+  | Glob_term.Fold l ->
+      <:expr< Glob_term.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Glob_term.Pattern l ->
       let f = mlexpr_of_list mlexpr_of_occ_constr in
-      <:expr< Rawterm.Pattern $f l$ >>
-  | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >>
-  | Rawterm.ExtraRedExpr s ->
-      <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ >>
+      <:expr< Glob_term.Pattern $f l$ >>
+  | Glob_term.CbvVm -> <:expr< Glob_term.CbvVm >>
+  | Glob_term.ExtraRedExpr s ->
+      <:expr< Glob_term.ExtraRedExpr $mlexpr_of_string s$ >>
 
 let rec mlexpr_of_argtype loc = function
   | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >>
@@ -222,25 +206,25 @@ let rec mlexpr_of_argtype loc = function
   | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >>
 
 let rec mlexpr_of_may_eval f = function
-  | Rawterm.ConstrEval (r,c) ->
-      <:expr< Rawterm.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
-  | Rawterm.ConstrContext ((loc,id),c) ->
+  | Glob_term.ConstrEval (r,c) ->
+      <:expr< Glob_term.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
+  | Glob_term.ConstrContext ((loc,id),c) ->
       let id = mlexpr_of_ident id in
-      <:expr< Rawterm.ConstrContext (loc,$id$) $f c$ >>
-  | Rawterm.ConstrTypeOf c ->
-      <:expr< Rawterm.ConstrTypeOf $mlexpr_of_constr c$ >>
-  | Rawterm.ConstrTerm c ->
-      <:expr< Rawterm.ConstrTerm $mlexpr_of_constr c$ >>
+      <:expr< Glob_term.ConstrContext (loc,$id$) $f c$ >>
+  | Glob_term.ConstrTypeOf c ->
+      <:expr< Glob_term.ConstrTypeOf $mlexpr_of_constr c$ >>
+  | Glob_term.ConstrTerm c ->
+      <:expr< Glob_term.ConstrTerm $mlexpr_of_constr c$ >>
 
 let mlexpr_of_binding_kind = function
-  | Rawterm.ExplicitBindings l ->
+  | Glob_term.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 ->
+      <:expr< Glob_term.ExplicitBindings $l$ >>
+  | Glob_term.ImplicitBindings l ->
       let l = mlexpr_of_list mlexpr_of_constr l in
-      <:expr< Rawterm.ImplicitBindings $l$ >>
-  | Rawterm.NoBindings ->
-       <:expr< Rawterm.NoBindings >>
+      <:expr< Glob_term.ImplicitBindings $l$ >>
+  | Glob_term.NoBindings ->
+       <:expr< Glob_term.NoBindings >>
 
 let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr
 
@@ -397,7 +381,7 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacAnyConstructor (ev,t) ->
       <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>>
   | Tacexpr.TacConstructor (ev,n,l) ->
-      let n = mlexpr_of_or_metaid mlexpr_of_int n in
+      let n = mlexpr_of_or_var mlexpr_of_int n in
       <:expr< Tacexpr.TacConstructor $mlexpr_of_bool ev$ $n$ $mlexpr_of_binding_kind l$>>
 
   (* Conversion *)
@@ -425,12 +409,6 @@ let rec mlexpr_of_atomic_tactic = function
       let lems = mlexpr_of_list mlexpr_of_constr lems in
       <:expr< Tacexpr.TacTrivial $lems$ $l$ >>
 
-(*
-  | Tacexpr.TacExtend (s,l) ->
-      let l = mlexpr_of_list mlexpr_of_tactic_arg l in
-      let $dloc$ = MLast.loc_of_expr l in
-      <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $l$ >>
-*)
   | _ -> failwith "Quotation of atomic tactic expressions: TODO"
 
 and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
@@ -450,6 +428,8 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
   | Tacexpr.TacDo (n,t) ->
       <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacTimeout (n,t) ->
+      <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
   | Tacexpr.TacRepeat t ->
       <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >>
   | Tacexpr.TacProgress t ->
@@ -485,9 +465,9 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacFun
         ($mlexpr_of_list mlexpr_of_ident_option idol$,
          $mlexpr_of_tactic body$) >>
-  | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,true,id)) -> anti loc id
-  | Tacexpr.TacArg t ->
-      <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >>
+  | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id
+  | Tacexpr.TacArg (_,t) ->
+      <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >>
   | Tacexpr.TacComplete t ->
       <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >>
   | _ -> failwith "Quotation of tactic expressions: TODO"
@@ -495,7 +475,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) ->
-      <:expr< Tacexpr.ConstrMayEval (Rawterm.ConstrTerm $anti loc id$) >>
+      <:expr< Tacexpr.ConstrMayEval (Glob_term.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$>>
   | Tacexpr.Tacexp t ->
@@ -506,18 +486,47 @@ and mlexpr_of_tactic_arg = function
       <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >>
   | _ -> failwith "mlexpr_of_tactic_arg: TODO"
 
+
+IFDEF CAMLP5 THEN
+
+let not_impl x =
+  let desc =
+    if Obj.is_block (Obj.repr x) then
+      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
+    else "int_val = " ^ string_of_int (Obj.magic x)
+  in
+  failwith ("<Q_coqast.patt_of_expt, not impl: " ^ desc)
+
+(* The following function is written without quotation
+   in order to be parsable even by camlp4. The version with
+   quotation can be found in revision <= 12972 of [q_util.ml4] *)
+
+open MLast
+
+let rec patt_of_expr e =
+  let loc = loc_of_expr e in
+  match e with
+    | ExAcc (_, e1, e2) -> PaAcc (loc, patt_of_expr e1, patt_of_expr e2)
+    | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2)
+    | ExLid (_, x) when x = vala "loc" -> PaAny loc
+    | ExLid (_, s) -> PaLid (loc, s)
+    | ExUid (_, s) -> PaUid (loc, s)
+    | ExStr (_, s) -> PaStr (loc, s)
+    | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e)
+    | _ -> not_impl e
+
 let fconstr e =
   let ee s =
-    mlexpr_of_constr (Pcoq.Gram.Entry.parse e
-                     (Pcoq.Gram.parsable (Stream.of_string s)))
+    mlexpr_of_constr (Pcoq.Gram.entry_parse e
+			(Pcoq.Gram.parsable (Stream.of_string s)))
   in
   let ep s = patt_of_expr (ee s) in
   Quotation.ExAst (ee, ep)
 
 let ftac e =
   let ee s =
-    mlexpr_of_tactic (Pcoq.Gram.Entry.parse e
-                     (Pcoq.Gram.parsable (Stream.of_string s)))
+    mlexpr_of_tactic (Pcoq.Gram.entry_parse e
+			(Pcoq.Gram.parsable (Stream.of_string s)))
   in
   let ep s = patt_of_expr (ee s) in
   Quotation.ExAst (ee, ep)
@@ -526,3 +535,23 @@ let _ =
   Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi);
   Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi);
   Quotation.default := "constr"
+
+ELSE
+
+open Pcaml
+
+let expand_constr_quot_expr loc _loc_name_opt contents =
+  mlexpr_of_constr
+    (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents)
+
+let expand_tactic_quot_expr loc _loc_name_opt contents =
+  mlexpr_of_tactic
+    (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents)
+
+let _ =
+  (* FIXME: for the moment, we add quotations in expressions only, not pattern *)
+  Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr;
+  Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr;
+  Quotation.default := "constr"
+
+END
diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4
index a41824d0..91ab29f1 100644
--- a/parsing/q_util.ml4
+++ b/parsing/q_util.ml4
@@ -1,41 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "q_MLast.cmo" i*)
-
-(* $Id: q_util.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* 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
-      "int_val = " ^ string_of_int (Obj.magic x)
-  in
-  failwith ("<Q_util." ^ name ^ ", not impl: " ^ desc)
-
-let rec patt_of_expr e =
-  let loc = MLast.loc_of_expr e in
-  match e with
-    | <:expr< $e1$.$e2$ >> -> <:patt< $patt_of_expr e1$.$patt_of_expr e2$ >>
-    | <:expr< $e1$ $e2$ >> -> <:patt< $patt_of_expr e1$ $patt_of_expr e2$ >>
-    | <:expr< loc >> -> <:patt< _ >>
-    | <:expr< $lid:s$ >> -> <:patt< $lid:s$ >>
-    | <:expr< $uid:s$ >> -> <:patt< $uid:s$ >>
-    | <:expr< $str:s$ >> -> <:patt< $str:s$ >>
-    | <:expr< $anti:e$ >> -> <:patt< $anti:patt_of_expr e$ >>
-    | _ -> not_impl "patt_of_expr" e
+open Compat
+open Util
 
 let mlexpr_of_list f l =
   List.fold_right
@@ -77,19 +52,18 @@ let mlexpr_of_option f = function
   | Some e -> <:expr< Some $f e$ >>
 
 open Vernacexpr
-open Pcoq
 open Genarg
 
 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$ >>
+  | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >>
+  | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
+  | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >>
+  | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
+  | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >>
+  | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >>
+  | Pcoq.Aself -> <:expr< Pcoq.Aself >>
+  | Pcoq.Anext -> <:expr< Pcoq.Anext >>
+  | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >>
+  | Pcoq.Agram s -> Util.anomaly "Agram not supported"
+  | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.obj $lid:s$) >>
+  | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >>
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
index 878adba6..5d56c456 100644
--- a/parsing/q_util.mli
+++ b/parsing/q_util.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: q_util.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-val patt_of_expr : MLast.expr -> MLast.patt
+open Compat
 
 val mlexpr_of_list :  ('a -> MLast.expr) -> 'a list -> MLast.expr
 
@@ -32,4 +30,4 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
-val mlexpr_of_prod_entry_key : Pcoq.Gram.te Extend.prod_entry_key -> MLast.expr
+val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index 0d7a9cfe..2fe1fdda 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-
-(* $Id: tacextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
+(*i camlp4deps: "tools/compat5b.cmo" i*)
 
 open Util
 open Genarg
@@ -18,6 +16,7 @@ open Argextend
 open Pcoq
 open Extrawit
 open Egrammar
+open Compat
 
 let rec make_patt = function
   | [] -> <:patt< [] >>
@@ -43,20 +42,9 @@ let rec make_let e = function
       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 =
-        (* Special case for tactics which must be stored in algebraic
-           form to avoid marshalling closures and to be reprinted *)
-        if is_tactic_genarg t then
-          <:expr< ($v$, Tacinterp.eval_tactic $v$) >>
-        else v in
       <:expr< let $lid:p$ = $v$ in $e$ >>
   | _::l -> make_let e l
 
-let add_clause s (pt,e) l =
-  let p = make_patt pt in
-  let w = Some (make_when (MLast.loc_of_expr e) pt) in
-  (p, <:vala< w >>, make_let e pt)::l
-
 let rec extract_signature = function
   | [] -> []
   | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
@@ -69,12 +57,14 @@ let check_unicity s l =
       ("Two distinct rules of tactic entry "^s^" have the same\n"^
       "non-terminals in the same order: put them in distinct tactic entries")
 
-let make_clauses s l =
+let make_clause (pt,e) =
+  (make_patt pt,
+   vala (Some (make_when (MLast.loc_of_expr e) pt)),
+   make_let e pt)
+
+let make_fun_clauses loc s l =
   check_unicity s l;
-  let default =
-    (<:patt< _ >>,<:vala<None>>,
-     <:expr< failwith "Tactic extension: cannot occur" >>) in
-  List.fold_right (add_clause s) l [default]
+  Compat.make_fun loc (List.map make_clause l)
 
 let rec make_args = function
   | [] -> <:expr< [] >>
@@ -89,9 +79,7 @@ let rec make_eval_tactic e = function
       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
-           form to avoid marshalling closures and to be reprinted *)
-      <:expr< let $lid:p$ = ($lid:p$,Tacinterp.eval_tactic $lid:p$) in $e$ >>
+      <:expr< let $lid:p$ = $lid:p$ in $e$ >>
   | _::l -> make_eval_tactic e l
 
 let rec make_fun e = function
@@ -165,30 +153,28 @@ let declare_tactic loc s cl =
   let atomic_tactics =
     mlexpr_of_list mlexpr_of_string
       (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in
-  <:str_item<
-    declare
-      open Pcoq;
-      open Extrawit;
-      declare $list:hidden$ end;
+  declare_str_items loc
+   (hidden @
+    [ <:str_item< do {
       try
-        let _=Tacinterp.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in
+        let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in
         List.iter
           (fun s -> Tacinterp.add_primitive_tactic s
               (Tacexpr.TacAtom($default_loc$,
                  Tacexpr.TacExtend($default_loc$,s,[]))))
           $atomic_tactics$
-      with e -> Pp.pp (Cerrors.explain_exn e);
+      with e -> Pp.pp (Errors.print e);
       Egrammar.extend_tactic_grammar $se$ $gl$;
-      List.iter Pptactic.declare_extra_tactic_pprule $pp$;
-    end
-  >>
+      List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >>
+    ])
 
 open Pcaml
+open PcamlSig
 
 EXTEND
   GLOBAL: str_item;
   str_item:
-    [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ];
+    [ [ "TACTIC"; "EXTEND"; s = tac_name;
         OPT "|"; l = LIST1 tacrule SEP "|";
         "END" ->
          declare_tactic loc s l ] ]
@@ -214,5 +200,10 @@ EXTEND
         GramTerminal s
     ] ]
   ;
+  tac_name:
+    [ [ s = LIDENT -> s
+      | s = UIDENT -> s
+    ] ]
+  ;
   END
 
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
index 45816856..83dae3dc 100644
--- a/parsing/tactic_printer.ml
+++ b/parsing/tactic_printer.ml
@@ -1,41 +1,33 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactic_printer.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Sign
 open Evd
 open Tacexpr
 open Proof_type
-open Proof_trees
-open Decl_expr
 open Logic
 open Printer
 
 let pr_tactic = function
-  | TacArg (Tacexp t) ->
+  | TacArg (_,Tacexp t) ->
       (*top tactic from tacinterp*)
       Pptactic.pr_glob_tactic (Global.env()) t
   | t ->
       Pptactic.pr_tactic (Global.env()) t
 
-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
 	  | Tactic (texp,_) -> hov 0 (pr_tactic texp)
-	  | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr)
       end
   | Daimon -> str "<Daimon>"
   | Decl_proof _ -> str "proof"
@@ -62,33 +54,23 @@ let pr_rule_dot_fnl = function
 
 exception Different
 
-(* We remove from the var context of env what is already in osign *)
-let thin_sign osign sign =
-  Sign.fold_named_context
-    (fun (id,c,ty as d) sign ->
-       try
-	 if Sign.lookup_named id osign = (id,c,ty) then sign
-	 else raise Different
-       with Not_found | Different -> Environ.push_named_context_val d sign)
-    sign ~init:Environ.empty_named_context_val
-
-let 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
+let rec print_proof sigma osign pf =
+  (* spiwack: [osign] is currently ignored, not sure if this function is even used. *)
+  let hyps = Environ.named_context_of_val (Goal.V82.hyps sigma pf.goal) in
   match pf.ref with
     | None ->
-	hov 0 (pr_goal {pf.goal with evar_hyps=hyps'})
+	hov 0 (pr_goal {sigma = sigma; it=pf.goal })
     | Some(r,spfl) ->
     	hov 0
-	  (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++
+	  (hov 0 (pr_goal {sigma = sigma; it=pf.goal }) ++
 	   spc () ++ str" BY " ++
 	   hov 0 (pr_rule r) ++ fnl () ++
 	   str"  " ++
-	   hov 0 (prlist_with_sep pr_fnl (print_proof _sigma hyps) spfl))
+	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl))
 
-let pr_change gl =
+let pr_change sigma gl =
   str"change " ++
-  pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"."
+  pr_lconstr_env (Goal.V82.env sigma gl) (Goal.V82.concl sigma gl) ++ str"."
 
 let print_decl_script tac_printer ?(nochange=true) sigma pf =
   let rec print_prf pf =
@@ -97,36 +79,10 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf =
 	(if nochange then
 	   (str"<Your Proof Text here>")
 	 else
-	   pr_change pf.goal)
+	   pr_change sigma pf.goal)
 	++ fnl ()
     | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)"
     | Some (Prim Change_evars,[subpf]) -> print_prf subpf
-    | Some (Nested(Proof_instr (opened,instr),_) as rule,subprfs) ->
-	begin
-	  match instr.instr,subprfs with
-	    Pescape,[{ref=Some(_,subsubprfs)}] ->
-	      hov 7
-		(pr_rule_dot_fnl rule ++
-		  prlist_with_sep pr_fnl tac_printer subsubprfs) ++ fnl () ++
-	      if opened then mt () else str "return."
-	  | Pclaim _,[body;cont] ->
-	      hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++
-	      (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) ++
-	      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
-	  | _,[next] ->
-	      pr_rule_dot_fnl rule ++ print_prf next
-	  | _,[] ->
-	      pr_rule_dot rule
-	  | _,_ -> anomaly "unknown branching instruction"
-	end
     | _ -> anomaly "Not Applicable" in
   print_prf pf
 
@@ -137,12 +93,12 @@ let print_script ?(nochange=true) sigma pf =
         (if nochange then
 	   (str"<Your Tactic Text here>")
 	 else
-	   pr_change pf.goal)
+	   pr_change sigma 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 sigma pf.goal ++ fnl ())
 	end ++
 	  begin
 	    hov 0 (str "proof." ++ fnl () ++
@@ -153,10 +109,10 @@ let print_script ?(nochange=true) sigma pf =
 	    if opened then mt () else (str "end proof." ++ fnl ())
 	  end
     | Some(Daimon,spfl) ->
-	((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+	((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++
 	   prlist_with_sep pr_fnl print_prf spfl )
     | Some(rule,spfl) ->
-	((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+	((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++
 	   pr_rule_dot_fnl rule ++
 	   prlist_with_sep pr_fnl print_prf spfl ) in
   print_prf pf
@@ -168,13 +124,12 @@ let print_treescript ?(nochange=true) sigma pf =
     match pf.ref with
     | None ->
         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
+	  str"<Your Proof Text here>"
+	else pr_change sigma pf.goal
     | Some(Decl_proof opened,script) ->
 	assert (List.length script = 1);
 	begin
-	  if nochange then mt () else pr_change pf.goal ++ fnl ()
+	  if nochange then mt () else pr_change sigma pf.goal ++ fnl ()
 	end ++
 	hov 0
 	  begin str "proof." ++ fnl () ++
@@ -184,16 +139,16 @@ let print_treescript ?(nochange=true) sigma pf =
 	  if opened then mt () else (str "end proof." ++ fnl ())
 	end
     | Some(Daimon,spfl) ->
-	(if nochange then mt () else pr_change pf.goal ++ fnl ()) ++
+	(if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++
 	prlist_with_sep pr_fnl (print_script ~nochange sigma) spfl
     | Some(r,spfl) ->
         let indent = if List.length spfl >= 2 then 1 else 0 in
-        (if nochange then mt () else pr_change pf.goal ++ fnl ()) ++
+        (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++
         hv indent (pr_rule_dot_fnl r ++ prlist_with_sep fnl print_prf spfl)
   in hov 0 (print_prf pf)
 
 let rec print_info_script sigma osign pf =
-  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
+  let sign = Goal.V82.hyps sigma pf.goal in
   match pf.ref with
     | None -> (mt ())
     | Some(r,spfl) ->
@@ -214,12 +169,4 @@ let rec 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
-    format_print_info_script sigma sign (subproof_of_proof pf)
-  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 05ba20e9..5ea57910 100644
--- a/parsing/tactic_printer.mli
+++ b/parsing/tactic_printer.mli
@@ -1,27 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_printer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Sign
 open Evd
 open Tacexpr
 open Proof_type
-(*i*)
 
-(* These are the entry points for tactics, proof trees, ... *)
+(** These are the entry points for tactics, proof trees, ... *)
 
 val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds
 val pr_rule     : rule -> std_ppcmds
 val pr_tactic   : tactic_expr -> std_ppcmds
-val pr_proof_instr : Decl_expr.proof_instr -> Pp.std_ppcmds
 val print_script :
   ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds
 val print_treescript :
diff --git a/parsing/tok.ml b/parsing/tok.ml
new file mode 100644
index 00000000..bd7645c2
--- /dev/null
+++ b/parsing/tok.ml
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** The type of token for the Coq lexer and parser *)
+
+type t =
+  | KEYWORD of string
+  | METAIDENT of string
+  | PATTERNIDENT of string
+  | IDENT of string
+  | FIELD of string
+  | INT of string
+  | STRING of string
+  | LEFTQMARK
+  | EOI
+
+let extract_string = function
+  | KEYWORD s -> s
+  | IDENT s -> s
+  | STRING s -> s
+  | METAIDENT s -> s
+  | PATTERNIDENT s -> s
+  | FIELD s -> s
+  | INT s -> s
+  | LEFTQMARK -> "?"
+  | EOI -> ""
+
+let to_string = function
+  | KEYWORD s -> Format.sprintf "%S" s
+  | IDENT s -> Format.sprintf "IDENT %S" s
+  | METAIDENT s -> Format.sprintf "METAIDENT %S" s
+  | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s
+  | FIELD s -> Format.sprintf "FIELD %S" s
+  | INT s -> Format.sprintf "INT %s" s
+  | STRING s -> Format.sprintf "STRING %S" s
+  | LEFTQMARK -> "LEFTQMARK"
+  | EOI -> "EOI"
+
+let match_keyword kwd = function
+  | KEYWORD kwd' when kwd = kwd' -> true
+  | _ -> false
+
+let print ppf tok = Format.fprintf ppf "%s" (to_string tok)
+
+(** For camlp5, conversion from/to [Plexing.pattern],
+    and a match function analoguous to [Plexing.default_match] *)
+
+let of_pattern = function
+  | "", s -> KEYWORD s
+  | "IDENT", s -> IDENT s
+  | "METAIDENT", s -> METAIDENT s
+  | "PATTERNIDENT", s -> PATTERNIDENT s
+  | "FIELD", s -> FIELD s
+  | "INT", s -> INT s
+  | "STRING", s -> STRING s
+  | "LEFTQMARK", _ -> LEFTQMARK
+  | "EOI", _ -> EOI
+  | _ -> failwith "Tok.of_pattern: not a constructor"
+
+let to_pattern = function
+  | KEYWORD s -> "", s
+  | IDENT s -> "IDENT", s
+  | METAIDENT s -> "METAIDENT", s
+  | PATTERNIDENT s -> "PATTERNIDENT", s
+  | FIELD s -> "FIELD", s
+  | INT s -> "INT", s
+  | STRING s -> "STRING", s
+  | LEFTQMARK -> "LEFTQMARK", ""
+  | EOI -> "EOI", ""
+
+let match_pattern =
+  let err () = raise Stream.Failure in
+  function
+    | "", "" -> (function KEYWORD s -> s | _ -> err ())
+    | "IDENT", "" -> (function IDENT s -> s | _ -> err ())
+    | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ())
+    | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ())
+    | "FIELD", "" -> (function FIELD s -> s | _ -> err ())
+    | "INT", "" -> (function INT s -> s | _ -> err ())
+    | "STRING", "" -> (function STRING s -> s | _ -> err ())
+    | "LEFTQMARK", "" -> (function LEFTQMARK -> ""  | _ -> err ())
+    | "EOI", "" -> (function EOI -> "" | _ -> err ())
+    | pat ->
+	let tok = of_pattern pat in
+	function tok' -> if tok = tok' then snd pat else err ()
diff --git a/parsing/tok.mli b/parsing/tok.mli
new file mode 100644
index 00000000..9a1edec5
--- /dev/null
+++ b/parsing/tok.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** The type of token for the Coq lexer and parser *)
+
+type t =
+  | KEYWORD of string
+  | METAIDENT of string
+  | PATTERNIDENT of string
+  | IDENT of string
+  | FIELD of string
+  | INT of string
+  | STRING of string
+  | LEFTQMARK
+  | EOI
+
+val extract_string : t -> string
+val to_string : t -> string
+val print : Format.formatter -> t -> unit
+val match_keyword : string -> t -> bool
+(** for camlp5 *)
+val of_pattern : string*string -> t
+val to_pattern : t -> string*string
+val match_pattern : string*string -> t -> string
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
index 3f60aafa..88a75079 100644
--- a/parsing/vernacextend.ml4
+++ b/parsing/vernacextend.ml4
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-
-(* $Id: vernacextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
+(*i camlp4deps: "tools/compat5b.cmo" i*)
 
 open Util
 open Genarg
@@ -18,6 +16,7 @@ open Argextend
 open Tacextend
 open Pcoq
 open Egrammar
+open Compat
 
 let rec make_let e = function
   | [] -> e
@@ -28,11 +27,6 @@ let rec make_let e = function
       <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
   | _::l -> make_let e l
 
-let add_clause s (_,pt,e) l =
-  let p = make_patt pt in
-  let w = Some (make_when (MLast.loc_of_expr e) pt) in
-  (p, <:vala<w>>, make_let e pt)::l
-
 let check_unicity s l =
   let l' = List.map (fun (_,l,_) -> extract_signature l) l in
   if not (Util.list_distinct l') then
@@ -40,31 +34,32 @@ let check_unicity s l =
       ("Two distinct rules of entry "^s^" have the same\n"^
       "non-terminals in the same order: put them in distinct vernac entries")
 
-let make_clauses s l =
+let make_clause (_,pt,e) =
+  (make_patt pt,
+   vala (Some (make_when (MLast.loc_of_expr e) pt)),
+   make_let e pt)
+
+let make_fun_clauses loc s l =
   check_unicity s l;
-  let default =
-    (<:patt< _ >>,<:vala<None>>,
-     <:expr< failwith "Vernac extension: cannot occur" >>) in
-  List.fold_right (add_clause s) l [default]
+  Compat.make_fun loc (List.map make_clause l)
 
 let mlexpr_of_clause =
   mlexpr_of_list
-    (fun (a,b,c) -> mlexpr_of_list make_prod_item (GramTerminal a::b))
+    (fun (a,b,c) -> mlexpr_of_list make_prod_item 
+       (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b))
 
-let declare_command loc s cl =
+let declare_command loc s nt cl =
   let gl = mlexpr_of_clause cl in
-  let icl = make_clauses s cl in
-  <: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$;
-    end
-  >>
+  let funcl = make_fun_clauses loc s cl in
+  declare_str_items loc
+    [ <:str_item< do {
+	try Vernacinterp.vinterp_add $mlexpr_of_string s$ $funcl$
+	with e -> Pp.pp (Errors.print e);
+	Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $nt$ $gl$
+      } >> ]
 
 open Pcaml
+open PcamlSig
 
 EXTEND
   GLOBAL: str_item;
@@ -72,13 +67,22 @@ EXTEND
     [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT;
         OPT "|"; l = LIST1 rule SEP "|";
         "END" ->
-         declare_command loc s l ] ]
+         declare_command loc s <:expr<None>> l 
+      | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT;
+        OPT "|"; l = LIST1 rule SEP "|";
+        "END" ->
+          declare_command loc s <:expr<Some $lid:nt$>> l ] ]
   ;
+  (* spiwack: comment-by-guessing: it seems that the isolated string (which
+      otherwise could have been another argument) is not passed to the
+      VernacExtend interpreter function to discriminate between the clauses. *)
   rule:
     [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]"
         ->
       if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty.");
-      (s,l,<:expr< fun () -> $e$ >>)
+      (Some s,l,<:expr< fun () -> $e$ >>)
+      | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" ->
+	  (None,l,<:expr< fun () -> $e$ >>)
     ] ]
   ;
   args:
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index 3c40cfb9..e3d27f71 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
 
@@ -30,6 +28,7 @@ let debug f x =
 let _=
   let gdopt=
     { optsync=true;
+      optdepr=false;
       optname="Congruence Verbose";
       optkey=["Congruence";"Verbose"];
       optread=(fun ()-> !cc_verbose);
@@ -105,6 +104,26 @@ type term=
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
+let rec term_equal t1 t2 =
+  match t1, t2 with
+    | Symb c1, Symb c2 -> eq_constr c1 c2
+    | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2
+    | Eps i1, Eps i2 -> id_ord i1 i2 = 0
+    | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2
+    | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1},
+      Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} ->
+      i1 = i2 && j1 = j2 && eq_constructor c1 c2
+    | _ -> t1 = t2
+
+open Hashtbl_alt.Combine
+
+let rec hash_term = function
+  | Symb c -> combine 1 (hash_constr c)
+  | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2)
+  | Eps i -> combine 3 (Hashtbl.hash i)
+  | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2)
+  | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j
+
 type ccpattern =
     PApp of term * ccpattern list (* arguments are reversed *)
   | PVar of int
@@ -172,13 +191,32 @@ type node =
      vertex:vertex;
      term:term}
 
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+module Typehash = Constrhash
+
+module Termhash = Hashtbl.Make
+  (struct type t = term
+	  let equal = term_equal
+	  let hash = hash_term
+   end)
+
+module Identhash = Hashtbl.Make
+  (struct type t = identifier
+	  let equal = Pervasives.(=)
+	  let hash = Hashtbl.hash
+   end)
+
 type forest=
     {mutable max_size:int;
      mutable size:int;
      mutable map: node array;
-     axioms: (constr,term*term) Hashtbl.t;
+     axioms: (term*term) Constrhash.t;
      mutable epsilons: pa_constructor list;
-     syms:(term,int) Hashtbl.t}
+     syms: int Termhash.t}
 
 type state =
     {uf: forest;
@@ -189,10 +227,10 @@ type state =
      mutable diseq: disequality list;
      mutable quant: quant_eq list;
      mutable pa_classes: Intset.t;
-     q_history: (identifier,int array) Hashtbl.t;
+     q_history: (int array) Identhash.t;
      mutable rew_depth:int;
      mutable changed:bool;
-     by_type: (types,Intset.t) Hashtbl.t;
+     by_type: Intset.t Typehash.t;
      mutable gls:Proof_type.goal Tacmach.sigma}
 
 let dummy_node =
@@ -207,8 +245,8 @@ let empty depth gls:state =
       size=0;
       map=Array.create init_size dummy_node;
       epsilons=[];
-      axioms=Hashtbl.create init_size;
-      syms=Hashtbl.create init_size};
+      axioms=Constrhash.create init_size;
+      syms=Termhash.create init_size};
   terms=Intset.empty;
   combine=Queue.create ();
   marks=Queue.create ();
@@ -216,9 +254,9 @@ let empty depth gls:state =
   diseq=[];
   quant=[];
   pa_classes=Intset.empty;
-  q_history=Hashtbl.create init_size;
+  q_history=Identhash.create init_size;
   rew_depth=depth;
-  by_type=Hashtbl.create init_size;
+  by_type=Constrhash.create init_size;
   changed=false;
   gls=gls}
 
@@ -384,7 +422,7 @@ let pr_term t = str "[" ++
 
 let rec add_term state t=
   let uf=state.uf in
-    try Hashtbl.find uf.syms t with
+    try Termhash.find uf.syms t with
 	Not_found ->
 	  let b=next uf in
 	  let typ = pf_type_of state.gls (constr_of_term t) in
@@ -430,10 +468,10 @@ let rec add_term state t=
 		     term=t}
 	  in
 	    uf.map.(b)<-new_node;
-	    Hashtbl.add uf.syms t b;
-	    Hashtbl.replace state.by_type typ
+	    Termhash.add uf.syms t b;
+	    Typehash.replace state.by_type typ
 	      (Intset.add b
-		 (try Hashtbl.find state.by_type typ with
+		 (try Typehash.find state.by_type typ with
 		      Not_found -> Intset.empty));
 	    b
 
@@ -441,7 +479,7 @@ let add_equality state c s t=
   let i = add_term state s in
   let j = add_term state t in
     Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine;
-    Hashtbl.add state.uf.axioms c (s,t)
+    Constrhash.add state.uf.axioms c (s,t)
 
 let add_disequality state from s t =
   let i = add_term state s in
@@ -461,7 +499,7 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
 let is_redundant state id args =
   try
     let norm_args = Array.map (find state.uf) args in
-    let prev_args = Hashtbl.find_all state.q_history id in
+    let prev_args = Identhash.find_all state.q_history id in
     List.exists
       (fun old_args ->
 	 Util.array_for_all2 (fun i j -> i = find state.uf j)
@@ -476,7 +514,7 @@ let add_inst state (inst,int_subst) =
     debug msgnl (str "discarding redundant (dis)equality")
   else
     begin
-      Hashtbl.add state.q_history inst.qe_hyp_id int_subst;
+      Identhash.add state.q_history inst.qe_hyp_id int_subst;
       let subst = build_subst (forest state) int_subst in
       let prfhead= mkVar inst.qe_hyp_id in
       let args = Array.map constr_of_term subst in
@@ -532,9 +570,9 @@ let union state i1 i2 eq=
   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
+    Constrhash.replace state.by_type r1.class_type
       (Intset.remove i1
-	 (try Hashtbl.find state.by_type r1.class_type with
+	 (try Constrhash.find state.by_type r1.class_type with
 	      Not_found -> Intset.empty));
     let f= Intset.union r1.fathers r2.fathers in
       r2.weight<-Intset.cardinal f;
@@ -691,11 +729,11 @@ 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.evar_hyps}};
+  let {it=gl ; sigma=sigma} = state.gls in
+  let new_hyps =
+    Environ.push_named_context_val (id,None,typ) (Goal.V82.hyps sigma gl) in
+  let gls = Goal.V82.new_goal_with sigma gl new_hyps in
+    state.gls<- gls;
     id
 
 let complete_one_class state i=
@@ -763,14 +801,14 @@ let rec do_match state res pb_stack =
 		    else (* mismatch for non-linear variable in pattern *) ()
 	      | PApp (f,[]) ->
 		  begin
-		    try let j=Hashtbl.find uf.syms f in
+		    try let j=Termhash.find uf.syms f in
 		      if find uf j =cl then
 			Stack.push {mp with mp_stack=remains} pb_stack
 		    with Not_found -> ()
 		  end
 	      | PApp(f, ((last_arg::rem_args) as args)) ->
 		  try
-		    let j=Hashtbl.find uf.syms f in
+		    let j=Termhash.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
@@ -788,7 +826,7 @@ let rec do_match state res pb_stack =
 let paf_of_patt syms = function
     PVar _ -> invalid_arg "paf_of_patt: pattern is trivial"
   | PApp (f,args) ->
-      {fsym=Hashtbl.find syms f;
+      {fsym=Termhash.find syms f;
        fnargs=List.length args}
 
 let init_pb_stack state =
@@ -810,7 +848,7 @@ let init_pb_stack state =
 	| Trivial typ ->
 	    begin
 	      try
-		Hashtbl.find state.by_type typ
+		Typehash.find state.by_type typ
 	      with Not_found -> Intset.empty
 	    end in
 	Intset.iter (fun i ->
@@ -833,7 +871,7 @@ let init_pb_stack state =
 	| Trivial typ ->
 	    begin
 	      try
-		Hashtbl.find state.by_type typ
+		Typehash.find state.by_type typ
 	      with Not_found -> Intset.empty
 	    end in
 	Intset.iter (fun i ->
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index 8786c907..78dbee3f 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Term
 open Names
@@ -24,6 +22,8 @@ type term =
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
+val term_equal : term -> term -> bool
+
 type patt_kind =
     Normal
   | Trivial of types
@@ -66,13 +66,16 @@ type explanation =
   | Contradiction of disequality
   | Incomplete
 
+module Constrhash : Hashtbl.S with type key = constr
+module Termhash : Hashtbl.S with type key = term
+
 val constr_of_term : term -> constr
 
 val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
 
 val forest : state -> forest
 
-val axioms : forest -> (constr, term * term) Hashtbl.t
+val axioms : forest -> (term * term) Constrhash.t
 
 val epsilons : forest -> pa_constructor list
 
@@ -127,7 +130,7 @@ val do_match :  state ->
 
 val init_pb_stack : state -> matching_problem Stack.t
 
-val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
+val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun
 
 val find_instances : state -> (quant_eq * int array) list
 
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index 6981c5a0..bb1d50c9 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* This file uses the (non-compressed) union-find structure to generate *)
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
@@ -45,7 +43,7 @@ let rec ptrans p1 p3=
     | 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 term_equal p1.p_rhs p3.p_lhs then
 	{p_lhs=p1.p_lhs;
 	 p_rhs=p3.p_rhs;
 	 p_rule=Trans (p1,p3)}
@@ -70,13 +68,13 @@ let rec psym p =
   | Congr (p1,p2)-> pcongr (psym p1) (psym p2)
 
 let pax axioms s =
-  let l,r = Hashtbl.find axioms s in
+  let l,r = Constrhash.find axioms s in
     {p_lhs=l;
      p_rhs=r;
      p_rule=Ax s}
 
 let psymax axioms s =
-  let l,r = Hashtbl.find axioms s in
+  let l,r = Constrhash.find axioms s in
     {p_lhs=r;
      p_rhs=l;
      p_rule=SymAx s}
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
index a58637f9..67819596 100644
--- a/plugins/cc/ccproof.mli
+++ b/plugins/cc/ccproof.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Ccalgo
 open Names
 open Term
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 5b477b4d..ec31f891 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: cctac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* This file is the interface between the c-c algorithm and Coq *)
 
 open Evd
@@ -20,7 +18,6 @@ open Nameops
 open Inductiveops
 open Declarations
 open Term
-open Termops
 open Tacmach
 open Tactics
 open Tacticals
@@ -66,8 +63,8 @@ let rec decompose_term env sigma t=
 	let tf=decompose_term env sigma f in
 	let targs=Array.map (decompose_term env sigma) args in
 	  Array.fold_left (fun s t->Appli (s,t)) tf targs
-    | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
-	let b = pop _b in
+    | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
+	let b = Termops.pop _b in
 	let sort_b = sf_of env sigma b in
 	let sort_a = sf_of env sigma a in
 	Appli(Appli(Product (sort_a,sort_b) ,
@@ -113,8 +110,8 @@ let rec pattern_of_constr env sigma c =
 	  (array_map_to_list (pattern_of_constr env sigma) args) in
 	  PApp (pf,List.rev pargs),
 	List.fold_left Intset.union Intset.empty lrels
-    | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
-	let b =pop _b in
+    | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
+	let b = Termops.pop _b in
 	let pa,sa = pattern_of_constr env sigma a in
 	let pb,sb = pattern_of_constr env sigma b in
 	let sort_b = sf_of env sigma b in
@@ -214,9 +211,9 @@ let rec make_prb gls depth additionnal_terms =
 		 neg_hyps:=(cid,nh):: !neg_hyps
 	     | `Rule patts -> add_quant state id true patts
 	     | `Nrule patts -> add_quant state id false patts
-	 end) (Environ.named_context_of_val gls.it.evar_hyps);
+	 end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it));
     begin
-      match atom_of_constr env sigma gls.it.evar_concl with
+      match atom_of_constr env sigma (pf_concl gls) with
 	  `Eq (t,a,b) -> add_disequality state Goal a b
 	|	`Other g ->
 		  List.iter
@@ -260,19 +257,19 @@ let rec proof_tac p gls =
     | 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 = Termops.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 = Termops.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 typ = Termops.refresh_universes (pf_type_of gls t2) in
 	let prf =
 	  mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in
 	  tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls
@@ -281,9 +278,9 @@ let rec proof_tac p gls =
 	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
-	let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in
+	let typf = Termops.refresh_universes (pf_type_of gls tf1) in
+	let typx = Termops.refresh_universes (pf_type_of gls tx1) in
+	let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in
 	let id = pf_get_new_id (id_of_string "f") gls in
 	let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
 	let lemma1 =
@@ -311,8 +308,8 @@ let rec proof_tac p gls =
 	 let ti=constr_of_term prf.p_lhs in
 	 let tj=constr_of_term prf.p_rhs in
 	 let default=constr_of_term p.p_lhs in
-	 let intype=refresh_universes (pf_type_of gls ti) in
-	 let outtype=refresh_universes (pf_type_of gls default) in
+	 let intype = Termops.refresh_universes (pf_type_of gls ti) in
+	 let outtype = Termops.refresh_universes (pf_type_of gls default) in
 	 let special=mkRel (1+nargs-argind) in
 	 let proj=build_projection intype outtype cstr special default gls in
 	 let injt=
@@ -321,7 +318,7 @@ let rec proof_tac 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 intype = Termops.refresh_universes (pf_type_of gls tt1) in
   let neweq=
     mkApp(Lazy.force _eq,
 	  [|intype;tt1;tt2|]) in
@@ -332,7 +329,7 @@ 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 sort = Termops.refresh_universes (pf_type_of gls tt2) in
   let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in
   let e=pf_get_new_id (id_of_string "e") gls in
   let x=pf_get_new_id (id_of_string "X") gls in
@@ -352,14 +349,14 @@ let convert_to_hyp_tac c1 t1 c2 t2 p 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
+  let intype = Termops.refresh_universes (pf_type_of gls t1) in
   let concl=pf_concl gls in
-  let outsort=mkType (new_univ ()) in
+  let outsort = mkType (Termops.new_univ ()) in
   let xid=pf_get_new_id (id_of_string "X") gls in
   let tid=pf_get_new_id (id_of_string "t") gls in
   let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
   let trivial=pf_type_of gls identity in
-  let outtype=mkType (new_univ ()) in
+  let outtype = mkType (Termops.new_univ ()) in
   let pred=mkLambda(Name xid,outtype,mkRel 1) in
   let hid=pf_get_new_id (id_of_string "Heq") gls in
   let proj=build_projection intype outtype cstr trivial concl gls in
@@ -414,7 +411,7 @@ let cc_tactic depth additionnal_terms gls=
 			 str "\"congruence with (" ++
 			 prlist_with_sep
 			   (fun () -> str ")" ++ pr_spc () ++ str "(")
-			   (print_constr_env (pf_env gls))
+			   (Termops.print_constr_env (pf_env gls))
 			   terms_to_complete ++
 			 str ")\","
 		       end);
@@ -456,7 +453,7 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal)
 
 let f_equal gl =
   let cut_eq c1 c2 =
-    let ty = refresh_universes (pf_type_of gl c1) in
+    let ty = Termops.refresh_universes (pf_type_of gl c1) in
     tclTHENTRY
       (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|])))
       (simple_reflexivity ())
diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
index b3d5c16b..32f56163 100644
--- a/plugins/cc/cctac.mli
+++ b/plugins/cc/cctac.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cctac.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Proof_type
 
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index eb58c5eb..881b9bee 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_congruence.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Cctac
 open Tactics
 open Tacticals
diff --git a/proofs/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
index 5c069cdd..fa6acaeb 100644
--- a/proofs/decl_expr.mli
+++ b/plugins/decl_mode/decl_expr.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_expr.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Util
 open Tacexpr
@@ -85,8 +83,8 @@ type raw_proof_instr =
      raw_tactic_expr) gen_proof_instr
 
 type glob_proof_instr =
-    ((identifier*(Genarg.rawconstr_and_expr option)) located,
-     Genarg.rawconstr_and_expr,
+    ((identifier*(Genarg.glob_constr_and_expr option)) located,
+     Genarg.glob_constr_and_expr,
      Topconstr.cases_pattern_expr,
      Tacexpr.glob_tactic_expr) gen_proof_instr
 
@@ -95,7 +93,7 @@ type proof_pattern =
      pat_aliases: (Term.constr*Term.types) statement list;
      pat_constr: Term.constr;
      pat_typ: Term.types;
-     pat_pat: Rawterm.cases_pattern;
+     pat_pat: Glob_term.cases_pattern;
      pat_expr: Topconstr.cases_pattern_expr}
 
 type proof_instr =
diff --git a/tactics/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index c4cff4d7..b3e076c4 100644
--- a/tactics/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decl_interp.ml 14677 2011-11-17 22:19:38Z herbelin $ i*)
-
 open Util
 open Names
 open Topconstr
@@ -16,13 +14,14 @@ open Tacmach
 open Decl_expr
 open Decl_mode
 open Pretyping.Default
-open Rawterm
+open Glob_term
 open Term
 open Pp
+open Compat
 
 (* INTERN *)
 
-let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args)
+let glob_app (loc,hd,args) = if args =[] then hd else GApp(loc,hd,args)
 
 let intern_justification_items globs =
   Option.map (List.map (intern_constr globs))
@@ -87,14 +86,14 @@ let intern_fundecl args body globs=
 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
+(*      Loc.raise loc
 	(UserError ("simple_pattern",str "\"as\" is not allowed here"))*)
   | CPatOr (loc, _)->
-      Stdpp.raise_with_loc loc
+      Loc.raise loc
 	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
   | CPatDelimiters (_,_,p) ->
       add_vars_of_simple_pattern globs p
-  | CPatCstr (_,_,pl) ->
+  | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) ->
       List.fold_left add_vars_of_simple_pattern globs pl
   | CPatNotation(_,_,(pl,pll)) ->
       List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
@@ -182,19 +181,19 @@ 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 abstract_one_hyp inject h raw =
+let abstract_one_hyp inject h glob =
   match h with
       Hvar (loc,(id,None)) ->
-	RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)
+	GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)
     | Hvar (loc,(id,Some typ)) ->
-	RProd (dummy_loc,Name id, Explicit, fst typ, raw)
+	GProd (dummy_loc,Name id, Explicit, fst typ, glob)
     | Hprop st ->
-	RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw)
+	GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob)
 
-let rawconstr_of_hyps inject hyps head =
+let glob_constr_of_hyps inject hyps head =
   List.fold_right (abstract_one_hyp inject) hyps head
 
-let raw_prop = RSort (dummy_loc,RProp Null)
+let glob_prop = GSort (dummy_loc,GProp Null)
 
 let rec match_hyps blend names constr = function
     [] -> [],substl names constr
@@ -212,10 +211,10 @@ let rec match_hyps blend names constr = function
 	qhyp::rhyps,head
 
 let interp_hyps_gen inject blend sigma env hyps head =
-  let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in
+  let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in
     match_hyps blend [] constr hyps
 
-let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop)
+let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop)
 
 let dummy_prefix= id_of_string "__"
 
@@ -233,36 +232,36 @@ let rec deanonymize ids =
     | PatCstr(loc,cstr,lpat,nam) ->
 	PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam)
 
-let rec raw_of_pat =
+let rec glob_of_pat =
   function
       PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
     | PatVar (loc,Name id) ->
-	  RVar (loc,id)
+	  GVar (loc,id)
     | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
 	let mind= fst (Global.lookup_inductive ind) in
 	let rec add_params n q =
 	  if n<=0 then q else
-	    add_params (pred n) (RHole(dummy_loc,
+	    add_params (pred n) (GHole(dummy_loc,
 				       Evd.TomatchTypeParameter(ind,n))::q) in
-	    let args = List.map raw_of_pat lpat in
-	      raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr),
+	    let args = List.map glob_of_pat lpat in
+	      glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr),
 		   add_params mind.Declarations.mind_nparams args)
 
 let prod_one_hyp = function
     (loc,(id,None)) ->
-      (fun raw ->
-	 RProd (dummy_loc,Name id, Explicit,
-		RHole (loc,Evd.BinderType (Name id)), raw))
+      (fun glob ->
+	 GProd (dummy_loc,Name id, Explicit,
+		GHole (loc,Evd.BinderType (Name id)), glob))
   | (loc,(id,Some typ)) ->
-      (fun raw ->
-	 RProd (dummy_loc,Name id, Explicit, fst typ, raw))
+      (fun glob ->
+	 GProd (dummy_loc,Name id, Explicit, fst typ, glob))
 
-let prod_one_id (loc,id) raw =
-  RProd (dummy_loc,Name id, Explicit,
-	 RHole (loc,Evd.BinderType (Name id)), raw)
+let prod_one_id (loc,id) glob =
+  GProd (dummy_loc,Name id, Explicit,
+	 GHole (loc,Evd.BinderType (Name id)), glob)
 
-let let_in_one_alias (id,pat) raw =
-  RLetIn (dummy_loc,Name id, raw_of_pat pat, raw)
+let let_in_one_alias (id,pat) glob =
+  GLetIn (dummy_loc,Name id, glob_of_pat pat, glob)
 
 let rec bind_primary_aliases map pat =
   match pat with
@@ -332,34 +331,34 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
 	     (if expected = 0 then str "none" else int expected) ++ spc () ++
 	     str "expected.") in
   let app_ind =
-    let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
+    let rind = GRef (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
+	   GVar (loc,id)) params in
     let dum_args=
-      list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
+      list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
 	oib.Declarations.mind_nrealargs in
-      raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
+      glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
   let pat_vars,aliases,patt = interp_pattern env pat in
   let inject = function
-      Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null)
+      Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp 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 ++
 	       str " does not occur in pattern.");
-	Rawterm.RSort(dummy_loc,RProp Null)
+	Glob_term.GSort(dummy_loc,GProp Null)
     | This (c,_) -> c in
-  let term1 = rawconstr_of_hyps inject hyps raw_prop in
+  let term1 = glob_constr_of_hyps inject hyps glob_prop in
   let loc_ids,npatt =
     let rids=ref ([],pat_vars) 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,
+    GLetIn(dummy_loc,Anonymous,
+	   GCast(dummy_loc,glob_of_pat npatt,
 		 CastConv (DEFAULTcast,app_ind)),term1) in
   let term3=List.fold_right let_in_one_alias aliases term2 in
   let term4=List.fold_right prod_one_id loc_ids term3 in
@@ -413,18 +412,18 @@ let interp_casee sigma env = function
 
 let abstract_one_arg = function
     (loc,(id,None)) ->
-      (fun raw ->
-	 RLambda (dummy_loc,Name id, Explicit,
-		RHole (loc,Evd.BinderType (Name id)), raw))
+      (fun glob ->
+	 GLambda (dummy_loc,Name id, Explicit,
+		GHole (loc,Evd.BinderType (Name id)), glob))
   | (loc,(id,Some typ)) ->
-      (fun raw ->
-	 RLambda (dummy_loc,Name id, Explicit, fst typ, raw))
+      (fun glob ->
+	 GLambda (dummy_loc,Name id, Explicit, fst typ, glob))
 
-let rawconstr_of_fun args body =
+let glob_constr_of_fun args body =
   List.fold_right abstract_one_arg args (fst body)
 
 let interp_fun sigma env args body =
-  let constr=understand sigma env (rawconstr_of_fun args body) in
+  let constr=understand sigma env (glob_constr_of_fun args body) in
     match_args destLambda [] constr args
 
 let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function
diff --git a/tactics/decl_interp.mli b/plugins/decl_mode/decl_interp.mli
index e2c1e531..46fbcec7 100644
--- a/tactics/decl_interp.mli
+++ b/plugins/decl_mode/decl_interp.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_interp.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Tacinterp
 open Decl_expr
 open Mod_subst
diff --git a/proofs/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
index 250c1655..af6aa4bf 100644
--- a/proofs/decl_mode.ml
+++ b/plugins/decl_mode/decl_mode.ml
@@ -1,44 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decl_mode.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Evd
 open Util
 
+
 let daimon_flag = ref false
 
 let set_daimon_flag () = daimon_flag:=true
 let clear_daimon_flag () = daimon_flag:=false
 let get_daimon_flag () = !daimon_flag
 
-type command_mode =
-    Mode_tactic
-  | Mode_proof
-  | Mode_none
 
-let mode_of_pftreestate pts =
-  let goal = sig_it (Refiner.top_goal_of_pftreestate pts) in
-    if goal.evar_extra = None then
-      Mode_tactic
-    else
-      Mode_proof
-
-let get_current_mode () =
-  try
-    mode_of_pftreestate (Pfedit.get_pftreestate ())
-  with _ -> Mode_none
 
-let check_not_proof_mode str =
- if get_current_mode () = Mode_proof then
-   error str
+(* Information associated to goals. *)
+open Store.Field
 
 type split_tree=
     Skip_patt of Idset.t * split_tree
@@ -72,54 +55,67 @@ type stack_info =
 
 type pm_info =
     { pm_stack : stack_info list}
+let info = Store.field ()
 
-let pm_in,pm_out = Dyn.create "pm_info"
 
-let get_info gl=
-  match gl.evar_extra with
-      None ->  invalid_arg "get_info"
-    | Some extra ->
-	try pm_out extra with _ -> invalid_arg "get_info"
+(* Current proof mode *)
+
+type command_mode =
+    Mode_tactic
+  | Mode_proof
+  | Mode_none
+
+let mode_of_pftreestate pts =
+  (* spiwack: it used to be "top_goal_..." but this should be fine *)
+  let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
+  let goal = List.hd goals in
+    if info.get (Goal.V82.extra sigma goal) = None then
+      Mode_tactic 
+    else
+      Mode_proof
+	  
+let get_current_mode () =
+  try 
+    mode_of_pftreestate (Pfedit.get_pftreestate ())
+  with _ -> Mode_none
+
+let check_not_proof_mode str =
+ if get_current_mode () = Mode_proof then
+   error str
+
+let get_info sigma gl=
+  match info.get (Goal.V82.extra sigma gl) with
+  | None ->  invalid_arg "get_info"
+  | Some pm -> pm
+
+let try_get_info sigma gl =
+  info.get (Goal.V82.extra sigma gl)
 
 let get_stack pts =
-  let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in
-    info.pm_stack
+  let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
+  let info = get_info sigma (List.hd goals) in
+  info.pm_stack
+
+
+let proof_focus = Proof.new_focus_kind ()
+let proof_cond = Proof.no_cond proof_focus
+
+let focus p =
+  let inf = get_stack p in
+  Proof.focus proof_cond inf 1 p
+
+let unfocus = Proof.unfocus proof_focus
+
+let maximal_unfocus = Proof_global.maximal_unfocus proof_focus
 
 let get_top_stack pts =
-  let info = get_info (sig_it (Refiner.top_goal_of_pftreestate pts)) in
+  try
+    Proof.get_at_focus proof_focus pts
+  with Proof.NoSuchFocus ->
+    let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in
+    let info = get_info sigma gl in
     info.pm_stack
 
-let get_end_command pts =
-  match mode_of_pftreestate pts with
-      Mode_proof ->
-	Some
-	  begin
-	    match get_top_stack pts with
-		[] -> "\"end proof\""
-	      | Claim::_ -> "\"end claim\""
-	      | Focus_claim::_-> "\"end focus\""
-	      | (Suppose_case :: Per (et,_,_,_) :: _
-		| Per (et,_,_,_) :: _ ) ->
-		  begin
-		    match et with
-			Decl_expr.ET_Case_analysis ->
-			  "\"end cases\" or start a new case"
-		      | Decl_expr.ET_Induction ->
-			  "\"end induction\" or start a new case"
-		  end
-	      | _ -> anomaly "lonely suppose"
-	  end
-    | Mode_tactic ->
-	begin
-	  try
-	    ignore
-	      (Refiner.up_until_matching_rule Proof_trees.is_proof_instr pts);
-	    Some "\"return\""
-	  with Not_found -> None
-	end
-    | Mode_none ->
-        error "no proof in progress"
-
 let get_last env =
   try
     let (id,_,_) =  List.hd (Environ.named_context env) in id
diff --git a/proofs/decl_mode.mli b/plugins/decl_mode/decl_mode.mli
index 60cb99c1..4e636598 100644
--- a/proofs/decl_mode.mli
+++ b/plugins/decl_mode/decl_mode.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_mode.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Evd
@@ -22,7 +20,7 @@ type command_mode =
   | Mode_proof
   | Mode_none
 
-val mode_of_pftreestate : pftreestate -> command_mode
+val mode_of_pftreestate : Proof.proof -> command_mode
 
 val get_current_mode : unit -> command_mode
 
@@ -61,14 +59,20 @@ type stack_info =
 type pm_info =
     {pm_stack : stack_info list }
 
-val pm_in : pm_info -> Dyn.t
+val info : pm_info Store.Field.t
 
-val get_info : Proof_type.goal -> pm_info
+val get_info : Evd.evar_map -> Proof_type.goal -> pm_info
 
-val get_end_command : pftreestate -> string option
+val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option
 
-val get_stack : pftreestate -> stack_info list
+val get_stack : Proof.proof -> stack_info list
 
-val get_top_stack : pftreestate -> stack_info list
+val get_top_stack : Proof.proof -> stack_info list
 
 val get_last:  Environ.env -> identifier
+
+val focus : Proof.proof -> unit
+
+val unfocus : Proof.proof -> unit
+
+val maximal_unfocus : Proof.proof -> unit
diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mllib
new file mode 100644
index 00000000..39342dbd
--- /dev/null
+++ b/plugins/decl_mode/decl_mode_plugin.mllib
@@ -0,0 +1,6 @@
+Decl_mode
+Decl_interp
+Decl_proof_instr
+Ppdecl_proof
+G_decl_mode
+Decl_mode_plugin_mod
diff --git a/tactics/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index 5a89e859..c1553b35 100644
--- a/tactics/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -1,26 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_proof_instr.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Evd
 
 open Refiner
 open Proof_type
-open Proof_trees
 open Tacmach
 open Tacinterp
 open Decl_expr
 open Decl_mode
 open Decl_interp
-open Rawterm
+open Glob_term
 open Names
 open Nameops
 open Declarations
@@ -35,7 +32,7 @@ open Goptions
 
 (* Strictness option *)
 
-let get_its_info gls = get_info gls.it
+let get_its_info gls = get_info gls.sigma gls.it
 
 let get_strictness,set_strictness =
   let strictness = ref false in
@@ -44,6 +41,7 @@ let get_strictness,set_strictness =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "strict mode";
       optkey   = ["Strict";"Proofs"];
       optread  = get_strictness;
@@ -51,18 +49,20 @@ let _ =
 
 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
-      [pftree] ->
-	{pftree with
-	   goal=gl;
-	   ref=Some (Prim Change_evars,[pftree])}
-    | _ -> anomaly "change_info : Wrong number of subtrees")
+     let concl = pf_concl gls in
+     let hyps = Goal.V82.hyps (project gls) (sig_it gls) in
+     let extra = Goal.V82.extra (project gls) (sig_it gls) in
+     let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in
+     let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in
+     { it = [gl] ; sigma= sigma } )
 
-let tcl_change_info info gls =  tcl_change_info_gen (Some (pm_in info)) gls
+open Store.Field
 
-let tcl_erase_info gls =  tcl_change_info_gen None gls
+let tcl_change_info info gls =  
+  let info_gen = Decl_mode.info.set info in
+  tcl_change_info_gen info_gen gls
+
+let tcl_erase_info gls =  tcl_change_info_gen (Decl_mode.info.remove) gls
 
 let special_whd gl=
   let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
@@ -77,7 +77,7 @@ let is_good_inductive env ind =
     oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
 
 let check_not_per pts =
-  if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then
+  if not (Proof.is_done pts) then
     match get_stack pts with
 	Per (_,_,_,_)::_ ->
 	  error "You are inside a proof per cases/induction.\n\
@@ -112,40 +112,22 @@ let assert_postpone id t =
 
 (* start a proof *)
 
+
 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
-      [pftree] ->
-	{pftree with
-	   goal=gl;
-	   ref=Some (Decl_proof true,[pftree])}
-    | _ -> anomaly "Dem : Wrong number of subtrees"
+  tcl_change_info info gls
 
 let go_to_proof_mode () =
-  Pfedit.mutate
-    (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts))
+  Pfedit.by start_proof_tac;
+  let p = Proof_global.give_me_the_proof () in
+  Decl_mode.focus p
 
 (* closing gaps *)
 
 let daimon_tac gls =
   set_daimon_flag ();
-  ({it=[];sigma=sig_sig gls},
-   function
-       [] ->
-	 {open_subgoals=0;
-	    goal=sig_it gls;
-	    ref=Some (Daimon,[])}
-     | _ -> anomaly "Daimon: Wrong number of subtrees")
-
-let daimon _ pftree =
-  set_daimon_flag ();
-  {pftree with
-     open_subgoals=0;
-     ref=Some (Daimon,[])}
+  {it=[];sigma=sig_sig gls}
 
-let daimon_subtree = map_pftreestate (fun _ ->  frontier_mapi daimon )
 
 (* marking closed blocks *)
 
@@ -159,57 +141,45 @@ 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) ->
-      if lock_focus then
-	Nested(Proof_instr (false,instr),spfl)
-      else
-	anomaly "already marked as done"
   | _ -> anomaly "mark_rule_as_done"
 
-let mark_proof_tree_as_done pt =
-  match pt.ref with
-      None -> anomaly "mark_proof_tree_as_done"
-    | 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)
 
 (* post-instruction focus management *)
 
-let goto_current_focus pts = up_until_matching_rule is_focussing_command pts
+(* spiwack: This used to fail if there was no focusing command
+   above, but I don't think it ever happened. I hope it doesn't mess
+   things up*)
+let goto_current_focus pts = 
+  Decl_mode.maximal_unfocus pts
 
 let goto_current_focus_or_top pts =
-  try
-    up_until_matching_rule is_focussing_command pts
-  with Not_found -> top_of_tree pts
+  goto_current_focus pts
 
 (* return *)
 
 let close_tactic_mode pts =
-    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
+  try goto_current_focus pts
+  with Not_found ->
+    error "\"return\" cannot be used outside of Declarative Proof Mode."
 
-let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode
+let return_from_tactic_mode () =
+  close_tactic_mode (Proof_global.give_me_the_proof ())
 
 (* end proof/claim *)
 
 let close_block bt pts =
-  let stack =
-    if Proof_trees.is_complete_proof (proof_of_pftreestate pts) then
-      get_top_stack pts
+    if Proof.no_focused_goal pts then
+      goto_current_focus pts
     else
-      get_stack pts in
-    match bt,stack with
+      let stack =
+	if Proof.is_done pts then
+	  get_top_stack pts
+	else
+	  get_stack pts 
+      in
+      match bt,stack with
 	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
-	  daimon_subtree (goto_current_focus pts)
+	  (goto_current_focus pts)
       | _, Claim::_ ->
 	  error "\"end claim\" expected."
       | _, Focus_claim::_ ->
@@ -224,22 +194,23 @@ let close_block bt pts =
 	  end
       | _,_ -> anomaly "Lonely suppose on stack."
 
+
 (* utility for suppose / suppose it is *)
 
 let close_previous_case pts =
   if
-    Proof_trees.is_complete_proof (proof_of_pftreestate pts)
+    Proof.is_done pts
   then
     match get_top_stack pts with
 	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (mark_as_done pts)
+	  goto_current_focus (pts)
       | _ -> error "Not inside a proof per cases or induction."
   else
     match get_stack pts with
-	Per (et,_,_,_) :: _ -> pts
+	Per (et,_,_,_) :: _ -> ()
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (mark_as_done (daimon_subtree pts))
+	  goto_current_focus ((pts))
       | _ -> error "Not inside a proof per cases or induction."
 
 (* Proof instructions *)
@@ -252,7 +223,7 @@ let filter_hyps f gls =
       tclIDTAC
     else
       tclTRY (clear [id])  in
-    tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls
+    tclMAP filter_aux (pf_hyps gls) gls
 
 let local_hyp_prefix = id_of_string "___"
 
@@ -358,7 +329,7 @@ let enstack_subsubgoals env se stack gls=
 		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
-              (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in
+              (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in
 	    let ncreated = replace_in_list
 	      se.se_meta nmetas se.se_meta_list in
 	    let evd0 = List.fold_left
@@ -400,12 +371,12 @@ let find_subsubgoal c ctyp skip submetas gls =
     let se = Stack.pop stack in
       try
 	let unifier =
-	  Unification.w_unify true env Reduction.CUMUL
-	    ctyp se.se_type se.se_evd in
+	  Unification.w_unify env se.se_evd Reduction.CUMUL
+	    ~flags:Unification.elim_flags ctyp se.se_type in
 	  if n <= 0 then
 	      {se with
 		 se_evd=meta_assign se.se_meta
-                  (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier;
+                  (c,(Conv,TypeNotProcessed (* ?? *))) unifier;
 	         se_meta_list=replace_in_list
 		  se.se_meta submetas se.se_meta_list}
 	  else
@@ -494,17 +465,17 @@ let mk_stat_or_thesis info gls = function
       error "\"thesis for ...\" is not applicable here."
   | Thesis Plain -> pf_concl gls
 
-let just_tac _then cut info gls0 =
-  let items_tac gls =
+let just_tac _then cut info gls0 = 
+  let last_item = if _then then 
+      let last_id = try get_last (pf_env gls0) with Failure _ -> 
+		error "\"then\" and \"hence\" require at least one previous fact"  in
+		[mkVar last_id]
+	    else []  
+  in
+  let items_tac gls = 
     match cut.cut_by with
 	None -> tclIDTAC gls
-      | Some items ->
-	  let items_ =
-	    if _then then
-	      let last_id = get_last (pf_env gls) in
-		(mkVar last_id)::items
-	    else items
-	  in prepare_goal items_ gls in
+      | Some items -> prepare_goal (last_item@items) gls in
   let method_tac gls =
     match cut.cut_using with
         None ->
@@ -602,8 +573,8 @@ let instr_claim _thus st gls0 =
   let ninfo1 = {pm_stack=
       (if _thus then Focus_claim else Claim)::info.pm_stack} in
     tclTHENS (assert_postpone id st.st_it)
-      [tcl_change_info ninfo1;
-       thus_tac] gls0
+      [thus_tac;
+       tcl_change_info ninfo1] gls0
 
 (* tactics for assume *)
 
@@ -830,7 +801,7 @@ let is_rec_pos (main_ind,wft) =
       None -> false
     | Some index ->
 	match fst (Rtree.dest_node wft) with
-	    Mrec i when i = index -> true
+	    Mrec (_,i) when i = index -> true
 	  | _ -> false
 
 let rec constr_trees (main_ind,wft) ind =
@@ -1316,15 +1287,12 @@ let understand_my_constr c gls =
   let env = pf_env gls in
   let nc = names_of_rel_context env in
   let rawc = Detyping.detype false [] nc c in
-  let rec frob = function REvar _ -> RHole (dummy_loc,QuestionMark Expand) | rc ->  map_rawconstr frob rc in
+  let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc ->  map_glob_constr frob rc in
     Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc)
 
-let set_refine,my_refine =
-let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in
-((fun tac -> refine:= tac),
-(fun c gls -> 
-   let oc = understand_my_constr c gls in
-     !refine oc gls))
+let my_refine c gls =
+  let oc = understand_my_constr c gls in
+  Refine.refine oc gls
 
 (* end focus/claim *)
 
@@ -1398,7 +1366,12 @@ let end_tac et2 gls =
 
 (* escape *)
 
-let escape_tac gls =  tcl_erase_info gls
+let escape_tac gls =
+  (* spiwack: sets an empty info stack to avoid interferences.
+     We could erase the info altogether, but that doesn't play
+     well with the Decl_mode.focus (used in post_processing). *)
+  let info={pm_stack=[]} in
+  tcl_change_info info gls
 
 (* General instruction engine *)
 
@@ -1446,59 +1419,69 @@ let rec preprocess pts instr =
   | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _
   | Pdefine (_,_,_) | Pper _ | Prew _ ->
       check_not_per pts;
-      true,pts
+      true
   | Pescape ->
       check_not_per pts;
-      true,pts
+      true
   | Pcase _ | Psuppose _ | Pend (B_elim _) ->
-      true,close_previous_case pts
+      close_previous_case pts ;
+      true
   | Pend bt ->
-      false,close_block bt pts
+      close_block bt pts ;
+      false
 
 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 _
-    | Pescape -> nth_unproven 1 pts
+    | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> ()
+    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ ->
+      Decl_mode.focus pts
+    | Pescape ->
+      Decl_mode.focus pts;
+      Proof_global.set_proof_mode "Classic"
     | 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
+	  let pfterm = List.hd (Proof.partial_proof pts) in
+	  let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in
+	  let env =  try
+		       Goal.V82.env sigma (List.hd gls)
+	             with Failure "hd" ->
+		       Global.env ()
+	  in
 	    try
 	      Inductiveops.control_only_guard env pfterm;
-	      goto_current_focus_or_top (mark_as_done pts)
+	      goto_current_focus_or_top pts
  	    with
 		Type_errors.TypeError(env,
 				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
 		  anomaly "\"end induction\" generated an ill-formed fixpoint"
 	end
     | Pend _ ->
-	goto_current_focus_or_top (mark_as_done pts)
+	goto_current_focus_or_top (pts)
 
 let do_instr raw_instr pts =
-  let has_tactic,pts1 = preprocess pts raw_instr.instr in
-  let pts2 =
+  let has_tactic = preprocess pts raw_instr.instr in
+  begin
     if has_tactic then
-      let gl = nth_goal_of_pftreestate 1 pts1 in
+      let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
+      let gl = { it=List.hd gls ; sigma=sigma } in
       let env=  pf_env gl in
-      let sigma= project gl in
       let ist = {ltacvars = ([],[]); ltacrecvars = [];
 		 gsigma = sigma; genv = env} in
       let glob_instr = intern_proof_instr ist raw_instr in
       let instr =
 	interp_proof_instr (get_its_info gl) sigma env glob_instr in
-      let lock_focus = is_focussing_instr instr.instr in
-      let marker= Proof_instr (lock_focus,instr) in
-	solve_nth_pftreestate 1
-	  (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1
-    else pts1 in
-      postprocess pts2 raw_instr.instr
+      Pfedit.by (tclTHEN (eval_instr instr) clean_tmp)
+    else () end;
+  postprocess pts raw_instr.instr;
+  (* spiwack: this should restore a compatible semantics with
+     v8.3 where we never stayed focused on 0 goal. *)
+  Decl_mode.maximal_unfocus pts
 
 let proof_instr raw_instr =
-  Pfedit.mutate (do_instr raw_instr)
+  let p = Proof_global.give_me_the_proof () in
+  do_instr raw_instr p
 
 (*
 
diff --git a/tactics/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli
index 5af60a1b..1205060a 100644
--- a/tactics/decl_proof_instr.mli
+++ b/plugins/decl_mode/decl_proof_instr.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_proof_instr.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Refiner
 open Names
 open Term
@@ -21,20 +19,14 @@ val register_automation_tac: tactic -> unit
 
 val automation_tac : tactic
 
-val daimon_subtree: pftreestate -> pftreestate
-
 val concl_refiner:
   Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
 
-val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate
+val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit
 val proof_instr: Decl_expr.raw_proof_instr -> unit
 
 val tcl_change_info : Decl_mode.pm_info -> tactic
 
-val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree
-
-val mark_as_done : pftreestate -> pftreestate
-
 val execute_cases :
     Names.name ->
     Decl_mode.per_info ->
@@ -43,20 +35,20 @@ val execute_cases :
     Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic
 
 val tree_of_pats : 
-  identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list ->
+  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree
 
 val add_branch : 
-  identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list ->
+  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val append_branch :
-  identifier *(int * int) -> int -> (Rawterm.cases_pattern*recpath) list list ->
+  identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
   (Names.Idset.t * Decl_mode.split_tree) option ->
   (Names.Idset.t * Decl_mode.split_tree) option
 
 val append_tree :
-  identifier * (int * int) -> int -> (Rawterm.cases_pattern*recpath) list list ->
+  identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val build_dep_clause :   Term.types Decl_expr.statement list ->
@@ -69,12 +61,12 @@ val register_dep_subcase :
     Names.identifier * (int * int) ->
     Environ.env ->
     Decl_mode.per_info ->
-    Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
+    Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
 
 val thesis_for :     Term.constr ->
     Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr
 
-val close_previous_case : pftreestate -> pftreestate
+val close_previous_case : Proof.proof -> unit
 
 val pop_stacks :
   (Names.identifier *
@@ -115,5 +107,3 @@ val init_tree:
      (int option * Declarations.recarg Rtree.t) array ->
      (Names.Idset.t * Decl_mode.split_tree) option) ->
     Decl_mode.split_tree
-
-val set_refine : (Evd.open_constr -> Proof_type.tactic) -> unit
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
new file mode 100644
index 00000000..27def8cc
--- /dev/null
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -0,0 +1,408 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* arnaud: veiller à l'aspect tutorial des commentaires *)
+
+open Pp
+open Tok
+open Decl_expr
+open Names
+open Term
+open Genarg
+open Pcoq
+
+open Pcoq.Constr
+open Pcoq.Tactic
+open Pcoq.Vernac_
+
+let pr_goal gs =
+  let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in
+  let env = Goal.V82.unfiltered_env sigma g in
+  let preamb,thesis,penv,pc =
+    (str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
+    (str "thesis := "  ++ fnl ()),
+    Printer.pr_context_of env,
+    Printer.pr_ltype_env_at_top env (Goal.V82.concl sigma g)
+  in
+    preamb ++
+    str"  " ++ hv 0 (penv ++ fnl () ++
+		       str (Printer.emacs_str "")  ++
+		       str "============================" ++ fnl ()  ++
+		       thesis ++ str " " ++  pc) ++ fnl ()
+
+(* arnaud: rebrancher ça 
+let pr_open_subgoals () =
+  let p = Proof_global.give_me_the_proof () in
+  let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in
+  let close_cmd = Decl_mode.get_end_command p in
+  pr_subgoals close_cmd sigma goals
+*)
+
+let pr_proof_instr instr = 
+  Util.anomaly "Cannot print a proof_instr"
+    (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller
+                     dans cette direction
+       Ppdecl_proof.pr_proof_instr (Global.env()) instr
+    *)
+let pr_raw_proof_instr instr =
+  Util.anomaly "Cannot print a raw proof_instr"
+let pr_glob_proof_instr instr =
+  Util.anomaly "Cannot print a non-interpreted proof_instr"
+
+let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
+  Decl_interp.interp_proof_instr 
+    (Decl_mode.get_info sigma gl)
+    (sigma)
+    (Goal.V82.env sigma gl)
+
+let vernac_decl_proof () = 
+  let pf = Proof_global.give_me_the_proof () in
+  if Proof.is_done pf then 
+    Util.error "Nothing left to prove here."
+  else
+    Proof.transaction pf begin fun () ->
+      Decl_proof_instr.go_to_proof_mode () ;
+      Proof_global.set_proof_mode "Declarative" ;
+      Vernacentries.print_subgoals ()
+    end
+
+(* spiwack: some bureaucracy is not performed here *)
+let vernac_return () =
+  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+    Decl_proof_instr.return_from_tactic_mode () ;
+    Proof_global.set_proof_mode "Declarative" ;
+    Vernacentries.print_subgoals ()
+  end
+
+let vernac_proof_instr instr =
+  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+    Decl_proof_instr.proof_instr instr;
+    Vernacentries.print_subgoals ()
+  end
+
+(* We create a new parser entry [proof_mode]. The Declarative proof mode
+    will replace the normal parser entry for tactics with this one. *)
+let proof_mode = Gram.entry_create "vernac:proof_command"
+(* Auxiliary grammar entry. *)
+let proof_instr = Gram.entry_create "proofmode:instr"
+
+(* Before we can write an new toplevel command (see below) 
+    which takes a [proof_instr] as argument, we need to declare
+    how to parse it, print it, globalise it and interprete it.
+    Normally we could do that easily through ARGUMENT EXTEND, 
+    but as the parsing is fairly complicated we will do it manually to
+    indirect through the [proof_instr] grammar entry. *)
+(* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *)
+
+(* [Genarg.create_arg] creates a new embedding into Genarg. *)
+let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) =
+  Genarg.create_arg "proof_instr"
+let _ = Tacinterp.add_interp_genarg "proof_instr"
+  begin
+  begin fun e x -> (* declares the globalisation function *)
+    Genarg.in_gen globwit_proof_instr 
+      (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x))
+  end,
+  begin fun ist gl x -> (* declares the interpretation function *)
+    Genarg.in_gen wit_proof_instr 
+      (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x))
+  end,
+  begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *)
+   end
+
+let _ = Pptactic.declare_extra_genarg_pprule
+  (rawwit_proof_instr, pr_raw_proof_instr)
+  (globwit_proof_instr, pr_glob_proof_instr)
+  (wit_proof_instr, pr_proof_instr)
+
+(* We use the VERNAC EXTEND facility with a custom non-terminal
+    to populate [proof_mode] with a new toplevel interpreter.
+    The "-" indicates that the rule does not start with a distinguished
+    string. *)
+VERNAC proof_mode EXTEND ProofInstr
+  [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ]
+END
+
+(* It is useful to use GEXTEND directly to call grammar entries that have been
+    defined previously VERNAC EXTEND. In this case we allow, in proof mode,
+    the use of commands like Check or Print. VERNAC EXTEND does quite a bit of
+    bureaucracy for us, but it is not needed in this sort of case, and it would require
+    to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *)
+GEXTEND Gram
+  GLOBAL: proof_mode ;
+
+  proof_mode: LAST
+    [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ]
+  ;
+END  
+
+(* We register a new proof mode here *)
+
+let _ = 
+  Proof_global.register_proof_mode { Proof_global.
+				       name = "Declarative" ; (* name for identifying and printing *)
+				       (* function [set] goes from No Proof Mode to 
+					   Declarative Proof Mode performing side effects *)
+				       set = begin fun () ->
+					 (* We set the command non terminal to
+					     [proof_mode] (which we just defined). *)
+					 G_vernac.set_command_entry proof_mode ;
+					 (* We substitute the goal printer, by the one we built
+					     for the proof mode. *)
+					 Printer.set_printer_pr { Printer.default_printer_pr with
+								                Printer.pr_goal = pr_goal }
+				       end ;
+                                       (* function [reset] goes back to No Proof Mode from
+					   Declarative Proof Mode *)
+				       reset = begin fun () ->
+					 (* We restore the command non terminal to
+					      [noedit_mode]. *)
+					 G_vernac.set_command_entry G_vernac.noedit_mode ;
+					 (* We restore the goal printer to default *)
+					 Printer.set_printer_pr Printer.default_printer_pr
+				       end
+				   }
+
+(* Two new vernacular commands *)
+VERNAC COMMAND EXTEND DeclProof
+  [ "proof" ] -> [ vernac_decl_proof () ]
+END
+VERNAC COMMAND EXTEND  DeclReturn
+  [ "return" ] -> [ vernac_return () ]
+END
+
+let none_is_empty = function
+    None -> []
+  | Some l -> l
+
+GEXTEND Gram
+GLOBAL: proof_instr;
+  thesis :
+    [[ "thesis" -> Plain 
+     | "thesis"; "for"; i=ident -> (For i)
+     ]];
+  statement :
+    [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c}
+     | i=ident -> {st_label=Anonymous;
+		   st_it=Topconstr.CRef (Libnames.Ident (loc, i))}
+     | c=constr -> {st_label=Anonymous;st_it=c}
+     ]];
+  constr_or_thesis :
+     [[ t=thesis -> Thesis t ] |
+      [ c=constr -> This c
+      ]];
+  statement_or_thesis : 
+    [
+      [ 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;
+		    st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))}
+      | c=constr -> {st_label=Anonymous;st_it=This c}
+      ]
+    ];
+  justification_items : 
+    [[ -> Some [] 
+     | "by"; l=LIST1 constr SEP "," -> Some l
+     | "by"; "*"                    -> None ]]
+  ;
+  justification_method : 
+    [[ -> None 
+     | "using";  tac = tactic -> Some tac ]]
+  ;
+  simple_cut_or_thesis :
+    [[ ls = statement_or_thesis;
+       j = justification_items;
+       taco = justification_method 	
+	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
+  ;
+  simple_cut :
+    [[ ls = statement;
+       j = justification_items;
+       taco = justification_method 	
+	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
+  ;
+  elim_type:
+    [[ IDENT "induction" -> ET_Induction
+     | IDENT "cases" -> ET_Case_analysis ]]
+  ;
+  block_type :
+    [[ IDENT "claim" -> B_claim
+     | 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" ; 
+       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} ]] 
+  ;
+  rew_step :
+    [[ "~=" ;         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"; 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); 
+     | IDENT "have"; c=simple_cut_or_thesis -> Pcut c;
+     | IDENT "claim"; c=statement -> Pclaim 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: 
+    [[ id=ident -> fun x -> (loc,(id,x)) ]];
+  hyp:
+    [[ id=loc_id -> id None ;
+     | id=loc_id ; ":" ; c=constr -> id (Some c)]]
+  ;
+  consider_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=consider_vars -> (Hvar name) :: v
+     | name=hyp; 
+       IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h
+     ]]
+  ;
+  consider_hyps:  
+    [[ st=statement; IDENT "and"; h=consider_hyps  -> Hprop st::h
+     | 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; 
+       IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h
+     ]]
+  ;
+  assume_hyps:  
+    [[ st=statement; IDENT "and"; h=assume_hyps  -> Hprop st::h
+     | st=statement; IDENT "and"; 
+       IDENT "we"; IDENT "have" ; v=assume_vars  -> Hprop st::v
+     | st=statement -> [Hprop st]
+     ]]
+  ;
+  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 -> 
+	 let (q,c) = v in ((Hvar name) :: q),c
+     | 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  ->	 
+	 let (q,c) = h in (Hprop st::q),c
+     | 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 -> 
+	 [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"; 
+       IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h
+     ]]
+  ;
+  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]
+    ]];
+  given_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=given_vars -> (Hvar name) :: v
+     | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h
+     ]]
+  ;
+  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; ","; v=suppose_vars -> (Hvar name) :: v
+     |name=hyp; OPT[IDENT "be"]; 
+      IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h
+     ]]
+  ;
+  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
+     | st=statement_or_thesis -> [Hprop st]
+     ]]
+  ;
+  suppose_clause:
+    [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v;
+     |  h=suppose_hyps -> h ]]
+  ;
+  intro_step:
+    [[ IDENT "suppose" ; h=assume_clause -> Psuppose h
+     | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ;
+       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	 
+     | 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; 
+       "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 : 
+    [[ -> 0
+     | "*" -> 1
+     | "**" -> 2
+     | "***" -> 3
+     ]]
+  ;
+  bare_proof_instr:
+    [[ c = cut_step -> c ;
+     | i = intro_step -> i ]]
+  ;
+  proof_instr :
+    [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]]
+  ;
+END;;
+
+ 
diff --git a/parsing/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index c0eddcc5..b866efab 100644
--- a/parsing/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppdecl_proof.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Decl_expr
diff --git a/parsing/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli
index fd6fb663..fd6fb663 100644
--- a/parsing/ppdecl_proof.mli
+++ b/plugins/decl_mode/ppdecl_proof.mli
diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v
index 5ddc4452..1b66c334 100644
--- a/plugins/dp/Dp.v
+++ b/plugins/dp/Dp.v
@@ -6,8 +6,6 @@ Require Export Classical.
 (* Zenon *)
 
 (*  Copyright 2004 INRIA  *)
-(*  $Id: Dp.v 12337 2009-09-17 15:58:14Z glondu $  *)
-
 Lemma zenon_nottrue :
   (~True -> False).
 Proof. tauto. Qed.
diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml
index ceadd26e..837195e4 100644
--- a/plugins/dp/dp.ml
+++ b/plugins/dp/dp.ml
@@ -23,7 +23,6 @@ open Fol
 open Names
 open Nameops
 open Namegen
-open Termops
 open Coqlib
 open Hipattern
 open Libnames
@@ -37,7 +36,7 @@ let set_trace b = trace := b
 let timeout = ref 10
 let set_timeout n = timeout := n
 
-let (dp_timeout_obj,_) =
+let dp_timeout_obj : int -> obj =
   declare_object
     {(default_object "Dp_timeout") with
        cache_function = (fun (_,x) -> set_timeout x);
@@ -45,7 +44,7 @@ let (dp_timeout_obj,_) =
 
 let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
 
-let (dp_debug_obj,_) =
+let dp_debug_obj : bool -> obj =
   declare_object
     {(default_object "Dp_debug") with
        cache_function = (fun (_,x) -> set_debug x);
@@ -53,7 +52,7 @@ let (dp_debug_obj,_) =
 
 let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
 
-let (dp_trace_obj,_) =
+let dp_trace_obj : bool -> obj =
   declare_object
     {(default_object "Dp_trace") with
        cache_function = (fun (_,x) -> set_trace x);
@@ -148,7 +147,7 @@ let fresh_var = function
    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
+  let avoid = ref (Termops.ids_of_named_context (Environ.named_context env)) in
   List.fold_right
     (fun (na,t) (newvars, newenv) ->
        let id = next_name_away na !avoid in
@@ -183,7 +182,7 @@ let decomp_type_lambdas env t =
 
 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
+    | Prod (_,t,c) when not (Termops.dependent (mkRel 1) c) -> arrows_rec (t :: l) c
     | Cast (c,_,_) -> arrows_rec l c
     | _ -> List.rev l, c
   in
@@ -195,8 +194,8 @@ let rec eta_expanse t vars env i =
     t, vars, env
   else
     match kind_of_term (Typing.type_of env Evd.empty t) with
-      | Prod (n, a, b) when not (dependent (mkRel 1) b) ->
-	  let avoid = ids_of_named_context (Environ.named_context env) in
+      | Prod (n, a, b) when not (Termops.dependent (mkRel 1) b) ->
+	  let avoid = Termops.ids_of_named_context (Environ.named_context env) in
 	  let id = next_name_away n avoid in
 	  let env' = Environ.push_named (id, None, a) env in
 	  let t' = mkApp (t, [| mkVar id |]) in
@@ -469,7 +468,7 @@ and axiomatize_body env r id d = match r with
   | VarRef _ ->
       assert false
   | ConstRef c ->
-      begin match (Global.lookup_constant c).const_body with
+      begin match body_of_constant (Global.lookup_constant c) with
 	| Some b ->
 	    let b = force b in
 	    let axioms =
@@ -826,7 +825,7 @@ let prelude_files = ref ([] : string list)
 
 let set_prelude l = prelude_files := l
 
-let (dp_prelude_obj,_) =
+let dp_prelude_obj : string list -> obj =
   declare_object
     {(default_object "Dp_prelude") with
        cache_function = (fun (_,x) -> set_prelude x);
@@ -1088,7 +1087,7 @@ let dp_hint l =
   in
   List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
 
-let (dp_hint_obj,_) =
+let dp_hint_obj : reference list -> obj =
   declare_object
     {(default_object "Dp_hint") with
        cache_function = (fun (_,l) -> dp_hint l);
@@ -1114,7 +1113,7 @@ let dp_predefined qid s =
   with NotFO ->
     msg_warning (str " ignored (not a first order declaration)")
 
-let (dp_predefined_obj,_) =
+let dp_predefined_obj : reference * string -> obj =
   declare_object
     {(default_object "Dp_predefined") with
        cache_function = (fun (_,(id,s)) -> dp_predefined id s);
diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
index fc957ea6..001ccce8 100644
--- a/plugins/dp/g_dp.ml4
+++ b/plugins/dp/g_dp.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_dp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Dp
 
 TACTIC EXTEND Simplify
diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v
index 0940b135..ce660052 100644
--- a/plugins/dp/test2.v
+++ b/plugins/dp/test2.v
@@ -73,7 +73,7 @@ zenon.
 Inductive IN (A:Set) : A -> list A -> Prop :=
   | IN1 : forall x l, IN A x (x::l)
   | IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
-Implicit Arguments IN [A].
+Arguments IN [A] _ _.
 
 Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
   zenon.
diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v
index f2400a7f..89028c4f 100644
--- a/plugins/dp/zenon.v
+++ b/plugins/dp/zenon.v
@@ -1,6 +1,4 @@
 (*  Copyright 2004 INRIA  *)
-(*  $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $  *)
-
 Require Export Classical.
 
 Lemma zenon_nottrue :
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
index eab2f67c..c9556972 100644
--- a/plugins/extraction/ExtrOcamlBasic.v
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (** Extraction to Ocaml : use of basic Ocaml types *)
 
-Scheme Equality for nat.
-
 Extract Inductive bool => bool [ true false ].
 Extract Inductive option => option [ Some None ].
 Extract Inductive unit => unit [ "()" ].
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
index e38d41e3..69e72918 100644
--- a/plugins/extraction/ExtrOcamlBigIntConv.v
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
index b059b2a0..697ea6b3 100644
--- a/plugins/extraction/ExtrOcamlIntConv.v
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
index 1fb83c5b..0a303b63 100644
--- a/plugins/extraction/ExtrOcamlNatBigInt.v
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 
 (** Extraction of [nat] into Ocaml's [big_int] *)
 
-Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import Arith Even Div2 EqNat Euclid.
 Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
@@ -36,7 +36,7 @@ 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 nat_beq => "Big.eq".*)
 Extract Constant EqNat.beq_nat => "Big.eq".
 Extract Constant EqNat.eq_nat_decide => "Big.eq".
 
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
index e577ebe1..a0cb26b5 100644
--- a/plugins/extraction/ExtrOcamlNatInt.v
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 
 (** Extraction of [nat] into Ocaml's [int] *)
 
-Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import Arith Even Div2 EqNat Euclid.
 Require Import ExtrOcamlBasic.
 
 (** Disclaimer: trying to obtain efficient certified programs
@@ -45,7 +45,7 @@ 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 nat_beq => "(=)".*)
 Extract Inlined Constant EqNat.beq_nat => "(=)".
 Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
 
@@ -72,4 +72,4 @@ Definition test n m (H:m>0) :=
  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
index 48260e3d..f8f942c8 100644
--- a/plugins/extraction/ExtrOcamlString.v
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 5ca6bd7b..12607b3a 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 
 (** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)
 
-Require Import ZArith NArith ZOdiv_def.
+Require Import ZArith NArith.
 Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
@@ -36,42 +36,44 @@ Extract Inductive N => "Big.big_int"
 
 (** 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 =>
+Extract Constant Pos.add => "Big.add".
+Extract Constant Pos.succ => "Big.succ".
+Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)".
+Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)".
+Extract Constant Pos.mul => "Big.mult".
+Extract Constant Pos.min => "Big.min".
+Extract Constant Pos.max => "Big.max".
+Extract Constant Pos.compare =>
+ "fun x y -> Big.compare_case Eq Lt Gt x y".
+Extract Constant Pos.compare_cont =>
  "fun x y c -> Big.compare_case c Lt Gt x y".
 
-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 =>
+Extract Constant N.add => "Big.add".
+Extract Constant N.succ => "Big.succ".
+Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant N.mul => "Big.mult".
+Extract Constant N.min => "Big.min".
+Extract Constant N.max => "Big.max".
+Extract Constant N.div =>
  "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
-Extract Constant Nmod =>
+Extract Constant N.modulo =>
  "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".
+Extract Constant N.compare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Z.add => "Big.add".
+Extract Constant Z.succ => "Big.succ".
+Extract Constant Z.pred => "Big.pred".
+Extract Constant Z.sub => "Big.sub".
+Extract Constant Z.mul => "Big.mult".
+Extract Constant Z.opp => "Big.opp".
+Extract Constant Z.abs => "Big.abs".
+Extract Constant Z.min => "Big.min".
+Extract Constant Z.max => "Big.max".
+Extract Constant Z.compare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Z.of_N => "fun p -> p".
+Extract Constant Z.abs_N => "Big.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/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
index a7046626..55ba0ca1 100644
--- a/plugins/extraction/ExtrOcamlZInt.v
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 
 (** Extraction of [positive], [N] and [Z] into Ocaml's [int] *)
 
-Require Import ZArith NArith ZOdiv_def.
+Require Import ZArith NArith.
 Require Import ExtrOcamlBasic.
 
 (** Disclaimer: trying to obtain efficient certified programs
@@ -33,44 +33,46 @@ Extract Inductive N => int [ "0" "" ]
 
 (** 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 =>
+Extract Constant Pos.add => "(+)".
+Extract Constant Pos.succ => "succ".
+Extract Constant Pos.pred => "fun n -> max 1 (n-1)".
+Extract Constant Pos.sub => "fun n m -> max 1 (n-m)".
+Extract Constant Pos.mul => "( * )".
+Extract Constant Pos.min => "min".
+Extract Constant Pos.max => "max".
+Extract Constant Pos.compare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+Extract Constant Pos.compare_cont =>
  "fun x y c -> if x=y then c else if x<y then Lt else Gt".
 
 
-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 =>
+Extract Constant N.add => "(+)".
+Extract Constant N.succ => "succ".
+Extract Constant N.pred => "fun n -> max 0 (n-1)".
+Extract Constant N.sub => "fun n m -> max 0 (n-m)".
+Extract Constant N.mul => "( * )".
+Extract Constant N.min => "min".
+Extract Constant N.max => "max".
+Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b".
+Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b".
+Extract Constant N.compare =>
  "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 =>
+Extract Constant Z.add => "(+)".
+Extract Constant Z.succ => "succ".
+Extract Constant Z.pred => "pred".
+Extract Constant Z.sub => "(-)".
+Extract Constant Z.mul => "( * )".
+Extract Constant Z.opp => "(~-)".
+Extract Constant Z.abs => "abs".
+Extract Constant Z.min => "min".
+Extract Constant Z.max => "max".
+Extract Constant Z.compare =>
  "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".
+Extract Constant Z.of_N => "fun p -> p".
+Extract Constant Z.abs_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/plugins/extraction/big.ml b/plugins/extraction/big.ml
index ae04ba6d..4c33691d 100644
--- a/plugins/extraction/big.ml
+++ b/plugins/extraction/big.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 9713fcd2..0bd5b843 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 open Names
@@ -35,17 +33,41 @@ let is_mp_bound = function MPbound _ -> true | _ -> false
 
 let pp_par par st = if par then str "(" ++ st ++ str ")" else st
 
+(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *)
+
 let pp_apply st par args = match args with
   | [] -> st
   | _  -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
 
+(** Same as [pp_apply], but with also protection of the head by parenthesis *)
+
+let pp_apply2 st par args =
+  let par' = args <> [] || par in
+  pp_apply (pp_par par' st) par args
+
 let pr_binding = function
   | [] -> mt ()
   | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
 
+let pp_tuple_light f = function
+  | [] -> mt ()
+  | [x] -> f true x
+  | l ->
+      pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
+
+let pp_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
+
+let pp_boxed_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
+
 (** By default, in module Format, you can do horizontal placing of blocks
     even if they include newlines, as long as the number of chars in the
-    blocks are less that a line length. To avoid this awkward situation,
+    blocks is less that a line length. To avoid this awkward situation,
     we attach a big virtual size to [fnl] newlines. *)
 
 let fnl () = stras (1000000,"") ++ fnl ()
@@ -54,8 +76,6 @@ 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
   | '0'..'9' -> true
   | _ -> false
@@ -352,12 +372,13 @@ let ref_renaming_fun (k,r) =
   let l = mp_renaming mp in
   let l = if lang () <> Ocaml && not (modular ()) then [""] else l in
   let s =
+    let idg = safe_basename_of_global r in
     if l = [""] (* this happens only at toplevel of the monolithic case *)
     then
       let globs = Idset.elements (get_global_ids ()) in
-      let id = next_ident_away (kindcase_id k (safe_basename_of_global r)) globs in
+      let id = next_ident_away (kindcase_id k idg) globs in
       string_of_id id
-    else modular_rename k (safe_basename_of_global r)
+    else modular_rename k idg
   in
   add_global_ids (id_of_string s);
   s::l
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
index 22bad6cd..02a496be 100644
--- a/plugins/extraction/common.mli
+++ b/plugins/extraction/common.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Libnames
 open Miniml
@@ -22,10 +20,19 @@ open Pp
 val fnl : unit -> std_ppcmds
 val fnl2 : unit -> std_ppcmds
 val space_if : bool -> std_ppcmds
-val sec_space_if : bool -> std_ppcmds
 
 val pp_par : bool -> std_ppcmds -> std_ppcmds
+
+(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *)
 val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
+
+(** Same as [pp_apply], but with also protection of the head by parenthesis *)
+val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
+
+val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds
+val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+
 val pr_binding : identifier list -> std_ppcmds
 
 val rename_id : identifier -> Idset.t -> identifier
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 3fa674d3..73062328 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Term
 open Declarations
 open Names
@@ -40,21 +38,19 @@ let toplevel_env () =
 	in l,seb
     | _ -> failwith "caught"
   in
-  match current_toplevel () with
-    | _ -> SEBstruct (List.rev (map_succeed get_reference seg))
- 
+  SEBstruct (List.rev (map_succeed get_reference seg))
+
 
 let environment_until dir_opt =
   let rec parse = function
     | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
     | [] -> []
     | d :: l ->
-      let mb = Global.lookup_module (MPfile d) in
-      (* If -dont-load-proof has been used, mod_expr is None,
-         we try with mod_type *)
-      let meb = Option.default mb.mod_type mb.mod_expr in
-      if dir_opt = Some d then [MPfile d, meb]
-      else (MPfile d, meb) :: (parse 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 ())
 
 
@@ -68,6 +64,9 @@ module type VISIT = sig
   (* Add the module_path and all its prefixes to the mp visit list *)
   val add_mp : module_path -> unit
 
+  (* Same, but we'll keep all fields of these modules *)
+  val add_mp_all : module_path -> unit
+
   (* Add kernel_name / constant / reference / ... in the visit lists.
      These functions silently add the mp of their arg in the mp list *)
   val add_ind : mutual_inductive -> unit
@@ -81,6 +80,7 @@ module type VISIT = sig
   val needed_ind : mutual_inductive -> bool
   val needed_con : constant -> bool
   val needed_mp : module_path -> bool
+  val needed_mp_all : module_path -> bool
 end
 
 module Visit : VISIT = struct
@@ -88,16 +88,26 @@ module Visit : VISIT = struct
      (for inductives and modules names) and a Cset_env for constants
      (and still the remaining MPset) *)
   type must_visit =
-      { mutable ind : KNset.t; mutable con : KNset.t; mutable mp : MPset.t }
+      { mutable ind : KNset.t; mutable con : KNset.t;
+	mutable mp : MPset.t; mutable mp_all : MPset.t }
   (* the imperative internal visit lists *)
-  let v = { ind = KNset.empty ; con = KNset.empty ; mp = MPset.empty }
+  let v = { ind = KNset.empty ; con = KNset.empty ;
+	    mp = MPset.empty; mp_all = MPset.empty }
   (* the accessor functions *)
-  let reset () = v.ind <- KNset.empty; v.con <- KNset.empty; v.mp <- MPset.empty
+  let reset () =
+    v.ind <- KNset.empty;
+    v.con <- KNset.empty;
+    v.mp <- MPset.empty;
+    v.mp_all <- MPset.empty
   let needed_ind i = KNset.mem (user_mind i) v.ind
   let needed_con c = KNset.mem (user_con c) v.con
-  let needed_mp mp = MPset.mem mp v.mp
+  let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all
+  let needed_mp_all mp = MPset.mem mp v.mp_all
   let add_mp mp =
     check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp
+  let add_mp_all mp =
+    check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp;
+    v.mp_all <- MPset.add mp v.mp_all
   let add_ind i =
     let kn = user_mind i in
     v.ind <- KNset.add kn v.ind; add_mp (modpath kn)
@@ -120,12 +130,17 @@ let check_arity env cb =
 
 let check_fix env cb i =
   match cb.const_body with
-    | None -> raise Impossible
-    | Some lbody ->
-	match kind_of_term (Declarations.force lbody) with
+    | Def lbody ->
+	(match kind_of_term (Declarations.force lbody) with
 	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
 	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
-	  | _ -> raise Impossible
+	  | _ -> raise Impossible)
+    | Undef _ | OpaqueDef _ -> raise Impossible
+
+let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) =
+  na1 = na2 &&
+  array_equal eq_constr ca1 ca2 &&
+  array_equal eq_constr ta1 ta2
 
 let factor_fix env l cb msb =
   let _,recd as check = check_fix env cb 0 in
@@ -139,7 +154,8 @@ let factor_fix env l cb msb =
       (fun j ->
 	 function
 	   | (l,SFBconst cb') ->
-	       if check <> check_fix env cb' (j+1) then raise Impossible;
+	       let check' = check_fix env cb' (j+1) in
+	       if not (fst check = fst check' && prec_declaration_equal (snd check) (snd check')) then raise Impossible;
 	       labels.(j+1) <- l;
 	   | _ -> raise Impossible) msb';
     labels, recd, msb''
@@ -157,7 +173,8 @@ let rec seb2mse = function
 
 let expand_seb env mp seb =
   let seb,_,_,_ =
-    Mod_typing.translate_struct_module_entry env mp true (seb2mse seb)
+    let inl = Some (Flags.get_inline_level()) in
+    Mod_typing.translate_struct_module_entry env mp inl (seb2mse seb)
   in seb
 
 (** When possible, we use the nicer, shorter, algebraic type structures
@@ -200,9 +217,8 @@ let rec extract_sfb_spec env mp = function
       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 mind = mind_of_kn kn in
-      let s = Sind (kn, extract_inductive env mind) in
+      let mind = make_mind mp empty_dirpath l in
+      let s = Sind (mind, extract_inductive env mind) in
       let specs = extract_sfb_spec env mp msig in
       if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
@@ -223,7 +239,7 @@ let rec extract_sfb_spec env mp = function
 *)
 
 and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
-  | SEBident mp -> Visit.add_mp mp; MTident mp
+  | SEBident mp -> Visit.add_mp_all mp; MTident mp
   | 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
@@ -231,7 +247,7 @@ and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
 	 | None -> mt
 	 | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
   | SEBwith(seb',With_module_body(idl,mp))->
-      Visit.add_mp mp;
+      Visit.add_mp_all mp;
       MTwith(extract_seb_spec env mp1 (seb,seb'),
 	     ML_With_module(idl,mp))
   | SEBfunctor (mbid, mtb, seb_alg') ->
@@ -283,11 +299,10 @@ let rec extract_sfb env mp all = function
 	 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 mind = mind_of_kn kn in
+      let mind = make_mind mp empty_dirpath l in
       let b = Visit.needed_ind mind in
       if all || b then
-	let d = Dind (kn, extract_inductive env mind) in
+	let d = Dind (mind, extract_inductive env mind) in
 	if (not b) && (logical_decl d) then ms
 	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
@@ -312,7 +327,7 @@ and extract_seb env mp all = function
       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
+      Visit.add_mp_all mp; MEident mp
   | SEBapply (meb, meb',_) ->
       MEapply (extract_seb env mp true meb,
 	       extract_seb env mp true meb')
@@ -346,11 +361,12 @@ let unpack = function MEstruct (_,sel) -> sel | _ -> assert false
 let mono_environment refs mpl =
   Visit.reset ();
   List.iter Visit.add_ref refs;
-  List.iter Visit.add_mp mpl;
+  List.iter Visit.add_mp_all 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
+    (fun (mp,m) -> mp, unpack (extract_seb env mp (Visit.needed_mp_all mp) m))
+    l
 
 (**************************************)
 (*S Part II : Input/Output primitives *)
@@ -488,13 +504,18 @@ let print_structure_to_file (fn,si,mo) dry struc =
 let reset () =
   Visit.reset (); reset_tables (); reset_renaming_tables Everything
 
-let init modular =
+let init modular library =
   check_inside_section (); check_inside_module ();
   set_keywords (descr ()).keywords;
   set_modular modular;
+  set_library library;
   reset ();
   if modular && lang () = Scheme then error_scheme ()
 
+let warns () =
+  warning_opaques (access_opaque ());
+  warning_axioms ()
+
 (* From a list of [reference], let's retrieve whether they correspond
    to modules or [global_reference]. Warn the user if both is possible. *)
 
@@ -503,7 +524,8 @@ let rec locate_ref = function
   | r::l ->
       let q = snd (qualid_of_reference r) in
       let mpo = try Some (Nametab.locate_module q) with Not_found -> None
-      and ro = try Some (Nametab.locate q) with Not_found -> None in
+      and ro = try Some (Smartlocate.global_with_alias r) with _ -> None
+      in
       match mpo, ro with
 	| None, None -> Nametab.error_global_not_found q
 	| None, Some r -> let refs,mps = locate_ref l in r::refs,mps
@@ -518,25 +540,41 @@ let rec locate_ref = function
     \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
 
 let full_extr f (refs,mps) =
-  init false;
+  init false false;
   List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps;
-  let struc = optimize_struct refs (mono_environment refs mps) in
-  warning_axioms ();
+  let struc = optimize_struct (refs,mps) (mono_environment refs mps) in
+  warns ();
   print_structure_to_file (mono_filename f) false struc;
   reset ()
 
 let full_extraction f lr = full_extr f (locate_ref lr)
 
+(*s Separate extraction is similar to recursive extraction, with the output
+   decomposed in many files, one per Coq .v file *)
+
+let separate_extraction lr =
+  init true false;
+  let refs,mps = locate_ref lr in
+  let struc = optimize_struct (refs,mps) (mono_environment refs mps) in
+  warns ();
+  let print = function
+    | (MPfile dir as mp, sel) as e ->
+	print_structure_to_file (module_filename mp) false [e]
+    | _ -> assert false
+  in
+  List.iter print struc;
+  reset ()
+
 (*s Simple extraction in the Coq toplevel. The vernacular command
     is \verb!Extraction! [qualid]. *)
 
 let simple_extraction r = match locate_ref [r] with
   | ([], [mp]) as p -> full_extr None p
   | [r],[] ->
-      init false;
-      let struc = optimize_struct [r] (mono_environment [r] []) in
+      init false false;
+      let struc = optimize_struct ([r],[]) (mono_environment [r] []) in
       let d = get_decl_in_structure r struc in
-      warning_axioms ();
+      warns ();
       if is_custom r then msgnl (str "(** User defined extraction *)");
       print_one_decl struc (modpath_of_r r) d;
       reset ()
@@ -547,12 +585,12 @@ let simple_extraction r = match locate_ref [r] with
   \verb!(Recursive) Extraction Library! [M]. *)
 
 let extraction_library is_rec m =
-  init true;
+  init true 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);
+  Visit.add_mp_all (MPfile dir_m);
   let env = Global.env () in
   let l = List.rev (environment_until (Some dir_m)) in
   let select l (mp,meb) =
@@ -561,8 +599,8 @@ let extraction_library is_rec m =
     else l
   in
   let struc = List.fold_left select [] l in
-  let struc = optimize_struct [] struc in
-  warning_axioms ();
+  let struc = optimize_struct ([],[]) struc in
+  warns ();
   let print = function
     | (MPfile dir as mp, sel) as e ->
 	let dry = not is_rec && dir <> dir_m in
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 145cd6b3..e587bf21 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s This module declares the extraction commands. *)
 
 open Names
@@ -15,9 +13,15 @@ open Libnames
 
 val simple_extraction : reference -> unit
 val full_extraction : string option -> reference list -> unit
+val separate_extraction : reference list -> unit
 val extraction_library : bool -> identifier -> unit
 
 (* For debug / external output via coqtop.byte + Drop : *)
 
 val mono_environment :
  global_reference list -> module_path list -> Miniml.ml_structure
+
+(* Used by the Relation Extraction plugin *)
+
+val print_one_decl :
+  Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 27f32a4a..219b3913 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.ml 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
 (*i*)
 open Util
 open Names
@@ -48,8 +46,6 @@ let sort_of env c =
     Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
   with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
 
-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:
@@ -197,6 +193,27 @@ let parse_ind_args si args relmax =
 	 | _ -> parse (i+1) (j+1) s)
   in parse 1 1 si
 
+let oib_equal o1 o2 =
+  id_ord o1.mind_typename o2.mind_typename = 0 &&
+  list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt &&
+  begin match o1.mind_arity, o2.mind_arity with
+  | Monomorphic {mind_user_arity=c1; mind_sort=s1},
+    Monomorphic {mind_user_arity=c2; mind_sort=s2} ->
+      eq_constr c1 c2 && s1 = s2
+  | ma1, ma2 -> ma1 = ma2 end &&
+  o1.mind_consnames = o2.mind_consnames
+
+let mib_equal m1 m2 =
+  array_equal oib_equal m1.mind_packets m1.mind_packets &&
+  m1.mind_record = m2.mind_record &&
+  m1.mind_finite = m2.mind_finite &&
+  m1.mind_ntypes = m2.mind_ntypes &&
+  list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps &&
+  m1.mind_nparams = m2.mind_nparams &&
+  m1.mind_nparams_rec = m2.mind_nparams_rec &&
+  list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt &&
+  m1.mind_constraints = m2.mind_constraints
+
 (*S Extraction of a type. *)
 
 (* [extract_type env db c args] is used to produce an ML type from the
@@ -215,7 +232,7 @@ let rec extract_type env db j c args =
 	extract_type env db j d (Array.to_list args' @ args)
     | Lambda (_,_,d) ->
 	(match args with
-	   | [] -> assert false (* otherwise the lambda would be reductible. *)
+	   | [] -> assert false (* A lambda cannot be a type. *)
 	   | a :: args -> extract_type env db j (subst1 a d) args)
     | Prod (n,t,d) ->
 	assert (args = []);
@@ -255,12 +272,13 @@ let rec extract_type env db j c args =
 	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
+	   | (Logic,_) -> assert false (* Cf. logical cases above *)
 	   | (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 ->
+		  | Undef _ | OpaqueDef _ -> mlt
+		  | Def _ when is_custom r -> mlt
+		  | Def 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 *)
@@ -269,10 +287,11 @@ let rec extract_type env db j c args =
 		      (* The shortest is [mlt], which use abbreviations *)
 		      (* If possible, we take [mlt], otherwise [mlt']. *)
 		      if expand env mlt = expand env mlt' then mlt else mlt')
-	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
+	   | (Info, Default) ->
+               (* Not an ML type, for example [(c:forall X, X->X) Type nat] *)
 	       (match cb.const_body with
-		  | None -> Tunknown (* Brutal approximation ... *)
-		  | Some lbody ->
+		  | Undef _  | OpaqueDef _ -> Tunknown (* Brutal approx ... *)
+		  | Def lbody ->
 		      (* We try to reduce. *)
 		      let newc = applist (Declarations.force lbody, args) in
 		      extract_type env db j newc []))
@@ -282,14 +301,6 @@ let rec extract_type env db j c args =
     | Case _ | Fix _ | CoFix _ -> Tunknown
     | _ -> assert false
 
-(* [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 []
-  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],
   and is completely applied: [List.length args = List.length s]. *)
@@ -337,13 +348,18 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
        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;
+    if not (mib_equal mib mib0) then raise Not_found;
     ml_ind
   with Not_found ->
-    (* First, if this inductive is aliased via a Module, *)
-    (* we process the original inductive. *)
-    let equiv = 
-      if (canonical_mind kn) = (user_mind kn) then
+    (* First, if this inductive is aliased via a Module,
+       we process the original inductive if possible.
+       When at toplevel of the monolithic case, we cannot do much
+       (cf Vector and bug #2570) *)
+    let equiv =
+      if lang () <> Ocaml ||
+	 (not (modular ()) && at_toplevel (mind_modpath kn)) ||
+	 kn_ord (canonical_mind kn) (user_mind kn) = 0
+      then
 	NoEquiv
       else
 	begin
@@ -370,8 +386,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	     ip_logical = (not b);
 	     ip_sign = s;
 	     ip_vars = v;
-	     ip_types = t;
-	     ip_optim_id_ok = None })
+	     ip_types = t })
 	mib.mind_packets
     in
 
@@ -412,7 +427,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	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))
+	if not (keep_singleton ()) &&
+	    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);
@@ -464,6 +480,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	     ind_equiv = equiv }
     in
     add_ind kn mib i;
+    add_inductive_kind kn i.ind_kind;
     i
 
 (*s [extract_type_cons] extracts the type of an inductive
@@ -496,8 +513,8 @@ and mlt_env env r = match r with
 	 let cb = Environ.lookup_constant kn env in
 	 let typ = Typeops.type_of_constant_type env cb.const_type in
 	 match cb.const_body with
-	   | None -> None
-	   | Some l_body ->
+	   | Undef _ | OpaqueDef _ -> None
+	   | Def l_body ->
 	       (match flag_of_type env typ with
 		  | Info,TypeScheme ->
 		      let body = Declarations.force l_body in
@@ -560,6 +577,8 @@ let rec extract_term env mle mlt c args =
     | LetIn (n, c1, t1, c2) ->
 	let id = id_of_name n in
 	let env' = push_rel (Name id, Some c1, t1) env in
+	(* We directly push the args inside the [LetIn].
+           TODO: the opt_let_app flag is supposed to prevent that *)
 	let args' = List.map (lift 1) args in
 	(try
 	  check_default env t1;
@@ -727,8 +746,8 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
 	| Tglob (_,l) -> List.map type_simpl l
 	| _ -> assert false
       in
-      let info = {c_kind = mi.ind_kind; c_typs = typeargs} in
-      put_magic_if magic1 (MLcons (info, ConstructRef cp, mla))
+      let typ = Tglob(IndRef ip, typeargs) in
+      put_magic_if magic1 (MLcons (typ, ConstructRef cp, mla))
   in
   (* Different situations depending of the number of arguments: *)
   if la < params_nb then
@@ -792,22 +811,22 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	(* We suppress dummy arguments according to signature. *)
 	let ids,e = case_expunge s e in
 	let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
-	(r, List.rev ids, e')
+	(List.rev ids, Pusual r, e')
       in
       if mi.ind_kind = Singleton then
 	begin
 	  (* Informative singleton case: *)
 	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
 	  assert (br_size = 1);
-	  let (_,ids,e') = extract_branch 0 in
+	  let (ids,_,e') = extract_branch 0 in
 	  assert (List.length ids = 1);
 	  MLletin (tmp_id (List.hd ids),a,e')
 	end
       else
 	(* Standard case: we apply [extract_branch]. *)
 	let typs = List.map type_simpl (Array.to_list metas) in
-	let info = { m_kind = mi.ind_kind; m_typs = typs; m_same = BranchNone }
-	in MLcase (info, a, Array.init br_size extract_branch)
+	let typ = Tglob (IndRef ip,typs) in
+	MLcase (typ, a, Array.init br_size extract_branch)
 
 (*s Extraction of a (co)-fixpoint. *)
 
@@ -869,7 +888,7 @@ let extract_std_constant env kn body typ =
     and m = nb_lam body in
     if n <= m then decompose_lam_n n body
     else
-      let s,s' = list_split_at m s in
+      let s,s' = list_chop m s in
       if List.for_all ((=) Keep) s' &&
 	(lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
       then decompose_lam_n m body
@@ -878,7 +897,7 @@ let extract_std_constant env kn body typ =
   (* Should we do one eta-expansion to avoid non-generalizable '_a ? *)
   let rels, c =
     let n = List.length rels in
-    let s,s' = list_split_at n s in
+    let s,s' = list_chop n s in
     let k = sign_kind s in
     let empty_s = (k = EmptySig || k = SafeLogicalSig) in
     if lang () = Ocaml && empty_s && not (gentypvar_ok c)
@@ -888,7 +907,7 @@ let extract_std_constant env kn 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 l,l' = list_chop n l in
   let t' = type_recomp (l',t') in
   (* The initial ML environment. *)
   let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
@@ -925,34 +944,45 @@ let extract_fixpoint env vkn (fi,ti,ci) =
 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. *)
-        (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_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) ->
-	       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
-	       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)
-	       in Dtype (r, vl, t))
+  let warn_info () = if not (is_custom r) then add_info_axiom r in
+  let warn_log () = if not (constant_has_body cb) then add_log_axiom r
+  in
+  let mk_typ_ax () =
+    let n = type_scheme_nb_args env typ in
+    let ids = iterate (fun l -> anonymous_name::l) n [] in
+    Dtype (r, ids, Taxiom)
+  in
+  let mk_typ c =
+    let s,vl = type_sign_vl env typ in
+    let db = db_from_sign s in
+    let t = extract_type_scheme env db c (List.length s)
+    in Dtype (r, vl, t)
+  in
+  let mk_ax () =
+    let t = snd (record_constant_type env kn (Some typ)) in
+    Dterm (r, MLaxiom, type_expunge env t)
+  in
+  let mk_def c =
+    let e,t = extract_std_constant env kn c typ in
+    Dterm (r,e,t)
+  in
+  match flag_of_type env typ with
+    | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype)
+    | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother)
+    | (Info,TypeScheme) ->
+        (match cb.const_body with
+	  | Undef _ -> warn_info (); mk_typ_ax ()
+	  | Def c -> mk_typ (force c)
+	  | OpaqueDef c ->
+	    add_opaque r;
+	    if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ())
+    | (Info,Default) ->
+        (match cb.const_body with
+	  | Undef _ -> warn_info (); mk_ax ()
+	  | Def c -> mk_def (force c)
+	  | OpaqueDef c ->
+	    add_opaque r;
+	    if access_opaque () then mk_def (force_opaque c) else mk_ax ())
 
 let extract_constant_spec env kn cb =
   let r = ConstRef kn in
@@ -963,8 +993,8 @@ let extract_constant_spec env kn cb =
     | (Info, TypeScheme) ->
 	let s,vl = type_sign_vl env typ in
 	(match cb.const_body with
-	  | None -> Stype (r, vl, None)
-	  | Some body ->
+	  | Undef _ | OpaqueDef _ -> Stype (r, vl, None)
+	  | Def body ->
 	      let db = db_from_sign s in
 	      let t = extract_type_scheme env db (force body) (List.length s)
 	      in Stype (r, vl, Some t))
@@ -977,9 +1007,13 @@ let extract_with_type env cb =
   match flag_of_type env typ with
     | (Info, TypeScheme) ->
 	let s,vl = type_sign_vl env typ in
-	let body = Option.get cb.const_body in
 	let db = db_from_sign s in
-	let t = extract_type_scheme env db (force body) (List.length s) in
+	let c = match cb.const_body with
+	  | Def body -> force body
+	  (* A "with Definition ..." is necessarily transparent *)
+	  | Undef _ | OpaqueDef _ -> assert false
+	in
+	let t = extract_type_scheme env db c (List.length s) in
 	Some (vl, t)
     | _ -> None
 
@@ -995,7 +1029,7 @@ let extract_inductive env kn =
 	  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 filter (1+ind.ind_nparams) l
   in
   let packets =
     Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types })
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index 8a2125fe..48f05acb 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Extraction from Coq terms to Miniml. *)
 
 open Names
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index ebd4de0d..11a2d0e0 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -63,6 +63,12 @@ VERNAC COMMAND EXTEND Extraction
   -> [ full_extraction (Some f) l ]
 END
 
+VERNAC COMMAND EXTEND SeparateExtraction
+(* Same, with content splitted in several files *)
+| [ "Separate" "Extraction" ne_global_list(l) ]
+  -> [ separate_extraction l ]
+END
+
 (* Modular extraction (one Coq library = one ML module) *)
 VERNAC COMMAND EXTEND ExtractionLibrary
 | [ "Extraction" "Library" ident(m) ]
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index aeacef93..96731ed2 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Production of Haskell syntax. *)
 
 open Pp
@@ -47,15 +45,15 @@ let preamble mod_name used_modules usf =
   (if used_modules = [] then mt () else fnl ()) ++
   (if not usf.magic then mt ()
    else str "\
-unsafeCoerce :: a -> b
-#ifdef __GLASGOW_HASKELL__
-import qualified GHC.Base
-unsafeCoerce = GHC.Base.unsafeCoerce#
-#else
--- HUGS
-import qualified IOExts
-unsafeCoerce = IOExts.unsafeCoerce
-#endif" ++ fnl2 ())
+\nunsafeCoerce :: a -> b\
+\n#ifdef __GLASGOW_HASKELL__\
+\nimport qualified GHC.Base\
+\nunsafeCoerce = GHC.Base.unsafeCoerce#\
+\n#else\
+\n-- HUGS\
+\nimport qualified IOExts\
+\nunsafeCoerce = IOExts.unsafeCoerce\
+\n#endif" ++ fnl2 ())
   ++
   (if not usf.mldummy then mt ()
    else str "__ :: any" ++ fnl () ++
@@ -78,17 +76,17 @@ let pp_global k r =
 
 let kn_sig =
   let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in
-  make_kn specif empty_dirpath (mk_label "sig")
+  make_mind specif empty_dirpath (mk_label "sig")
 
 let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ -> assert false
     | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i))
     | Tglob (r,[]) -> pp_global Type r
-    | Tglob (r,l) ->
-	if r = IndRef (mind_of_kn kn_sig,0) then
+    | Tglob (IndRef(kn,0),l)
+	when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" ->
 	  pp_type true vl (List.hd l)
-	else
+    | Tglob (r,l) ->
 	  pp_par par
 	    (pp_global Type r ++ spc () ++
 	     prlist_with_sep spc (pp_type true vl) l)
@@ -113,8 +111,8 @@ let expr_needs_par = function
 
 
 let rec pp_expr par env args =
-  let par' = args <> [] || par
-  and apply st = pp_apply st par args in
+  let apply st = pp_apply st par args
+  and apply2 st = pp_apply2 st par args in
   function
     | MLrel n ->
 	let id = get_db_name n env in apply (pr_id id)
@@ -125,7 +123,7 @@ let rec pp_expr par env args =
       	let fl,a' = collect_lams a 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)
+	apply2 st
     | MLletin (id,a1,a2) ->
 	let i,env' = push_vars [id_of_mlid id] env in
 	let pp_id = pr_id (List.hd i)
@@ -135,37 +133,42 @@ let rec pp_expr par env args =
 	  str "let {" ++ cut () ++
 	  hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}")
 	in
-	apply
-	  (pp_par par'
-	     (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++
-		    spc () ++ hov 0 pp_a2)))
+	apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++
+		       spc () ++ hov 0 pp_a2))
     | MLglob r ->
 	apply (pp_global Term r)
-    | MLcons _ as c when is_native_char c -> assert (args=[]); pp_native_char c
-    | MLcons (_,r,[]) ->
-	assert (args=[]); pp_global Cons r
-    | MLcons (_,r,[a]) ->
-	assert (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 () ++
-		    prlist_with_sep spc (pp_expr true env []) args')
+    | MLcons (_,r,a) as c ->
+        assert (args=[]);
+        begin match a with
+	  | _ when is_native_char c -> pp_native_char c
+	  | [] -> pp_global Cons r
+	  | [a] ->
+	    pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a)
+	  | _ ->
+	    pp_par par (pp_global Cons r ++ spc () ++
+			prlist_with_sep spc (pp_expr true env []) a)
+	end
+    | MLtuple l ->
+        assert (args=[]);
+        pp_boxed_tuple (pp_expr true env []) l
     | MLcase (_,t, pv) when is_custom_match pv ->
-	let mkfun (_,ids,e) =
+        if not (is_regular_match pv) then
+	  error "Cannot mix yet user-given match and general patterns.";
+	let mkfun (ids,_,e) =
 	  if ids <> [] then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
-	apply
-	  (pp_par par'
-	     (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 (info,t, pv) ->
-      	apply (pp_par par'
-		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++
-		       fnl () ++ pp_pat env info pv)))
+	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
+	let inner =
+	  str (find_custom_match pv) ++ fnl () ++
+	  prvect pp_branch pv ++
+	  pp_expr true env [] t
+	in
+	apply2 (hov 2 inner)
+    | MLcase (typ,t,pv) ->
+        apply2
+	  (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++
+		fnl () ++ pp_pat env 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
@@ -178,44 +181,31 @@ let rec pp_expr par env args =
 	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 info pv =
-  let pp_one_pat (name,ids,t) =
-    let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
-    let par = expr_needs_par t in
-    hov 2 (str " " ++ pp_global Cons name ++
-	   (match ids with
-	      | [] -> mt ()
-	      | _  -> (str " " ++
-		       prlist_with_sep spc pr_id (List.rev ids))) ++
-	   str " ->" ++ spc () ++ pp_expr par env' [] t)
-  in
-  let factor_br, factor_set = try match info.m_same with
-    | BranchFun ints ->
-        let i = Intset.choose ints in
-	branch_as_fun info.m_typs pv.(i), ints
-    | BranchCst ints ->
-        let i = Intset.choose ints in
-        ast_pop (branch_as_cst pv.(i)), ints
-    | BranchNone -> MLdummy, Intset.empty
-  with _ -> MLdummy, Intset.empty
-  in
-  let last = Array.length pv - 1 in
+and pp_cons_pat par r ppl =
+  pp_par par
+    (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl)
+
+and pp_gen_pat par ids env = function
+  | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l)
+  | Pusual r -> pp_cons_pat par r (List.map pr_id ids)
+  | Ptuple l -> pp_boxed_tuple (pp_gen_pat false ids env) l
+  | Pwild -> str "_"
+  | Prel n -> pr_id (get_db_name n env)
+
+and pp_one_pat env (ids,p,t) =
+  let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in
+  hov 2 (str " " ++
+	 pp_gen_pat false (List.rev ids') env' p ++
+	 str " ->" ++ spc () ++
+	 pp_expr (expr_needs_par t) env' [] t)
+
+and pp_pat env pv =
   prvecti
-    (fun i x -> if Intset.mem i factor_set then mt () else
-       (pp_one_pat pv.(i) ++
-       if i = last && Intset.is_empty factor_set then str "}" else
-	 (str ";" ++ fnl ()))) pv
-  ++
-  if Intset.is_empty factor_set then mt () else
-  let par = expr_needs_par factor_br in
-  match info.m_same with
-    | BranchFun _ ->
-        let ids, env' = push_vars [anonymous_name] env in
-        hov 2 (str " " ++ pr_id (List.hd ids) ++ str " ->" ++ spc () ++
-	       pp_expr par env' [] factor_br ++ str "}")
-    | BranchCst _ ->
-        hov 2 (str " _ ->" ++ spc () ++ pp_expr par env [] factor_br ++ str "}")
-    | BranchNone -> mt ()
+    (fun i x ->
+       pp_one_pat env pv.(i) ++
+       if i = Array.length pv - 1 then str "}" else
+	 (str ";" ++ fnl ()))
+    pv
 
 (*s names of the functions ([ids]) are already pushed in [env],
     and passed here just for convenience. *)
@@ -293,12 +283,10 @@ let rec pp_ind first kn i 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_kind = 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)
+      pp_singleton kn i.ind_packets.(0) ++ fnl ()
+  | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
   | Dtype (r, l, t) ->
       if is_inline_custom r then mt ()
       else
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
index eb774db7..0f8949e3 100644
--- a/plugins/extraction/haskell.mli
+++ b/plugins/extraction/haskell.mli
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 val haskell_descr : Miniml.language_descr
 
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index aaf2d0c3..5a19cc3f 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: miniml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Target language for extraction: a core ML called MiniML. *)
 
 open Pp
@@ -73,8 +71,7 @@ type ml_ind_packet = {
   ip_logical : bool;
   ip_sign : signature;
   ip_vars : identifier list;
-  ip_types : (ml_type list) array;
-  mutable ip_optim_id_ok : bool option
+  ip_types : (ml_type list) array
 }
 
 (* [ip_nparams] contains the number of parameters. *)
@@ -99,28 +96,17 @@ type ml_ident =
   | Tmp of identifier
 
 (** We now store some typing information on constructors
-    and cases to avoid type-unsafe optimisations.
-    For cases, we also store the set of branches to merge
-    in a common pattern, either "_ -> c" or "x -> f x"
+    and cases to avoid type-unsafe optimisations. This will be
+    either the type of the applied constructor or the type
+    of the head of the match.
 *)
 
-type constructor_info = {
-  c_kind : inductive_kind;
-  c_typs : ml_type list;
-}
-
-type branch_same =
-  | BranchNone
-  | BranchFun of Intset.t
-  | BranchCst of Intset.t
+(** Nota : the constructor [MLtuple] and the extension of [MLcase]
+    to general patterns have been proposed by P.N. Tollitte for
+    his Relation Extraction plugin. [MLtuple] is currently not
+    used by the main extraction, as well as deep patterns. *)
 
-type match_info = {
-  m_kind : inductive_kind;
-  m_typs : ml_type list;
-  m_same : branch_same
-}
-
-type ml_branch = global_reference * ml_ident list * ml_ast
+type ml_branch = ml_ident list * ml_pattern * ml_ast
 
 and ml_ast =
   | MLrel    of int
@@ -128,24 +114,32 @@ and ml_ast =
   | MLlam    of ml_ident * ml_ast
   | MLletin  of ml_ident * ml_ast * ml_ast
   | MLglob   of global_reference
-  | MLcons   of constructor_info * global_reference * ml_ast list
-  | MLcase   of match_info * ml_ast * ml_branch array
+  | MLcons   of ml_type * global_reference * ml_ast list
+  | MLtuple  of ml_ast list
+  | MLcase   of ml_type * ml_ast * ml_branch array
   | MLfix    of int * identifier array * ml_ast array
   | MLexn    of string
   | MLdummy
   | MLaxiom
   | MLmagic  of ml_ast
 
+and ml_pattern =
+  | Pcons   of global_reference * ml_pattern list
+  | Ptuple  of ml_pattern list
+  | Prel    of int (** Cf. the idents in the branch. [Prel 1] is the last one. *)
+  | Pwild
+  | Pusual  of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
+
 (*s ML declarations. *)
 
 type ml_decl =
-  | Dind  of kernel_name * ml_ind
+  | Dind  of mutual_inductive * 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 =
-  | Sind  of kernel_name * ml_ind
+  | Sind  of mutual_inductive * ml_ind
   | Stype of global_reference * identifier list * ml_type option
   | Sval  of global_reference * ml_type
 
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 3c7ee0f2..c244e046 100644
--- a/plugins/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.ml 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
 (*i*)
 open Pp
 open Util
@@ -56,18 +54,6 @@ 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 rec subst t = match t with
-    | Tvar j when i = j -> t0
-    | 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
-  in subst t
-
 (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
 
 let type_subst_list l t =
@@ -378,54 +364,61 @@ let ast_iter_rel f =
     | MLlam (_,a) -> iter (n+1) a
     | MLletin (_,a,b) -> iter n a; iter (n+1) b
     | MLcase (_,a,v) ->
-	iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
+	iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v
     | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
     | MLapp (a,l) -> iter n a; List.iter (iter n) l
-    | MLcons (_,_,l) ->  List.iter (iter n) l
+    | MLcons (_,_,l) | MLtuple l ->  List.iter (iter n) l
     | MLmagic a -> iter n a
     | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
   in iter 0
 
 (*s Map over asts. *)
 
-let ast_map_case f (c,ids,a) = (c,ids,f a)
+let ast_map_branch f (c,ids,a) = (c,ids,f a)
+
+(* Warning: in [ast_map] we assume that [f] does not change the type
+   of [MLcons] and of [MLcase] heads *)
 
 let ast_map f = function
   | MLlam (i,a) -> MLlam (i, f a)
   | MLletin (i,a,b) -> MLletin (i, f a, f b)
-  | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v)
+  | MLcase (typ,a,v) -> MLcase (typ,f a, Array.map (ast_map_branch f) v)
   | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
   | MLapp (a,l) -> MLapp (f a, List.map f l)
-  | MLcons (i,c,l) -> MLcons (i,c, List.map f l)
+  | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l)
+  | MLtuple l -> MLtuple (List.map f l)
   | MLmagic a -> MLmagic (f a)
   | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
 
 (*s Map over asts, with binding depth as parameter. *)
 
-let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
+let ast_map_lift_branch f n (ids,p,a) = (ids,p, f (n+(List.length ids)) a)
+
+(* Same warning as for [ast_map]... *)
 
 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)
+  | MLcase (typ,a,v) -> MLcase (typ,f n a,Array.map (ast_map_lift_branch f n) 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)
+  | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l)
+  | MLtuple l -> MLtuple (List.map (f n) l)
   | MLmagic a -> MLmagic (f n a)
   | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
 
 (*s Iter over asts. *)
 
-let ast_iter_case f (c,ids,a) = f a
+let ast_iter_branch f (c,ids,a) = f a
 
 let ast_iter f = function
   | MLlam (i,a) -> f a
   | MLletin (i,a,b) -> f a; f b
-  | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v
+  | MLcase (_,a,v) -> f a; Array.iter (ast_iter_branch f) v
   | MLfix (i,ids,v) -> Array.iter f v
   | MLapp (a,l) -> f a; List.iter f l
-  | MLcons (_,c,l) -> List.iter f l
+  | MLcons (_,_,l) | MLtuple l -> List.iter f l
   | MLmagic a -> f a
   | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom  -> ()
 
@@ -446,15 +439,6 @@ let ast_occurs_itvl k k' t =
     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] (resp. [Rel 1]) in [t]. *)
-
-let nb_occur_k k t =
-  let cpt = ref 0 in
-  ast_iter_rel (fun i -> if i = k then incr cpt) t;
-  !cpt
-
-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. *)
 
@@ -464,13 +448,13 @@ let nb_occur_match =
     | MLcase(_,a,v) ->
         (nb k a) +
 	Array.fold_left
-	  (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
+	  (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
       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) | MLtuple 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
@@ -530,6 +514,39 @@ let gen_subst v d t =
     | a -> ast_map_lift subst n a
   in subst 0 t
 
+(*S Operations concerning match patterns *)
+
+let is_basic_pattern = function
+  | Prel _ | Pwild -> true
+  | Pusual _ | Pcons _ | Ptuple _ -> false
+
+let has_deep_pattern br =
+  let deep = function
+    | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l)
+    | Pusual _ | Prel _ | Pwild -> false
+  in
+  array_exists (function (_,pat,_) -> deep pat) br
+
+let is_regular_match br =
+  if Array.length br = 0 then false (* empty match becomes MLexn *)
+  else
+    try
+      let get_r (ids,pat,c) =
+	match pat with
+	  | Pusual r -> r
+	  | Pcons (r,l) ->
+	    if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l))
+	    then raise Impossible;
+	    r
+	  | _ -> raise Impossible
+      in
+      let ind = match get_r br.(0) with
+	| ConstructRef (ind,_) -> ind
+	| _ -> raise Impossible
+      in
+      array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br
+    with Impossible -> false
+
 (*S Operations concerning lambdas. *)
 
 (*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
@@ -577,7 +594,6 @@ let rec many_lams id a = function
   | 0 -> a
   | n -> many_lams id (MLlam (id,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
 
@@ -679,26 +695,31 @@ let rec ast_glob_subst s t = match t with
    expansion of type definitions.
 *)
 
-(*s [branch_as_function b typs (r,l,c)] tries to see branch [c]
+(*s [branch_as_function b typ (l,p,c)] tries to see branch [c]
   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 branch_as_fun typs (r,l,c) =
+let branch_as_fun typ (l,p,c) =
   let nargs = List.length l in
+  let cons = match p with
+    | Pusual r -> MLcons (typ, r, eta_args nargs)
+    | Pcons (r,pl) ->
+      let pat2rel = function Prel i -> MLrel i | _ -> raise Impossible in
+      MLcons (typ, r, List.map pat2rel pl)
+    | _ -> raise Impossible
+  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(i,r',args) when
-	r=r' && (test_eta_args_lift n nargs args) && typs = i.c_typs ->
-	MLrel (n+1)
+    | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1)
     | a -> ast_map_lift genrec n a
   in genrec 0 c
 
-(*s [branch_as_cst (r,l,c)] tries to see branch [c] as a constant
+(*s [branch_as_cst (l,p,c)] tries to see branch [c] as a constant
    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 [branch_as_fun]).
@@ -706,7 +727,7 @@ let branch_as_fun typs (r,l,c) =
    empty, i.e. when [r] is a constant constructor
 *)
 
-let branch_as_cst (_,l,c) =
+let branch_as_cst (l,_,c) =
   let n = List.length l in
   if ast_occurs_itvl 1 n c then raise Impossible;
   ast_lift (1-n) c
@@ -745,20 +766,27 @@ let census_add, census_max, census_clean =
    constant.
 *)
 
-let factor_branches o typs br =
-  census_clean ();
-  for i = 0 to Array.length br - 1 do
-    if o.opt_case_idr then
-      (try census_add (branch_as_fun typs br.(i)) i with Impossible -> ());
-    if o.opt_case_cst then
-      (try census_add (branch_as_cst br.(i)) i with Impossible -> ());
-  done;
-  let br_factor, br_set = census_max MLdummy in
-  census_clean ();
-  let n = Intset.cardinal br_set in
-  if n = 0 then None
-  else if Array.length br >= 2 && n < 2 then None
-  else Some (br_factor, br_set)
+let is_opt_pat (_,p,_) = match p with
+  | Prel _ | Pwild -> true
+  | _ -> false
+
+let factor_branches o typ br =
+  if array_exists is_opt_pat br then None (* already optimized *)
+  else begin
+    census_clean ();
+    for i = 0 to Array.length br - 1 do
+      if o.opt_case_idr then
+	(try census_add (branch_as_fun typ br.(i)) i with Impossible -> ());
+      if o.opt_case_cst then
+	(try census_add (branch_as_cst br.(i)) i with Impossible -> ());
+    done;
+    let br_factor, br_set = census_max MLdummy in
+    census_clean ();
+    let n = Intset.cardinal br_set in
+    if n = 0 then None
+    else if Array.length br >= 2 && n < 2 then None
+    else Some (br_factor, br_set)
+  end
 
 (*s If all branches are functions, try to permut the case and the functions. *)
 
@@ -781,14 +809,14 @@ let rec permut_case_fun br acc =
     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 (l,p,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)
+	br.(i) <- (l,p,remove_n_lams local_nb t)
       else begin
 	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)
+	br.(i) <- (l,p,permut_rels !nb (List.length l) t)
       end
     done;
     (!ids,br)
@@ -796,32 +824,43 @@ let rec permut_case_fun br acc =
 
 (*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
-   transformed into beta-redexes. *)
-
-let rec is_iota_gen = function
-  | MLcons _ -> true
-  | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
-  | _ -> false
-
-let constructor_index = function
-  | ConstructRef (_,j) -> pred j
-  | _ -> assert false
-
-let iota_gen br =
+(* Definition of a generalized iota-redex: it's a [MLcase(e,br)]
+   where the head [e] is a [MLcons] or made of [MLcase]'s with
+   [MLcons] as leaf branches.
+   A generalized iota-redex is transformed into beta-redexes. *)
+
+(* In [iota_red], we try to simplify a [MLcase(_,MLcons(typ,r,a),br)].
+   Argument [i] is the branch we consider, we should lift what
+   comes from [br] by [lift] *)
+
+let rec iota_red i lift br ((typ,r,a) as cons) =
+  if i >= Array.length br then raise Impossible;
+  let (ids,p,c) = br.(i) in
+  match p with
+    | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons
+    | Pusual r' ->
+      let c = named_lams (List.rev ids) c in
+      let c = ast_lift lift c
+      in MLapp (c,a)
+    | Prel 1 when List.length ids = 1 ->
+      let c = MLlam (List.hd ids, c) in
+      let c = ast_lift lift c
+      in MLapp(c,[MLcons(typ,r,a)])
+    | Pwild when ids = [] -> ast_lift lift c
+    | _ -> raise Impossible (* TODO: handle some more cases *)
+
+(* [iota_gen] is an extension of [iota_red] where we allow to
+   traverse matches in the head of the first match *)
+
+let iota_gen br hd =
   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
-	MLapp (c,a)
-    | MLcase(i,e,br') ->
+    | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a)
+    | MLcase(typ,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
+	  Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br'
+	in MLcase(typ,e,new_br)
+    | _ -> raise Impossible
+  in iota 0 hd
 
 let is_atomic = function
   | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
@@ -853,9 +892,9 @@ let expand_linear_let o id e =
 let rec simpl o = function
   | 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)
+  | MLcase (typ,e,br) ->
+      let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in
+      simpl_case o typ br (simpl o e)
   | MLletin(Dummy,_,e) -> simpl o (ast_pop e)
   | MLletin(id,c,e) ->
       let e = simpl o e in
@@ -891,40 +930,50 @@ and simpl_app o a = function
   | 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 (typ,e,br) when o.opt_case_app ->
       (* Application of a case: we push arguments inside *)
       let br' =
 	Array.map
-      	  (fun (n,l,t) ->
+	  (fun (l,p,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'))
+	     (l, p, simpl o (MLapp (t,a')))) br
+      in simpl o (MLcase (typ,e,br'))
   | (MLdummy | MLexn _) as e -> e
 	(* We just discard arguments in those cases. *)
   | f -> MLapp (f,a)
 
 (* 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 *)
+and simpl_case o typ br e =
+  try
+    (* Generalized iota-redex *)
+    if not o.opt_case_iot then raise Impossible;
     simpl o (iota_gen br e)
-  else
+  with Impossible ->
     (* 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)))
+      simpl o (named_lams ids (MLcase (typ, ast_lift n e, br)))
     else
       (* Can we merge several branches as the same constant or function ? *)
-      match factor_branches o i.m_typs br with
+      if lang() = Scheme || is_custom_match br
+      then MLcase (typ, e, br)
+      else match factor_branches o typ br with
 	| Some (f,ints) when Intset.cardinal ints = Array.length br ->
-	    (* If all branches have been factorized, we remove the match *)
-	    simpl o (MLletin (Tmp anonymous_name, e, f))
+	  (* If all branches have been factorized, we remove the match *)
+	  simpl o (MLletin (Tmp anonymous_name, e, f))
 	| Some (f,ints) ->
-	  let same = if ast_occurs 1 f then BranchFun ints else BranchCst ints
-	  in MLcase ({i with m_same=same}, e, br)
-	| None -> MLcase (i, e, br)
+	  let last_br =
+	    if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f)
+	    else ([], Pwild, ast_pop f)
+	  in
+	  let brl = Array.to_list br in
+	  let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in
+	  let brl_opt = brl_opt @ [last_br] in
+	  MLcase (typ, e, Array.of_list brl_opt)
+	| None -> MLcase (typ, e, br)
 
 (*S Local prop elimination. *)
 (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
@@ -1149,28 +1198,24 @@ let optimize_fix a =
 
 (* Utility functions used in the decision of inlining. *)
 
+let ml_size_branch size pv = Array.fold_left (fun a (_,_,t) -> a + size t) 0 pv
+
 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) ->
-      1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
+  | MLcons(_,_,l) | MLtuple l -> ml_size_list l
+  | MLcase(_,t,pv) -> 1 + ml_size t + ml_size_branch ml_size pv
   | MLfix(_,_,f) -> ml_size_array f
   | MLletin (_,_,t) -> ml_size t
   | MLmagic t -> ml_size t
-  | _ -> 0
+  | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0
 
 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l
 
-and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l
+and ml_size_array a = Array.fold_left (fun a t -> a + ml_size t) 0 a
 
 let is_fix = function MLfix _ -> true | _ -> false
 
-let rec is_constr = function
-  | MLcons _   -> true
-  | MLlam(_,t) -> is_constr t
-  | _          -> false
-
 (*s Strictness *)
 
 (* A variable is strict if the evaluation of the whole term implies
@@ -1219,7 +1264,7 @@ let rec non_stricts add cand = function
       (* so we make an union (in fact a merge). *)
       let cand = non_stricts false cand t in
       Array.fold_left
-	(fun c (_,i,t)->
+	(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
@@ -1265,12 +1310,14 @@ 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 has_body =
+      try constant_has_body (Global.lookup_constant c)
+      with _ -> false
+    in
+    has_body &&
+      (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
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index 54a1baaa..029e8cf4 100644
--- a/plugins/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.mli 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
 open Util
 open Names
 open Term
@@ -20,7 +18,6 @@ open Table
 val reset_meta_count : unit -> unit
 val new_meta : 'a -> ml_type
 
-val type_subst : int -> ml_type -> ml_type -> ml_type
 val type_subst_list : ml_type list -> ml_type -> ml_type
 val type_subst_vect : ml_type array -> ml_type -> ml_type
 
@@ -118,9 +115,11 @@ val normalize : ml_ast -> ml_ast
 val optimize_fix : ml_ast -> ml_ast
 val inline : global_reference -> ml_ast -> bool
 
+val is_basic_pattern : ml_pattern -> bool
+val has_deep_pattern : ml_branch array -> bool
+val is_regular_match : ml_branch array -> bool
+
 exception Impossible
-val branch_as_fun : ml_type list -> ml_branch -> ml_ast
-val branch_as_cst : ml_branch -> ml_ast
 
 (* Classification of signatures *)
 
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index ffa38def..9e8dd828 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Declarations
 open Environ
@@ -28,7 +26,7 @@ let rec msid_of_mt = function
 (*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 se_iter do_decl do_spec =
   let rec mt_iter = function
     | MTident _ -> ()
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
@@ -58,7 +56,10 @@ let struct_iter do_decl do_spec s =
     | MEapply (me,me') -> me_iter me; me_iter me'
     | MEstruct (msid, sel) -> List.iter se_iter sel
   in
-  List.iter (function (_,sel) -> List.iter se_iter sel) s
+  se_iter
+
+let struct_iter do_decl do_spec s =
+  List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec) sel) s
 
 (*s Apply some fonctions upon all references in [ml_type], [ml_ast],
   [ml_decl], [ml_spec] and [ml_structure]. *)
@@ -76,18 +77,26 @@ let type_iter_references do_type t =
     | _ -> ()
   in iter t
 
+let patt_iter_references do_cons p =
+  let rec iter = function
+    | Pcons (r,l) -> do_cons r; List.iter iter l
+    | Pusual r -> do_cons r
+    | Ptuple l -> List.iter iter l
+    | Prel _ | Pwild -> ()
+  in iter p
+
 let ast_iter_references do_term do_cons do_type a =
   let rec iter a =
     ast_iter iter a;
     match a with
       | MLglob r -> do_term r
-      | MLcons (i,r,_) ->
-	  if lang () = Ocaml then record_iter_references do_term i.c_kind;
-	  do_cons r
-      | MLcase (i,_,v) ->
-	  if lang () = Ocaml then record_iter_references do_term i.m_kind;
-	  Array.iter (fun (r,_,_) -> do_cons r) v
-      | _ -> ()
+      | MLcons (_,r,_) -> do_cons r
+      | MLcase (ty,_,v) ->
+	type_iter_references do_type ty;
+	Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v
+
+      | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _
+      | MLdummy | MLaxiom | MLmagic _ -> ()
   in iter a
 
 let ind_iter_references do_term do_cons do_type kn ind =
@@ -108,15 +117,14 @@ 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 
-	(mind_of_kn kn) ind
+    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type 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) ->
 	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 (mind_of_kn kn) ind
+  | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type 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
 
@@ -236,7 +244,7 @@ let rec optim_se top to_appear s = function
       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)
+      if top && i && not (library ()) && not (List.mem r to_appear)
       then optim_se top to_appear s lse
       else
 	let d = match optimize_fix a with
@@ -254,7 +262,7 @@ let rec optim_se top to_appear s = function
 	then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s
 	else all := false
       done;
-      if !all && top && not (modular ())
+      if !all && top && not (library ())
 	&& (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)
@@ -271,7 +279,8 @@ and optim_me to_appear s = function
   | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me)
 
 (* After these optimisations, some dependencies may not be needed anymore.
-   For monolithic extraction, we recompute a minimal set of dependencies. *)
+   For non-library extraction, we recompute a minimal set of dependencies
+   for first-level objects *)
 
 exception NoDepCheck
 
@@ -281,15 +290,19 @@ let base_r = function
   | ConstructRef ((kn,_),_) -> IndRef (kn,0)
   | _ -> assert false
 
-let reset_needed, add_needed, found_needed, is_needed =
-  let needed = ref Refset'.empty in
-  ((fun l -> needed := Refset'.empty),
+let reset_needed, add_needed, add_needed_mp, found_needed, is_needed =
+  let needed = ref Refset'.empty
+  and needed_mps = ref MPset.empty in
+  ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty),
    (fun r -> needed := Refset'.add (base_r r) !needed),
+   (fun mp -> needed_mps := MPset.add mp !needed_mps),
    (fun r -> needed := Refset'.remove (base_r r) !needed),
-   (fun r -> Refset'.mem (base_r r) !needed))
+   (fun r ->
+     let r = base_r r in
+     Refset'.mem r !needed || MPset.mem (modpath_of_r r) !needed_mps))
 
 let declared_refs = function
-  | Dind (kn,_) -> [IndRef (mind_of_kn kn,0)]
+  | Dind (kn,_) -> [IndRef (kn,0)]
   | Dtype (r,_,_) -> [r]
   | Dterm (r,_,_) -> [r]
   | Dfix (rv,_,_) -> Array.to_list rv
@@ -300,7 +313,7 @@ let declared_refs = function
 let compute_deps_decl = function
   | Dind (kn,ind) ->
       (* Todo Later : avoid dependencies when Extract Inductive *)
-      ind_iter_references add_needed add_needed add_needed (mind_of_kn kn) ind
+      ind_iter_references add_needed add_needed add_needed kn ind
   | Dtype (r,ids,t) ->
       if not (is_custom r) then type_iter_references add_needed t
   | Dterm (r,u,t) ->
@@ -310,6 +323,15 @@ let compute_deps_decl = function
   | Dfix _ as d ->
       decl_iter_references add_needed add_needed add_needed d
 
+let compute_deps_spec = function
+  | Sind (kn,ind) ->
+      (* Todo Later : avoid dependencies when Extract Inductive *)
+      ind_iter_references add_needed add_needed add_needed kn ind
+  | Stype (r,ids,t) ->
+      if not (is_custom r) then Option.iter (type_iter_references add_needed) t
+  | Sval (r,t) ->
+      type_iter_references add_needed t
+
 let rec depcheck_se = function
   | [] -> []
   | ((l,SEdecl d) as t) :: se ->
@@ -317,7 +339,9 @@ let rec depcheck_se = function
     let refs = declared_refs d in
     let refs' = List.filter is_needed refs in
     if refs' = [] then
-      (List.iter remove_info_axiom refs; se')
+      (List.iter remove_info_axiom refs;
+       List.iter remove_opaque refs;
+       se')
     else begin
       List.iter found_needed refs';
       (* Hack to avoid extracting unused part of a Dfix *)
@@ -327,7 +351,10 @@ let rec depcheck_se = function
 	  ((l,SEdecl (Dfix (rv,trms',tys))) :: se')
 	| _ -> (compute_deps_decl d; t::se')
     end
-  | _ -> raise NoDepCheck
+  | t :: se ->
+    let se' = depcheck_se se in
+    se_iter compute_deps_decl compute_deps_spec t;
+    t :: se'
 
 let rec depcheck_struct = function
   | [] -> []
@@ -350,13 +377,15 @@ let check_implicits = function
 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
+    List.map (fun (mp,lse) -> (mp, optim_se true (fst 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;
+  if library () then opt_struc
+  else begin
     reset_needed ();
-    List.iter add_needed to_appear;
+    List.iter add_needed (fst to_appear);
+    List.iter add_needed_mp (snd to_appear);
     depcheck_struct opt_struc
-  with NoDepCheck -> opt_struc
+  end
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
index 26d07872..0565522b 100644
--- a/plugins/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Declarations
 open Environ
@@ -38,4 +36,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
    optimizations. The first argument is the list of objects we want to appear.
 *)
 
-val optimize_struct : global_reference list -> ml_structure -> ml_structure
+val optimize_struct : global_reference list * module_path list ->
+  ml_structure -> ml_structure
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index c07a1758..ed69ec45 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Production of Ocaml syntax. *)
 
 open Pp
@@ -31,22 +29,6 @@ let pp_tvar id =
   then str ("'"^s)
   else str ("' "^s)
 
-let pp_tuple_light f = function
-  | [] -> mt ()
-  | [x] -> f true x
-  | l ->
-      pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
-
-let pp_tuple f = function
-  | [] -> mt ()
-  | [x] -> f x
-  | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
-
-let pp_boxed_tuple f = function
-  | [] -> mt ()
-  | [x] -> f x
-  | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
-
 let pp_abst = function
   | [] -> mt ()
   | l  ->
@@ -59,6 +41,10 @@ let pp_parameters l =
 let pp_string_parameters l =
   (pp_boxed_tuple str l ++ space_if (l<>[]))
 
+let pp_letin pat def body =
+  let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in
+  hv 0 (hv 0 (hov 2 fstline ++ spc () ++ str "in") ++ spc () ++ hov 0 body)
+
 (*s Ocaml renaming issues. *)
 
 let keywords =
@@ -137,7 +123,8 @@ let rec pp_type par vl t =
     | Tglob (r,[a1;a2]) when is_infix r ->
 	pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global Type r
-    | Tglob (IndRef(kn,0),l) when kn = mk_ind "Coq.Init.Specif" "sig" ->
+    | Tglob (IndRef(kn,0),l)
+	when not (keep_singleton ()) && 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
@@ -154,10 +141,19 @@ let rec pp_type par vl t =
     de Bruijn variables. [args] is the list of collected arguments
     (already pretty-printed). *)
 
+let is_bool_patt p s =
+  try
+    let r = match p with
+      | Pusual r -> r
+      | Pcons (r,[]) -> r
+      | _ -> raise Not_found
+    in
+    find_custom r = s
+  with Not_found -> false
+
+
 let is_ifthenelse = function
-  | [|(r1,[],_);(r2,[],_)|] ->
-      (try (find_custom r1 = "true") && (find_custom r2 = "false")
-       with Not_found -> false)
+  | [|([],p1,_);([],p2,_)|] -> is_bool_patt p1 "true" && is_bool_patt p2 "false"
   | _ -> false
 
 let expr_needs_par = function
@@ -167,8 +163,8 @@ let expr_needs_par = function
   | _        -> false
 
 let rec pp_expr par env args =
-  let par' = args <> [] || par
-  and apply st = pp_apply st par args in
+  let apply st = pp_apply st par args
+  and apply2 st = pp_apply2 st par args in
   function
     | MLrel n ->
 	let id = get_db_name n env in apply (pr_id id)
@@ -179,109 +175,23 @@ let rec pp_expr par env args =
       	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)
+	let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in
+	apply2 st
     | MLletin (id,a1,a2) ->
 	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") ++
-		 spc () ++ hov 0 pp_a2)))
+	hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2))
     | 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 _ as c when is_native_char c -> assert (args=[]); pp_native_char c
-    | MLcons ({c_kind = Coinductive},r,[]) ->
-	assert (args=[]);
-	pp_par par (str "lazy " ++ pp_global Cons r)
-    | MLcons ({c_kind = Coinductive},r,args') ->
-	assert (args=[]);
-	let tuple = pp_tuple (pp_expr true env []) args' in
-	pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")")
-    | MLcons (_,r,[]) ->
-	assert (args=[]);
-	pp_global Cons r
-    | MLcons ({c_kind = Record fields}, r, args') ->
-	assert (args=[]);
-	pp_record_pat (pp_fields r fields, List.map (pp_expr true env []) args')
-    | MLcons (_,r,[arg1;arg2]) when is_infix r ->
-	assert (args=[]);
-	pp_par par
-	  ((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
-	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
-	apply
-	  (pp_par par'
-	     (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 (info, t, pv) ->
-	let expr = if info.m_kind = Coinductive then
-	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
-	else
-	  (pp_expr false env [] t)
-	in
-	(try
-	   (* First, can this match be printed as a mere record projection ? *)
-	   let fields =
-	     match info.m_kind with Record f -> f | _ -> raise Impossible
-	   in
-	   let (r, ids, c) = pv.(0) in
-	   let n = List.length ids in
-	   let free_of_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in
-	   let proj_hd i =
-	     pp_expr true env [] t ++ str "." ++ pp_field r fields i
-	   in
-	   match c with
-	     | MLrel i when i <= n -> apply (pp_par par' (proj_hd (n-i)))
-	     | MLapp (MLrel i, a) when (i <= n) && (free_of_patvar a) ->
-	       let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
-	       (pp_apply (proj_hd (n-i))
-		  par ((List.map (pp_expr true env' []) a) @ args))
-	     | _ -> raise Impossible
-	 with Impossible ->
-	   (* Second, can this match be printed as a let-in ? *)
-	   if Array.length pv = 1 then
-	     let s1,s2 = pp_one_pat env info 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
-	     (* Otherwise, standard match *)
- 	     apply
-      	       (pp_par par'
-		  (try pp_ifthenelse par' env expr pv
-		   with Not_found ->
-		     v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++
-			  pp_pat env info 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
+	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
     | MLexn s ->
 	(* An [MLexn] may be applied, but I don't really care. *)
 	pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
@@ -291,7 +201,96 @@ let rec pp_expr par env args =
 	pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
     | MLaxiom ->
 	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
-
+    | MLcons (_,r,a) as c ->
+        assert (args=[]);
+        begin match a with
+	  | _ when is_native_char c -> pp_native_char c
+	  | [a1;a2] when is_infix r ->
+	    let pp = pp_expr true env [] in
+	    pp_par par (pp a1 ++ str (get_infix r) ++ pp a2)
+	  | _ when is_coinductive r ->
+	    let ne = (a<>[]) in
+	    let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in
+	    pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple))
+	  | [] -> pp_global Cons r
+	  | _ ->
+	    let fds = get_record_fields r in
+	    if fds <> [] then
+	      pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a)
+	    else
+	      let tuple = pp_tuple (pp_expr true env []) a in
+	      if str_global Cons r = "" (* hack Extract Inductive prod *)
+	      then tuple
+	      else pp_par par (pp_global Cons r ++ spc () ++ tuple)
+	end
+    | MLtuple l ->
+        assert (args = []);
+        pp_boxed_tuple (pp_expr true env []) l
+    | MLcase (_, t, pv) when is_custom_match pv ->
+        if not (is_regular_match pv) then
+	  error "Cannot mix yet user-given match and general patterns.";
+	let mkfun (ids,_,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
+	let inner =
+	  str (find_custom_match pv) ++ fnl () ++
+	  prvect pp_branch pv ++
+	  pp_expr true env [] t
+	in
+	apply2 (hov 2 inner)
+    | MLcase (typ, t, pv) ->
+        let head =
+	  if not (is_coinductive_type typ) then pp_expr false env [] t
+	  else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
+	in
+	(* First, can this match be printed as a mere record projection ? *)
+        (try pp_record_proj par env typ t pv args
+	 with Impossible ->
+	   (* Second, can this match be printed as a let-in ? *)
+	   if Array.length pv = 1 then
+	     let s1,s2 = pp_one_pat env pv.(0) in
+	     hv 0 (apply2 (pp_letin s1 head s2))
+	   else
+	     (* Third, can this match be printed as [if ... then ... else] ? *)
+	     (try apply2 (pp_ifthenelse env head pv)
+	      with Not_found ->
+		(* Otherwise, standard match *)
+		apply2
+		  (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++
+			pp_pat env pv))))
+
+and pp_record_proj par env typ t pv args =
+  (* Can a match be printed as a mere record projection ? *)
+  let fields = record_fields_of_type typ in
+  if fields = [] then raise Impossible;
+  if Array.length pv <> 1 then raise Impossible;
+  if has_deep_pattern pv then raise Impossible;
+  let (ids,pat,body) = pv.(0) in
+  let n = List.length ids in
+  let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in
+  let rel_i,a = match body with
+    | MLrel i when i <= n -> i,[]
+    | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a
+    | _ -> raise Impossible
+  in
+  let rec lookup_rel i idx = function
+    | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l
+    | Pwild :: l -> lookup_rel i (idx+1) l
+    | _ -> raise Impossible
+  in
+  let r,idx = match pat with
+    | Pusual r -> r, n-rel_i
+    | Pcons (r,l) -> r, lookup_rel rel_i 0 l
+    | _ -> raise Impossible
+  in
+  if is_infix r then raise Impossible;
+  let env' = snd (push_vars (List.rev_map id_of_mlid ids) env) in
+  let pp_args = (List.map (pp_expr true env' []) a) @ args in
+  let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx
+  in
+  pp_apply pp_head par pp_args
 
 and pp_record_pat (fields, args) =
    str "{ " ++
@@ -300,9 +299,27 @@ and pp_record_pat (fields, args) =
      (List.combine fields args) ++
    str " }"
 
-and pp_ifthenelse par env expr pv = match pv with
-  | [|(tru,[],the);(fal,[],els)|] when
-      (find_custom tru = "true") && (find_custom fal = "false")
+and pp_cons_pat r ppl =
+  if is_infix r && List.length ppl = 2 then
+    List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl)
+  else
+    let fields = get_record_fields r in
+    if fields <> [] then pp_record_pat (pp_fields r fields, ppl)
+    else if str_global Cons r = "" then
+      pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *)
+    else
+      pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl
+
+and pp_gen_pat ids env = function
+  | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l)
+  | Pusual r -> pp_cons_pat r (List.map pr_id ids)
+  | Ptuple l -> pp_boxed_tuple (pp_gen_pat ids env) l
+  | Pwild -> str "_"
+  | Prel n -> pr_id (get_db_name n env)
+
+and pp_ifthenelse env expr pv = match pv with
+  | [|([],tru,the);([],fal,els)|] when
+      (is_bool_patt tru "true") && (is_bool_patt fal "false")
       ->
       hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++
             hov 2 (str "then " ++
@@ -311,66 +328,34 @@ and pp_ifthenelse par env expr pv = match pv with
 	           hov 2 (pp_expr (expr_needs_par els) env [] els)))
   | _ -> raise Not_found
 
-and pp_one_pat env info (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
-  let patt = match info.m_kind with
-    | Record fields ->
-      pp_record_pat (pp_fields r fields, List.rev_map pr_id ids)
-    | _ -> 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 ->
-	  (* hack Extract Inductive prod *)
-	  (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ())
-	  ++ pp_boxed_tuple pr_id ids
-  in
-  patt, expr
-
-and pp_pat env info pv =
-  let factor_br, factor_set = try match info.m_same with
-    | BranchFun ints ->
-        let i = Intset.choose ints in
-        branch_as_fun info.m_typs pv.(i), ints
-    | BranchCst ints ->
-        let i = Intset.choose ints in
-	ast_pop (branch_as_cst pv.(i)), ints
-    | BranchNone -> MLdummy, Intset.empty
-  with _ -> MLdummy, Intset.empty
-  in
-  let last = Array.length pv - 1 in
+and pp_one_pat env (ids,p,t) =
+  let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in
+  pp_gen_pat (List.rev ids') env' p,
+  pp_expr (expr_needs_par t) env' [] t
+
+and pp_pat env pv =
   prvecti
-    (fun i x -> if Intset.mem i factor_set then mt () else
-       let s1,s2 = pp_one_pat env info x in
+    (fun i x ->
+       let s1,s2 = pp_one_pat env x in
        hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++
-       if i = last && Intset.is_empty factor_set then mt () else fnl ())
+       if i = Array.length pv - 1 then mt () else fnl ())
     pv
-  ++
-  if Intset.is_empty factor_set then mt () else
-  let par = expr_needs_par factor_br in
-  match info.m_same with
-    | BranchFun _ ->
-        let ids, env' = push_vars [anonymous_name] env in
-        hv 2 (str "| " ++ pr_id (List.hd ids) ++ str " ->" ++ spc () ++
-		 hov 2 (pp_expr par env' [] factor_br))
-    | BranchCst _ ->
-        hv 2 (str "| _ ->" ++ spc () ++ hov 2 (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 (List.map id_of_mlid bl) env in
   match t' with
-    | MLcase(i,MLrel 1,pv) when
-	i.m_kind = Standard && not (is_custom_match pv) ->
-	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then
+    | MLcase(Tglob(r,_),MLrel 1,pv) when
+	not (is_coinductive r) && get_record_fields r = [] &&
+	not (is_custom_match pv) ->
+	if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then
 	  pr_binding (List.rev (List.tl bl)) ++
        	  str " = function" ++ fnl () ++
-	  v 0 (pp_pat env' i pv)
+	  v 0 (pp_pat env' pv)
 	else
           pr_binding (List.rev bl) ++
           str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++
-	  v 0 (pp_pat env' i pv)
+	  v 0 (pp_pat env' pv)
     | _ ->
           pr_binding (List.rev bl) ++
 	  str " =" ++ fnl () ++ str "  " ++
@@ -451,7 +436,7 @@ let pp_logical_ind packet =
   fnl ()
 
 let pp_singleton kn packet =
-  let name = pp_global Type (IndRef (mind_of_kn kn,0)) in
+  let name = pp_global Type (IndRef (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 () ++
@@ -459,7 +444,7 @@ let pp_singleton kn packet =
 		     pr_id packet.ip_consnames.(0)))
 
 let pp_record kn fields ip_equiv packet =
-  let ind = IndRef (mind_of_kn kn,0) in
+  let ind = IndRef (kn,0) in
   let name = pp_global Type ind in
   let fieldnames = pp_fields ind fields in
   let l = List.combine fieldnames packet.ip_types.(0) in
@@ -482,20 +467,20 @@ let pp_ind co kn ind =
   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)))
+		  pp_global Type (IndRef (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 ((mind_of_kn kn,i),j+1)))
+	 Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((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 = (mind_of_kn kn,i) in
+      let ip = (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)
diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
index c0b4e5b3..fd60c69d 100644
--- a/plugins/extraction/ocaml.mli
+++ b/plugins/extraction/ocaml.mli
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 val ocaml_descr : Miniml.language_descr
 
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index 1f04ca59..21507655 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Production of Scheme syntax. *)
 
 open Pp
@@ -87,7 +85,7 @@ let rec pp_expr env args =
 		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
     | MLglob r ->
 	apply (pp_global Term r)
-    | MLcons (info,r,args') ->
+    | MLcons (_,r,args') ->
 	assert (args=[]);
 	let st =
 	  str "`" ++
@@ -95,9 +93,12 @@ let rec pp_expr env args =
 		 (if args' = [] then mt () else spc ()) ++
 		 prlist_with_sep spc (pp_cons_args env) args')
 	in
-	if info.c_kind = Coinductive then paren (str "delay " ++ st) else st
+	if is_coinductive r then paren (str "delay " ++ st) else st
+    | MLtuple _ -> error "Cannot handle tuples in Scheme yet."
+    | MLcase (_,_,pv) when not (is_regular_match pv) ->
+	error "Cannot handle general patterns in Scheme yet."
     | MLcase (_,t,pv) when is_custom_match pv ->
-	let mkfun (_,ids,e) =
+	let mkfun (ids,_,e) =
 	  if ids <> [] then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
@@ -107,9 +108,9 @@ let rec pp_expr env args =
 		(str (find_custom_match pv) ++ fnl () ++
 		 prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv
 		 ++ pp_expr env [] t)))
-     | MLcase (info,t, pv) ->
-	let e =
-	  if info.m_kind <> Coinductive then pp_expr env [] t
+    | MLcase (typ,t, pv) ->
+        let e =
+	  if not (is_coinductive_type typ) then pp_expr env [] t
 	  else paren (str "force" ++ spc () ++ pp_expr env [] t)
 	in
 	apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv)))
@@ -126,14 +127,18 @@ let rec pp_expr env args =
     | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"")
 
 and pp_cons_args env = function
-  | MLcons (info,r,args) when info.c_kind<>Coinductive ->
+  | MLcons (_,r,args) when is_coinductive r ->
       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) =
+and pp_one_pat env (ids,p,t) =
+  let r = match p with
+    | Pusual r -> r
+    | Pcons (r,l) -> r (* cf. the check [is_regular_match] above *)
+    | _ -> assert false
+  in
   let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
   let args =
     if ids = [] then mt ()
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
index c7c3d8b5..eeca083c 100644
--- a/plugins/extraction/scheme.mli
+++ b/plugins/extraction/scheme.mli
@@ -1,11 +1,9 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 val scheme_descr : Miniml.language_descr
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 67cf2210..238befd2 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Declarations
@@ -21,23 +19,11 @@ open Util
 open Pp
 open Miniml
 
-(** Sets and maps for [global_reference] that work modulo equivalent
-    on the user part of the name (otherwise use Refset / Refmap ) *)
-
-module RefOrd = struct
-  type t = global_reference
-  let compare x y =
-    let make_name = function
-      | ConstRef con -> ConstRef(constant_of_kn(user_con con))
-      | IndRef (kn,i) -> IndRef(mind_of_kn(user_mind kn),i)
-      | ConstructRef ((kn,i),j)-> ConstructRef((mind_of_kn(user_mind kn),i),j)
-      | VarRef id -> VarRef id
-    in
-    Pervasives.compare (make_name x) (make_name y)
-end
+(** Sets and maps for [global_reference] that use the "user" [kernel_name]
+    instead of the canonical one *)
 
-module Refmap' = Map.Make(RefOrd)
-module Refset' = Set.Make(RefOrd)
+module Refmap' = Map.Make(RefOrdered_env)
+module Refset' = Set.Make(RefOrdered_env)
 
 (*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
 
@@ -71,11 +57,6 @@ 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
-  | (MPfile _) as mp -> mp
-  | MPdot (mp,_) -> modfile_of_mp mp
-  | _ -> raise Not_found
-
 let current_toplevel () = fst (Lib.current_prefix ())
 
 let is_toplevel mp =
@@ -109,12 +90,6 @@ let common_prefix_from_list mp0 mpl =
     | 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
-  | mp -> mp,ll
-
-let labels_of_mp mp = parse_labels [] mp
-
 let rec parse_labels2 ll mp1 = function
   | mp when mp1=mp -> mp,ll
   | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
@@ -125,10 +100,6 @@ let labels_of_ref r =
   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, ... *)
 
@@ -156,6 +127,39 @@ let add_ind kn mib ml_ind =
   inductives := Mindmap_env.add kn (mib,ml_ind) !inductives
 let lookup_ind kn = Mindmap_env.find kn !inductives
 
+let inductive_kinds =
+  ref (Mindmap_env.empty : inductive_kind Mindmap_env.t)
+let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty
+let add_inductive_kind kn k =
+    inductive_kinds := Mindmap_env.add kn k !inductive_kinds
+let is_coinductive r =
+  let kn = match r with
+    | ConstructRef ((kn,_),_) -> kn
+    | IndRef (kn,_) -> kn
+    | _ -> assert false
+  in
+  try Mindmap_env.find kn !inductive_kinds = Coinductive
+  with Not_found -> false
+
+let is_coinductive_type = function
+  | Tglob (r,_) -> is_coinductive r
+  | _ -> false
+
+let get_record_fields r =
+  let kn = match r with
+    | ConstructRef ((kn,_),_) -> kn
+    | IndRef (kn,_) -> kn
+    | _ -> assert false
+  in
+  try match Mindmap_env.find kn !inductive_kinds with
+    | Record f -> f
+    | _ -> []
+  with Not_found -> []
+
+let record_fields_of_type = function
+  | Tglob (r,_) -> get_record_fields r
+  | _ -> []
+
 (*s Recursors table. *)
 
 (* NB: here we can use the equivalence between canonical
@@ -203,25 +207,51 @@ let add_info_axiom r = info_axioms := Refset'.add r !info_axioms
 let remove_info_axiom r = info_axioms := Refset'.remove r !info_axioms
 let add_log_axiom r = log_axioms := Refset'.add r !log_axioms
 
-(*s Extraction mode: modular or monolithic *)
+let opaques = ref Refset'.empty
+let init_opaques () = opaques := Refset'.empty
+let add_opaque r = opaques := Refset'.add r !opaques
+let remove_opaque r = opaques := Refset'.remove r !opaques
+
+(*s Extraction modes: modular or monolithic, library or minimal ?
+
+Nota:
+ - Recursive Extraction : monolithic, minimal
+ - Separate Extraction : modular, minimal
+ - Extraction Library : modular, library
+*)
 
 let modular_ref = ref false
+let library_ref = ref false
 
 let set_modular b = modular_ref := b
 let modular () = !modular_ref
 
+let set_library b = library_ref := b
+let library () = !library_ref
+
 (*s Printing. *)
 
 (* The following functions work even on objects not in [Global.env ()].
-   WARNING: for inductive objects, an extract_inductive must have been
-   done before. *)
-
-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) ->
-      (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1)
-  | _ -> assert false
+   Warning: for inductive objects, this only works if an [extract_inductive]
+   have been done earlier, otherwise we can only ask the Nametab about
+   currently visible objects. *)
+
+let safe_basename_of_global r =
+  let last_chance r =
+    try Nametab.basename_of_global r
+    with Not_found ->
+      anomaly "Inductive object unknown to extraction and not globally visible"
+  in
+  match r with
+    | ConstRef kn -> id_of_label (con_label kn)
+    | IndRef (kn,0) -> id_of_label (mind_label kn)
+    | IndRef (kn,i) ->
+      (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename
+       with Not_found -> last_chance r)
+    | ConstructRef ((kn,i),j) ->
+      (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1)
+       with Not_found -> last_chance r)
+    | VarRef _ -> assert false
 
 let string_of_global r =
  try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
@@ -272,7 +302,28 @@ let warning_axioms () =
        str "Having invalid logical axiom in the environment when extracting" ++
        spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
        fnl ())
-  end
+  end;
+  if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then
+    msg_warning
+      (str "Some of these axioms might be due to option -dont-load-proofs.")
+
+let warning_opaques accessed =
+  let opaques = Refset'.elements !opaques in
+  if opaques = [] then ()
+  else
+    let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in
+    if accessed then
+      msg_warning
+	(str "The extraction is currently set to bypass opacity,\n" ++
+	 str "the following opaque constant bodies have been accessed :" ++
+	 lst ++ str "." ++ fnl ())
+    else
+      msg_warning
+	(str "The extraction now honors the opacity constraints by default,\n" ++
+	 str "the following opaque constants have been extracted as axioms :" ++
+	 lst ++ str "." ++ fnl () ++
+	 str "If necessary, use \"Set Extraction AccessOpaque\" to change this."
+	 ++ fnl ())
 
 let warning_both_mod_and_cst q mp r =
  msg_warning
@@ -386,31 +437,34 @@ let info_file f =
 (* The objects defined below should survive an arbitrary time,
    so we register them to coq save/undo mechanism. *)
 
-(*s Extraction AutoInline *)
+let my_bool_option name initval =
+  let flag = ref initval in
+  let access = fun () -> !flag in
+  let _ = declare_bool_option
+    {optsync = true;
+     optdepr = false;
+     optname = "Extraction "^name;
+     optkey = ["Extraction"; name];
+     optread = access;
+     optwrite = (:=) flag }
+  in
+  access
 
-let auto_inline_ref = ref false
+(*s Extraction AccessOpaque *)
 
-let auto_inline () = !auto_inline_ref
+let access_opaque = my_bool_option "AccessOpaque" false
 
-let _ = declare_bool_option
-	  {optsync = true;
-	   optname = "Extraction AutoInline";
-	   optkey = ["Extraction"; "AutoInline"];
-	   optread = auto_inline;
-	   optwrite = (:=) auto_inline_ref}
+(*s Extraction AutoInline *)
+
+let auto_inline = my_bool_option "AutoInline" false
 
 (*s Extraction TypeExpand *)
 
-let type_expand_ref = ref true
+let type_expand = my_bool_option "TypeExpand" true
 
-let type_expand () = !type_expand_ref
+(*s Extraction KeepSingleton *)
 
-let _ = declare_bool_option
-	  {optsync = true;
-	   optname = "Extraction TypeExpand";
-	   optkey = ["Extraction"; "TypeExpand"];
-	   optread = type_expand;
-	   optwrite = (:=) type_expand_ref}
+let keep_singleton = my_bool_option "KeepSingleton" false
 
 (*s Extraction Optimize *)
 
@@ -461,6 +515,7 @@ let optims () = !opt_flag_ref
 
 let _ = declare_bool_option
 	  {optsync = true;
+           optdepr = false;
 	   optname = "Extraction Optimize";
 	   optkey = ["Extraction"; "Optimize"];
 	   optread = (fun () -> !int_flag_ref <> 0);
@@ -468,6 +523,7 @@ let _ = declare_bool_option
 
 let _ = declare_int_option
           { optsync = true;
+            optdepr = false;
             optname = "Extraction Flag";
             optkey = ["Extraction";"Flag"];
             optread = (fun _ -> Some !int_flag_ref);
@@ -484,7 +540,7 @@ let lang_ref = ref Ocaml
 
 let lang () = !lang_ref
 
-let (extr_lang,_) =
+let extr_lang : lang -> obj =
   declare_object
     {(default_object "Extraction Lang") with
        cache_function = (fun (_,l) -> lang_ref := l);
@@ -516,12 +572,14 @@ let add_inline_entries b l =
 
 (* Registration of operations for rollback. *)
 
-let (inline_extraction,_) =
+let inline_extraction : bool * global_reference list -> obj =
   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);
        classify_function = (fun o -> Substitute o);
+       discharge_function =
+	(fun (_,(b,l)) -> Some (b, List.map pop_global_reference l));
        subst_function =
         (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
     }
@@ -534,8 +592,7 @@ let _ = declare_summary "Extraction Inline"
 (* Grammar entries. *)
 
 let extraction_inline b l =
-  check_inside_section ();
-  let refs = List.map Nametab.global l in
+  let refs = List.map Smartlocate.global_with_alias l in
   List.iter
     (fun r -> match r with
        | ConstRef _ -> ()
@@ -559,7 +616,7 @@ let print_extraction_inline () =
 
 (* Reset part *)
 
-let (reset_inline,_) =
+let reset_inline : unit -> obj =
   declare_object
     {(default_object "Reset Extraction Inline") with
        cache_function = (fun (_,_)-> inline_table :=  empty_inline_table);
@@ -598,7 +655,7 @@ let add_implicits r l =
 
 (* Registration of operations for rollback. *)
 
-let (implicit_extraction,_) =
+let implicit_extraction : global_reference * int_or_id list -> obj =
   declare_object
     {(default_object "Extraction Implicit") with
        cache_function = (fun (_,(r,l)) -> add_implicits r l);
@@ -616,7 +673,7 @@ let _ = declare_summary "Extraction Implicit"
 
 let extraction_implicit r l =
   check_inside_section ();
-  Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l))
+  Lib.add_anonymous_leaf (implicit_extraction (Smartlocate.global_with_alias r,l))
 
 
 (*s Extraction Blacklist of filenames not to use while extracting *)
@@ -658,12 +715,11 @@ let add_blacklist_entries l =
 
 (* Registration of operations for rollback. *)
 
-let (blacklist_extraction,_) =
+let blacklist_extraction : string list -> obj =
   declare_object
     {(default_object "Extraction Blacklist") with
        cache_function = (fun (_,l) -> add_blacklist_entries l);
        load_function = (fun _ (_,l) -> add_blacklist_entries l);
-       classify_function = (fun o -> Libobject.Keep o);
        subst_function = (fun (_,x) -> x)
     }
 
@@ -686,7 +742,7 @@ let print_extraction_blacklist () =
 
 (* Reset part *)
 
-let (reset_blacklist,_) =
+let reset_blacklist : unit -> obj =
   declare_object
     {(default_object "Reset Extraction Blacklist") with
        cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
@@ -719,8 +775,10 @@ let add_custom_match r s =
 
 let indref_of_match pv =
   if Array.length pv = 0 then raise Not_found;
-  match pv.(0) with
-    | (ConstructRef (ip,_), _, _) -> IndRef ip
+  let (_,pat,_) = pv.(0) in
+  match pat with
+    | Pusual (ConstructRef (ip,_)) -> IndRef ip
+    | Pcons (ConstructRef (ip,_),_) -> IndRef ip
     | _ -> raise Not_found
 
 let is_custom_match pv =
@@ -732,7 +790,7 @@ let find_custom_match pv =
 
 (* Registration of operations for rollback. *)
 
-let (in_customs,_) =
+let in_customs : global_reference * string list * string -> obj =
   declare_object
     {(default_object "ML extractions") with
        cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
@@ -747,7 +805,7 @@ let _ = declare_summary "ML extractions"
 	    unfreeze_function = ((:=) customs);
 	    init_function = (fun () -> customs := Refmap'.empty) }
 
-let (in_custom_matchs,_) =
+let in_custom_matchs : global_reference * string -> obj =
   declare_object
     {(default_object "ML extractions custom matchs") with
        cache_function = (fun (_,(r,s)) -> add_custom_match r s);
@@ -765,7 +823,7 @@ let _ = declare_summary "ML extractions custom match"
 
 let extract_constant_inline inline r ids s =
   check_inside_section ();
-  let g = Nametab.global r in
+  let g = Smartlocate.global_with_alias r in
   match g with
     | ConstRef kn ->
 	let env = Global.env () in
@@ -783,7 +841,7 @@ let extract_constant_inline inline r ids s =
 
 let extract_inductive r s l optstr =
   check_inside_section ();
-  let g = Nametab.global r in
+  let g = Smartlocate.global_with_alias r in
   match g with
     | IndRef ((kn,i) as ip) ->
 	let mib = Global.lookup_mind kn in
@@ -805,5 +863,6 @@ let extract_inductive r s l optstr =
 (*s Tables synchronization. *)
 
 let reset_tables () =
-  init_terms (); init_types (); init_inductives (); init_recursors ();
-  init_projs (); init_axioms (); reset_modfile ()
+  init_terms (); init_types (); init_inductives ();
+  init_inductive_kinds (); init_recursors ();
+  init_projs (); init_axioms (); init_opaques (); reset_modfile ()
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index b70d3efa..a3b7124e 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Libnames
 open Miniml
@@ -21,6 +19,7 @@ val safe_basename_of_global : global_reference -> identifier
 (*s Warning and Error messages. *)
 
 val warning_axioms : unit -> unit
+val warning_opaques : bool -> unit
 val warning_both_mod_and_cst :
  qualid -> module_path -> global_reference -> unit
 val warning_id : string -> unit
@@ -59,10 +58,8 @@ 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 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
 
@@ -77,6 +74,14 @@ val lookup_type : constant -> ml_schema
 val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit
 val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind
 
+val add_inductive_kind : mutual_inductive -> inductive_kind -> unit
+val is_coinductive : global_reference -> bool
+val is_coinductive_type : ml_type -> bool
+(* What are the fields of a record (empty for a non-record) *)
+val get_record_fields :
+  global_reference -> global_reference option list
+val record_fields_of_type : ml_type -> global_reference option list
+
 val add_recursors : Environ.env -> mutual_inductive -> unit
 val is_recursor : global_reference -> bool
 
@@ -88,8 +93,15 @@ val add_info_axiom : global_reference -> unit
 val remove_info_axiom : global_reference -> unit
 val add_log_axiom : global_reference -> unit
 
+val add_opaque : global_reference -> unit
+val remove_opaque : global_reference -> unit
+
 val reset_tables : unit -> unit
 
+(*s AccessOpaque parameter *)
+
+val access_opaque : unit -> bool
+
 (*s AutoInline parameter *)
 
 val auto_inline : unit -> bool
@@ -98,6 +110,10 @@ val auto_inline : unit -> bool
 
 val type_expand : unit -> bool
 
+(*s KeepSingleton parameter *)
+
+val keep_singleton : unit -> bool
+
 (*s Optimize parameter *)
 
 type opt_flag =
@@ -120,11 +136,20 @@ val optims :  unit -> opt_flag
 type lang = Ocaml | Haskell | Scheme
 val lang : unit -> lang
 
-(*s Extraction mode: modular or monolithic *)
+(*s Extraction modes: modular or monolithic, library or minimal ?
+
+Nota:
+ - Recursive Extraction : monolithic, minimal
+ - Separate Extraction : modular, minimal
+ - Extraction Library : modular, library
+*)
 
 val set_modular : bool -> unit
 val modular : unit -> bool
 
+val set_library : bool -> unit
+val library : unit -> bool
+
 (*s Table for custom inlining *)
 
 val to_inline : global_reference -> bool
@@ -158,6 +183,7 @@ val extract_constant_inline :
 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
 
diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v
index 9017f8d5..011bc81e 100644
--- a/plugins/field/LegacyField.v
+++ b/plugins/field/LegacyField.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export LegacyField_Compl.
 Require Export LegacyField_Theory.
 Require Export LegacyField_Tactic.
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
index 52e049a5..97c70c0e 100644
--- a/plugins/field/LegacyField_Compl.v
+++ b/plugins/field/LegacyField_Compl.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Compl.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import List.
 
 Definition assoc_2nd :=
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
index f6626e4a..810443f8 100644
--- a/plugins/field/LegacyField_Tactic.v
+++ b/plugins/field/LegacyField_Tactic.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Tactic.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import List.
 Require Import LegacyRing.
 Require Export LegacyField_Compl.
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
index 8d10bc8e..20ffbc27 100644
--- a/plugins/field/LegacyField_Theory.v
+++ b/plugins/field/LegacyField_Theory.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import List.
 Require Import Peano_dec.
 Require Import LegacyRing.
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
index 37aa457d..9e4f4d74 100644
--- a/plugins/field/field.ml4
+++ b/plugins/field/field.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: field.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Pp
 open Proof_type
@@ -39,18 +37,20 @@ let constr_of_opt a opt =
   | None -> mkApp (init_constant "None",[|ac3|])
   | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
 
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
+
 (* Table of theories *)
-let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
+let th_tab = ref (Cmap.empty : constr Cmap.t)
 
 let lookup env typ =
-  try Gmap.find typ !th_tab
+  try Cmap.find typ !th_tab
   with Not_found ->
     errorlabstrm "field"
       (str "No field is declared for type" ++ spc() ++
       Printer.pr_lconstr_env env typ)
 
 let _ =
-  let init () = th_tab := Gmap.empty in
+  let init () = th_tab := Cmap.empty in
   let freeze () = !th_tab in
   let unfreeze fs = th_tab := fs in
   Summary.declare_summary "field"
@@ -59,7 +59,7 @@ let _ =
       Summary.init_function     = init }
 
 let load_addfield _ = ()
-let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
+let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab
 let subst_addfield (subst,(typ,th as obj)) =
   let typ' = subst_mps subst typ in
   let th' = subst_mps subst th in
@@ -67,7 +67,7 @@ let subst_addfield (subst,(typ,th as obj)) =
       (typ',th')
 
 (* Declaration of the Add Field library object *)
-let (in_addfield,out_addfield)=
+let in_addfield : types * constr -> Libobject.obj =
   Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
        Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
        Libobject.cache_function = cache_addfield;
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 1f3fd595..d67dceea 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Hipattern
 open Names
 open Term
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index a831c087..379aaff1 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Names
 open Libnames
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 8e68506c..4a38c48d 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
-(* $Id: g_ground.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Formula
 open Sequent
 open Ground
@@ -29,6 +27,7 @@ let ground_depth=ref 3
 let _=
   let gdopt=
     { optsync=true;
+      optdepr=false;
       optname="Firstorder Depth";
       optkey=["Firstorder";"Depth"];
       optread=(fun ()->Some !ground_depth);
@@ -44,6 +43,7 @@ let congruence_depth=ref 100
 let _=
   let gdopt=
     { optsync=true;
+      optdepr=false;
       optname="Congruence Depth";
       optkey=["Congruence";"Depth"];
       optread=(fun ()->Some !congruence_depth);
@@ -111,7 +111,6 @@ let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_loc
 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
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 163b9891..46708053 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Formula
 open Sequent
 open Rules
@@ -18,32 +16,6 @@ open Tactics
 open Tacticals
 open Libnames
 
-(*
-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,
-resulting in some limited space wasting*)
-
-let update_flags ()=
-  if not ( !Auto.searchtable == !old_search ) then
-    begin
-      old_search:=!Auto.searchtable;
-      let predref=ref Names.KNpred.empty in
-      let f p_a_t =
-	match p_a_t.Auto.code with
-	    Auto.Unfold_nth (ConstRef kn)->
-	      predref:=Names.KNpred.add kn !predref
-	  | _ ->() in
-      let g _ l=List.iter f l in
-      let h _ hdb=Auto.Hint_db.iter g hdb in
-	Util.Stringmap.iter h !Auto.searchtable;
-	red_flags:=
-	Closure.RedFlags.red_add_transparent
-	  Closure.betaiotazeta (Names.Idpred.full,!predref)
-    end
-*)
-
 let update_flags ()=
   let predref=ref Names.Cpred.empty in
   let f coe=
@@ -61,7 +33,7 @@ let ground_tac solver startseq gl=
   update_flags ();
   let rec toptac skipped seq gl=
     if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
-    then Pp.msgnl (Printer.pr_goal (sig_it gl));
+    then Pp.msgnl (Printer.pr_goal gl);
     tclORELSE (axiom_tac seq.gl seq)
       begin
 	try
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 8328bb3a..a4ee68fd 100644
--- a/plugins/firstorder/ground.mli
+++ b/plugins/firstorder/ground.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 val ground_tac:     Tacmach.tactic ->
   (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
 
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index 4802aaa3..16831d3e 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Formula
 open Sequent
 open Unify
 open Rules
 open Util
 open Term
-open Rawterm
+open Glob_term
 open Tacmach
 open Tactics
 open Tacticals
@@ -35,11 +33,11 @@ let compare_instance inst1 inst2=
 	  | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
 	  | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
 
-let compare_gr id1 id2=
+let compare_gr id1 id2 =
   if id1==id2 then 0 else
     if id1==dummy_id then 1
     else if id2==dummy_id then -1
-    else Pervasives.compare id1 id2
+    else Libnames.RefOrdered.compare id1 id2
 
 module OrderedInstance=
 struct
@@ -125,9 +123,9 @@ let mk_open_instance id gl m t=
   let rec raux n t=
     if n=0 then t else
       match t with
-	  RLambda(loc,name,k,_,t0)->
+	  GLambda(loc,name,k,_,t0)->
 	    let t1=raux (n-1) t0 in
-	      RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1)
+	      GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1)
 	| _-> anomaly "can't happen" in
   let ntt=try
     Pretyping.Default.understand evmap env (raux m rawt)
@@ -181,12 +179,12 @@ let right_instance_tac inst continue seq=
 	[tclTHENLIST
 	   [introf;
 	    (fun gls->
-	       split (Rawterm.ImplicitBindings
+	       split (Glob_term.ImplicitBindings
 			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
 	    tclSOLVE [wrap 0 true continue (deepen seq)]];
 	 tclTRY assumption]
     | Real ((0,t),_) ->
-	(tclTHEN (split (Rawterm.ImplicitBindings [t]))
+	(tclTHEN (split (Glob_term.ImplicitBindings [t]))
 	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
     | Real ((m,t),_) ->
 	tclFAIL 0 (Pp.str "not implemented ... yet")
diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
index 537e40e7..be69b067 100644
--- a/plugins/firstorder/instances.mli
+++ b/plugins/firstorder/instances.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Term
 open Tacmach
 open Names
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index e6d73fb6..23eeb2f6 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
index a5a6b614..7d1e57f4 100644
--- a/plugins/firstorder/rules.mli
+++ b/plugins/firstorder/rules.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Tacmach
 open Names
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index faac286e..f75678c6 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Util
 open Formula
@@ -59,71 +57,10 @@ struct
 	(priority e1.pat) - (priority e2.pat)
 end
 
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's,
-   application associativity, binders name and Cases annotations are
-   not taken into account *)
-
-let rec compare_list f l1 l2=
-  match l1,l2 with
-      [],[]-> 0
-    | [],_ -> -1
-    | _,[] -> 1
-    | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
-
-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
-	else
-	  let ci=f v1.(i) v2.(i) in
-	    if ci=0 then
-	      comp_aux (i-1)
-	    else ci
-      in comp_aux (l-1)
-    else c
-
-let compare_constr_int f t1 t2 =
-  match kind_of_term t1, kind_of_term t2 with
-    | Rel n1, Rel n2 -> n1 - n2
-    | Meta m1, Meta m2 -> m1 - m2
-    | Var id1, Var id2 -> Pervasives.compare id1 id2
-    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
-    | Cast (c1,_,_), _ -> f c1 t2
-    | _, Cast (c2,_,_) -> f t1 c2
-    | Prod (_,t1,c1), Prod (_,t2,c2)
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	(f =? f) t1 t2 c1 c2
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
-	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
-    | App (_,_), App (_,_) ->
-	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) ->
-	((-) =? (compare_array f)) e1 e2 l1 l2
-    | Const c1, Const c2 -> Pervasives.compare c1 c2
-    | Ind c1, Ind c2 -> Pervasives.compare c1 c2
-    | Construct c1, Construct c2 -> Pervasives.compare c1 c2
-    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | _ -> Pervasives.compare t1 t2
-
-let rec compare_constr m n=
-  compare_constr_int compare_constr m n
-
 module OrderedConstr=
 struct
   type t=constr
-  let compare=compare_constr
+  let compare=constr_ord
 end
 
 type h_item = global_reference * (int*constr) option
@@ -132,7 +69,7 @@ module Hitem=
 struct
   type t = h_item
   let compare (id1,co1) (id2,co2)=
-    (Pervasives.compare
+    (Libnames.RefOrdered.compare
      =? (fun oc1 oc2 ->
 	   match oc1,oc2 with
 	       Some (m1,c1),Some (m2,c2) ->
@@ -283,7 +220,7 @@ let extend_with_auto_hints l seq gl=
 	       seqref:=add_formula Hint gr typ !seqref gl
 	   with Not_found->())
       | _-> () in
-  let g _ l=List.iter f l in
+  let g _ l = List.iter f l in
   let h dbname=
     let hdb=
       try
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index ef052605..c5c2bb95 100644
--- a/plugins/firstorder/sequent.mli
+++ b/plugins/firstorder/sequent.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Util
 open Formula
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 4e0ad108..299a0054 100644
--- a/plugins/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unify.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Formula
 open Tacmach
@@ -91,9 +89,8 @@ let unif t1 t2=
 let value i t=
   let add x y=
     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 isMeta term && destMeta term = i then 0 else
       let f v t=add v (vaux t) in
       let vr=fold_constr f (-1) term in
 	if vr<0 then -1 else vr+1 in
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 4e0d88d3..06865611 100644
--- a/plugins/firstorder/unify.mli
+++ b/plugins/firstorder/unify.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unify.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 
 exception UFAIL of constr*constr
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index d6447111..a1113d2d 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
 Require Export LegacyRing.
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index 7c5b5ed7..3d16f189 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier_util.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Rbase.
 Comments "Lemmas used by the tactic Fourier".
 
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index 1a92c716..6c4d4d15 100644
--- a/plugins/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourier.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Méthode d'élimination de Fourier *)
 (* Référence:
 Auteur(s) : Fourier, Jean-Baptiste-Joseph
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 2cabcf52..48493785 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourierR.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 
 
 (* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
@@ -31,17 +29,23 @@ 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;
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+
+type flin = {fhom: rational Constrhash.t;
              fcste:rational};;
 
-let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
+let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};;
 
-let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
+let flin_coef f x = try (Constrhash.find f.fhom x) with _-> r0;;
 
 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);
+    Constrhash.remove f.fhom x;
+    Constrhash.add f.fhom x (rplus cx c);
     f
 ;;
 let flin_add_cste f c =
@@ -53,20 +57,20 @@ let flin_one () = flin_add_cste (flin_zero()) r1;;
 
 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;
+    Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+    Constrhash.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 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;
+    Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+    Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
     flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
 ;;
 let flin_emult a f =
     let f2 = flin_zero() in
-    Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
+    Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
     flin_add_cste f2 (rmult a f.fcste);
 ;;
 
@@ -167,7 +171,7 @@ let rec flin_of_constr c =
 
 let flin_to_alist f =
     let res=ref [] in
-    Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
+    Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f;
     !res
 ;;
 
@@ -256,17 +260,17 @@ let ineq1_of_constr (h,t) =
 
 let fourier_lineq lineq1 =
    let nvar=ref (-1) in
-   let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
+   let hvar=Constrhash.create 50 in (* la table des variables des inéquations *)
    List.iter (fun f ->
-		Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin
+		Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin
 				nvar:=(!nvar)+1;
-				Hashtbl.add hvar x (!nvar)
+				Constrhash.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)
+               Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c)
                   h.hflin.fhom;
                ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
              lineq1 in
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index ea766830..9276eda1 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_fourier.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open FourierR
 
 TACTIC EXTEND fourier
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index 763ed82f..b29b8362 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 3590e698..1d1e4a2a 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,7 +1,6 @@
 open Printer
 open Util
 open Term
-open Termops
 open Namegen
 open Names
 open Declarations
@@ -35,9 +34,10 @@ let observennl strm =
 let do_observe_tac s tac g =
  try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
  with e ->
-   let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+   let e = Cerrors.process_vernac_interp_error e in
+   let goal = begin try (Printer.pr_goal g) with _ -> assert false end in
    msgnl (str "observation "++ s++str " raised exception " ++
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal );
+	    Errors.print e ++ str " on goal " ++ goal );
    raise e;;
 
 let observe_tac_stream s tac g =
@@ -263,7 +263,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
     in
     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 end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *)
     let new_end_of_type =
       (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
 	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
@@ -286,7 +286,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	   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))
+	     (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
 	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
 	)
@@ -350,9 +350,9 @@ let isLetIn t =
 
 let h_reduce_with_zeta =
   h_reduce
-    (Rawterm.Cbv
-       {Rawterm.all_flags
-	with Rawterm.rDelta = false;
+    (Glob_term.Cbv
+       {Glob_term.all_flags
+	with Glob_term.rDelta = false;
        })
 
 
@@ -388,7 +388,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
   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 real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context 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 =
@@ -406,13 +406,13 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
     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
+	let actual_real_type_of_hyp = it_mkProd_or_LetIn 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 popped_t' = Termops.pop t' in
+	    let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in
 	    let prove_new_type_of_hyp =
 	      let context_length = List.length context in
 	      tclTHENLIST
@@ -461,9 +461,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 (* 	    observe (str "In "++Ppconstr.pr_id hyp_id++  *)
 (* 		       str " removing useless precond True" *)
 (* 		    );  *)
-	  let popped_t' = pop t' in
+	  let popped_t' = Termops.pop t' in
 	  let real_type_of_hyp =
-	    it_mkProd_or_LetIn ~init:popped_t' context
+	    it_mkProd_or_LetIn popped_t' context
 	  in
 	  let prove_trivial =
 	    let nb_intro = List.length context in
@@ -489,9 +489,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	  ]
 	else if is_trivial_eq t_x
 	then (*  t_x :=  t = t   => we remove this precond *)
-	  let popped_t' = pop t' in
+	  let popped_t' = Termops.pop t' in
 	  let real_type_of_hyp =
-	    it_mkProd_or_LetIn ~init:popped_t' context
+	    it_mkProd_or_LetIn popped_t' context
 	  in
 	  let hd,args = destApp t_x in
 	  let get_args hd args =
@@ -589,7 +589,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 	 let fun_body =
 	   mkLambda(Anonymous,
 		    pf_type_of g' term,
-		    replace_term term (mkRel 1) dyn_infos.info
+		    Termops.replace_term term (mkRel 1) dyn_infos.info
 		   )
 	 in
 	 let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
@@ -609,7 +609,7 @@ let my_orelse tac1 tac2 g =
   try
     tac1 g
   with e ->
-(*     observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
+(*     observe (str "using snd tac since : " ++ Errors.print e); *)
     tac2 g
 
 let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
@@ -909,8 +909,8 @@ let generalize_non_dep hyp g =
   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 List.exists (Termops.occur_var_in_decl env hyp) keep
+	or Termops.occur_var env hyp hyp_typ
 	or Termops.is_section_variable hyp (* should be dangerous *)
       then (clear,decl::keep)
       else (hyp::clear,keep))
@@ -936,7 +936,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
   let f_def = Global.lookup_constant (destConst f) in
   let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
   let f_body =
-    force (Option.get f_def.const_body)
+    force (Option.get (body_of_constant f_def))
   in
   let params,f_body_with_params = decompose_lam_n nb_params f_body in
   let (_,num),(_,_,bodies) = destFix f_body_with_params in
@@ -954,7 +954,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
   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
+  let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in
   let f_id = id_of_label (con_label (destConst f)) in
   let prove_replacement =
     tclTHENSEQ
@@ -964,7 +964,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 	   let rec_id = pf_nth_hyp_id g 1 in
 	   tclTHENSEQ
 	     [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id);
-	      (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings));
+	      (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings));
 	      intros_reflexivity] g
 	)
       ]
@@ -1009,7 +1009,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
 	  | _ -> ()
 
       in
-      Tacinterp.constr_of_id (pf_env g) equation_lemma_id
+      Constrintern.construct_reference (pf_hyps g) equation_lemma_id
   in
   let nb_intro_to_do = nb_prod (pf_concl g) in
     tclTHEN
@@ -1052,7 +1052,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
       }
     in
     let get_body const =
-      match (Global.lookup_constant const ).const_body with
+      match body_of_constant (Global.lookup_constant const) with
 	| Some b ->
 	     let body = force b in
 	     Tacred.cbv_norm_flags
@@ -1300,7 +1300,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 in
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
-		   [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
+		   [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)];
 		    let do_prove =
 		      build_proof
 			interactive_proof
@@ -1400,10 +1400,10 @@ let build_clause eqs =
   {
     Tacexpr.onhyps =
       Some (List.map
-	      (fun id -> (Rawterm.all_occurrences_expr,id),InHyp)
+	      (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp)
 	      eqs
 	   );
-    Tacexpr.concl_occs = Rawterm.no_occurrences_expr
+    Tacexpr.concl_occs = Glob_term.no_occurrences_expr
   }
 
 let rec rewrite_eqs_in_eqs eqs =
@@ -1416,7 +1416,7 @@ let rec rewrite_eqs_in_eqs eqs =
 	       (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))
+		    (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false))
 		    gl
 	       )
 	       eqs
@@ -1438,7 +1438,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 		  (fun g ->
 		     if is_mes
 		     then
-		       unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+		       unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
@@ -1451,7 +1451,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 				    Eauto.eauto_with_bases
 				      false
 				      (true,5)
-				      [Lazy.force refl_equal]
+				      [Evd.empty,Lazy.force refl_equal]
 				      [Auto.Hint_db.empty empty_transparent_state false]
 				  )
 			   )
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index b756492b..6df9d574 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,7 +1,6 @@
 open Printer
 open Util
 open Term
-open Termops
 open Namegen
 open Names
 open Declarations
@@ -114,9 +113,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
   let pre_princ =
     it_mkProd_or_LetIn
-      ~init:
       (it_mkProd_or_LetIn
-	 ~init:(Option.fold_right
+	 (Option.fold_right
 			   mkProd_or_LetIn
 			   princ_type_info.indarg
 			   princ_type_info.concl
@@ -140,7 +138,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 Termops.pop (array_get_start args)) in
 (*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
     res
   in
@@ -199,58 +197,58 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     begin
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
-	let new_x : name = get_name (ids_of_context env) x in
+	let new_x : name = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,None,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
+	 then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
 	 else
 	   (
 	     bind_fun(new_x,new_t,new_b),
 	     list_union_eq
 	       eq_constr
 	       binders_to_remove_from_t
-	       (List.map pop binders_to_remove_from_b)
+	       (List.map Termops.pop binders_to_remove_from_b)
 	   )
 
        with
 	 | Toberemoved ->
 (* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map pop binders_to_remove_from_b
+	    new_b, List.map Termops.pop binders_to_remove_from_b
 	| Toberemoved_with_rel (n,c) ->
 (* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
+	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b)
     end
   and compute_new_princ_type_for_letin remove env x v t b =
     begin
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
 	let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
-	let new_x : name = get_name (ids_of_context env) x in
+	let new_x : name = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,Some v,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
+	then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
 	else
 	  (
 	    mkLetIn(new_x,new_v,new_t,new_b),
 	    list_union_eq
 	      eq_constr
 	      (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
-	      (List.map pop binders_to_remove_from_b)
+	      (List.map Termops.pop binders_to_remove_from_b)
 	  )
 
       with
 	| Toberemoved ->
 (* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map pop binders_to_remove_from_b
+	    new_b, List.map Termops.pop binders_to_remove_from_b
 	| Toberemoved_with_rel (n,c) ->
 (* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
+	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b)
     end
   and  compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc)  =
     let new_e,to_remove_from_e = compute_new_princ_type remove env e
@@ -267,10 +265,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
       (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)
-			      new_predicates)
-	  )
+    (it_mkProd_or_LetIn
+       pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
+          	      new_predicates)
+    )
     princ_type_info.params
 
 
@@ -283,7 +281,7 @@ let change_property_sort toSort princ princName =
      compose_prod args (mkSort toSort)
     )
   in
-  let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in
+  let princName_as_constr = Constrintern.global_reference princName in
   let init =
     let nargs =  (princ_info.nparams + (List.length  princ_info.predicates)) in
     mkApp(princName_as_constr,
@@ -291,8 +289,7 @@ let change_property_sort toSort princ princName =
 	    (fun i -> mkRel (nargs - i )))
   in
   it_mkLambda_or_LetIn
-    ~init:
-    (it_mkLambda_or_LetIn ~init
+    (it_mkLambda_or_LetIn init
        (List.map change_sort_in_predicate princ_info.predicates)
     )
     princ_info.params
@@ -384,10 +381,9 @@ let generate_functional_principle
 	(*       Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
 	let ce =
 	  { const_entry_body = value;
+            const_entry_secctx = None;
 	    const_entry_type = None;
-	    const_entry_opaque = false;
-	    const_entry_boxed = Flags.boxed_definitions()
-	  }
+	    const_entry_opaque = false }
 	in
 	ignore(
 	  Declare.declare_constant
@@ -450,7 +446,7 @@ let get_funs_constant mp dp =
   in
   function const ->
     let find_constant_body const =
-      match (Global.lookup_constant const ).const_body with
+      match body_of_constant (Global.lookup_constant const) with
 	| Some b ->
 	    let body = force b in
 	    let body = Tacred.cbv_norm_flags
@@ -475,7 +471,7 @@ let get_funs_constant mp dp =
       let first_params = List.hd l_params  in
       List.iter
 	(fun params ->
-	   if not ((=) first_params params)
+	   if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params)
 	   then error "Not a mutal recursive block"
 	)
 	l_params
@@ -493,7 +489,10 @@ let get_funs_constant mp dp =
 	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))
+	  let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) =
+	    ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2
+	  in
+	  if not (eq_infos first_infos (extract_info false body))
 	  then  error "Not a mutal recursive block"
 	in
 	List.iter check l_bodies
@@ -504,7 +503,7 @@ let get_funs_constant mp dp =
 exception No_graph_found
 exception Found_type of int
 
-let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
+let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list =
   let env = Global.env ()
   and sigma = Evd.empty in
   let funs = List.map fst fas in
@@ -584,7 +583,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
     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
+      Declarations.is_opaque (Global.lookup_constant equation)
     with Option.IsNone -> (* non recursive definition *)
       false
   in
@@ -639,7 +638,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
 	     const
 	 with Found_type i ->
 	   let princ_body =
-	     Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
+	     Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt
 	   in
 	   {const with
 	      Entries.const_entry_body = princ_body;
@@ -688,7 +687,7 @@ 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 *)
+(*     Constrintern.global_reference  id *)
 (*   in  *)
   let funs =  (fun (_,f,_) ->
 		 try Libnames.constr_of_global (Nametab.global f)
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index fb04c6ec..1c02c16e 100644
--- a/plugins/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array ->
 
 exception No_graph_found
 
-val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list
+val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list
 
-val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list ->  unit
-val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort)  ->  unit
+val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list ->  unit
+val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort)  ->  unit
 
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 41fafdf1..123399d5 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,19 +16,20 @@ open Indfun
 open Genarg
 open Pcoq
 open Tacticals
+open Constr
 
 let pr_binding prc = function
-  | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+  | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Rawterm.ImplicitBindings l ->
+  | Glob_term.ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
       Util.prlist_with_sep spc prc l
-  | Rawterm.ExplicitBindings l ->
+  | Glob_term.ExplicitBindings l ->
       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 ()
+  | Glob_term.NoBindings -> mt ()
 
 let pr_with_bindings prc prlc (c,bl) =
   prc c ++ hv 0 (pr_bindings prc prlc bl)
@@ -55,7 +56,6 @@ let pr_fun_ind_using_typed prc prlc _ opt_c =
 
 
 ARGUMENT EXTEND fun_ind_using
-  TYPED AS constr_with_bindings_opt
   PRINTED BY pr_fun_ind_using_typed
   RAW_TYPED AS constr_with_bindings_opt
   RAW_PRINTED BY pr_fun_ind_using
@@ -129,85 +129,36 @@ 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 ++
-    Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}"
-
-let pr_rec_annotation2 = function
-  | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}"
-  | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l
-  | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l
-
-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) ]
-END
-
-let pr_binder2 (idl,c) =
-  str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++
-    str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")"
+module Gram = Pcoq.Gram
+module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
 
-VERNAC ARGUMENT EXTEND binder2
-PRINTED BY pr_binder2
-    [ "(" ne_ident_list(idl) ":" lconstr(c)  ")"] -> [ (idl,c) ]
-END
+module FunctionGram =
+struct
+  let gec s = Gram.entry_create ("Function."^s)
+		(* types *)
+  let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc"
+end
+open FunctionGram
 
-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 ++
-    Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++
-    Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++
-    Ppconstr.pr_lconstr_expr def
-
-VERNAC ARGUMENT EXTEND rec_definition2
-PRINTED BY pr_rec_definition2
- [ ident(id)  binder2_list(bl)
-     rec_annotation2_opt(annot) ":" lconstr(type_)
-	":=" lconstr(def)] ->
-    [ (id,bl,annot,type_,def) ]
-END
+GEXTEND Gram
+  GLOBAL: function_rec_definition_loc ;
 
-let make_rec_definitions2 (id,bl,annot,type_,def) =
-     let bl = List.map make_binder2 bl in
-     let names = List.map snd (Topconstr.names_of_local_assums bl) in
-     let check_one_name () =
-       if List.length names > 1 then
-         Util.user_err_loc
-           (Util.dummy_loc,"Function",
-            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 ignore(Util.list_index0 (Name id) names); annot
-	  with Not_found ->  Util.user_err_loc
-            (Util.dummy_loc,"Function",
-             Pp.str "No argument named " ++ Nameops.pr_id id)
-	 )
-       with Failure "check_exists_args" ->  check_one_name ();annot
-     in
-     let ni =
-       match annot with
-         | None ->
-             annot
-	 | Some an ->
-	     check_exists_args an
-     in
-     ((Util.dummy_loc,id), ni, bl, type_, def)
+  function_rec_definition_loc:
+    [ [ g = Vernac.rec_definition -> loc, g ]]
+    ;
 
+  END
+type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type
 
+let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype),
+  (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype),
+  (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) =
+  Genarg.create_arg "function_rec_definition_loc"
 VERNAC COMMAND EXTEND Function
-   ["Function" ne_rec_definition2_list_sep(recsl,"with")] ->
+   ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] ->
 	[
-	  do_generate_principle false (List.map make_rec_definitions2 recsl);
+	  do_generate_principle false (List.map snd recsl);
 
 	]
 END
@@ -215,7 +166,7 @@ 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 " ++
-  Ppconstr.pr_rawsort s
+  Ppconstr.pr_glob_sort s
 
 VERNAC ARGUMENT EXTEND fun_scheme_arg
 PRINTED BY pr_fun_scheme_arg
@@ -224,17 +175,18 @@ END
 
 
 let warning_error names e =
+  let e = Cerrors.process_vernac_interp_error e in
   match e with
     | Building_graph e ->
 	Pp.msg_warning
 	  (str "Cannot define graph(s) for " ++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
+	     if do_observe () then (spc () ++ Errors.print e) else mt ())
     | Defining_principle e ->
 	Pp.msg_warning
 	  (str "Cannot define principle(s) for "++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
-	     if do_observe () then Cerrors.explain_exn e else mt ())
+	     if do_observe () then Errors.print e else mt ())
     | _ -> raise e
 
 
@@ -480,7 +432,7 @@ TACTIC EXTEND fauto
     [ "fauto" tactic(tac)] ->
       [
 	let heuristic = chose_heuristic None in
-	finduction None heuristic (snd tac)
+	finduction None heuristic (Tacinterp.eval_tactic tac)
       ]
   |
     [ "fauto" ] ->
diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index b74422a3..c88c6669 100644
--- a/plugins/funind/rawterm_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -2,11 +2,11 @@ open Printer
 open Pp
 open Names
 open Term
-open Rawterm
+open Glob_term
 open Libnames
 open Indfun_common
 open Util
-open Rawtermops
+open Glob_termops
 
 let observe strm =
   if do_observe ()
@@ -23,31 +23,31 @@ type binder_type =
   | Prod of name
   | LetIn of name
 
-type raw_context = (binder_type*rawconstr) list
+type glob_context = (binder_type*glob_constr) list
 
 (*
-   compose_raw_context [(bt_1,n_1,t_1);......] rt returns
+   compose_glob_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_glob_context =
   let compose_binder  (bt,t) acc =
     match bt with
-      | Lambda n -> mkRLambda(n,t,acc)
-      | Prod n -> mkRProd(n,t,acc)
-      | LetIn n -> mkRLetIn(n,t,acc)
+      | Lambda n -> mkGLambda(n,t,acc)
+      | Prod n -> mkGProd(n,t,acc)
+      | LetIn n -> mkGLetIn(n,t,acc)
   in
   List.fold_right compose_binder
 
 
 (*
-   The main part deals with building a list of raw constructor expressions
+   The main part deals with building a list of globalized constructor expressions
    from the rhs of a fixpoint equation.
 *)
 
 type 'a build_entry_pre_return =
     {
-      context : raw_context;  (* the binding context of the result *)
+      context : glob_context;  (* the binding context of the result *)
       value : 'a; (* The value *)
     }
 
@@ -159,8 +159,8 @@ let apply_args ctxt body args =
       | _,[] -> (* No more args *)
 	  (ctxt,body)
       | [],_ -> (* no more fun *)
-	  let f,args' = raw_decompose_app body in
-	  (ctxt,mkRApp(f,args'@args))
+	  let f,args' = glob_decompose_app body in
+	  (ctxt,mkGApp(f,args'@args))
       | (Lambda Anonymous,t)::ctxt',arg::args' ->
 	  do_apply avoid ctxt' body args'
       | (Lambda (Name id),t)::ctxt',arg::args' ->
@@ -215,8 +215,8 @@ let combine_app f args =
 let combine_lam n t b =
   {
     context = [];
-    value = mkRLambda(n, compose_raw_context t.context t.value,
-		      compose_raw_context b.context b.value )
+    value = mkGLambda(n, compose_glob_context t.context t.value,
+		      compose_glob_context b.context b.value )
   }
 
 
@@ -269,8 +269,8 @@ 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))
+       then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref))
+       else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref))
     )
     0
 (*
@@ -281,7 +281,7 @@ let make_discr_match_brl i =
 *)
 let make_discr_match brl =
   fun el i ->
-  mkRCases(None,
+  mkGCases(None,
 	   make_discr_match_el el,
 	   make_discr_match_brl i brl)
 
@@ -312,22 +312,22 @@ let build_constructors_of_type ind' argl =
 		  if argl = []
 		  then
  		    Array.to_list
-		      (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
+		      (Array.init (cst_narg - npar) (fun _ -> mkGHole ())
 		      )
 		  else argl
 		in
 		let pat_as_term =
-		  mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
+		  mkGApp(mkGRef (ConstructRef(ind',i+1)),argl)
 		in
-		cases_pattern_of_rawconstr Anonymous pat_as_term
+		cases_pattern_of_glob_constr Anonymous pat_as_term
 	     )
     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
+  let f,_ = glob_decompose_app b in
   match f with
-    | RRef(_,ref) ->
+    | GRef(_,ref) ->
 	begin
 	  let ind_type  =
 	    match ref with
@@ -350,8 +350,8 @@ let rec find_type_of nb b =
 	  then raise (Invalid_argument "find_type_of : not a valid inductive");
 	  ind_type
 	end
-    | RCast(_,b,_) -> find_type_of nb b
-    | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
+    | GCast(_,b,_) -> find_type_of nb b
+    | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *)
     | _ -> raise (Invalid_argument "not a ref")
 
 
@@ -419,7 +419,7 @@ let add_pat_variables pat typ env : Environ.env =
 let rec pattern_to_term_and_type env typ  = function
   | PatVar(loc,Anonymous) -> assert false
   | PatVar(loc,Name id) ->
-	mkRVar id
+	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
 	Inductiveops.mis_constructor_nargs_env
@@ -445,7 +445,7 @@ let rec pattern_to_term_and_type env typ  = function
       let patl_as_term =
 	List.map2 (pattern_to_term_and_type env)  (List.rev cs_args_types)  patternl
       in
-      mkRApp(mkRRef(ConstructRef constr),
+      mkGApp(mkGRef(ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
 
@@ -472,7 +472,7 @@ let rec pattern_to_term_and_type env typ  = function
    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.
+   WARNING: The terms constructed here are only USING the glob_constr 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.
@@ -481,15 +481,15 @@ let rec pattern_to_term_and_type env typ  = function
 *)
 
 
-let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
-  observe (str " Entering : " ++ Printer.pr_rawconstr rt);
+let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
+  observe (str " Entering : " ++ Printer.pr_glob_constr rt);
   match rt with
-    | RRef _ | RVar _ | REvar _ | RPatVar _     | RSort _  | RHole _  ->
+    | GRef _ | GVar _ | GEvar _ | GPatVar _     | GSort _  | GHole _  ->
 	(* do nothing (except changing type of course) *)
 	mk_result [] rt avoid
-    | RApp(_,_,_) ->
-	let f,args = raw_decompose_app rt in
-	let args_res : (rawconstr list) build_entry_return =
+    | GApp(_,_,_) ->
+	let f,args = glob_decompose_app rt in
+	let args_res : (glob_constr list) build_entry_return =
 	  List.fold_right (* create the arguments lists of constructors and combine them *)
 	    (fun arg ctxt_argsl ->
 	       let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
@@ -500,19 +500,19 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	in
 	begin
 	  match f with
-	    | RLambda _  -> 
+	    | GLambda _  -> 
 		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)
+			  | GLambda(loc,na,_,nat,b) -> 
+			      GLetIn(dummy_loc,na,u,aux b l)
 			  | _ -> 
-			      RApp(dummy_loc,t,l)
+			      GApp(dummy_loc,t,l)
 		in
 		build_entry_lc env funnames avoid (aux f args)
-	    | RVar(_,id) when Idset.mem id funnames ->
+	    | GVar(_,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
@@ -525,20 +525,20 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 		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 res_rt = mkGVar 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)]
+			  Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)]
 		       in
 		       {context =  arg_res.context@new_hyps; value = res_rt }
 		    )
 		    args_res.result
 		in
 		{ result = new_result; to_avoid = new_avoid }
-	    | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
+	    | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ ->
 		(* if have [g t1 ... tn] with [g] not appearing in [funnames]
 		   then
 		   foreach [ctxt,v1 ... vn] in [args_res] we return
@@ -549,11 +549,11 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 		    result =
 		    List.map
 		      (fun args_res ->
-			 {args_res with value = mkRApp(f,args_res.value)})
+			 {args_res with value = mkGApp(f,args_res.value)})
 		      args_res.result
 		}
-	    | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
-       	    | RLetIn(_,n,t,b) ->
+	    | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *)
+       	    | GLetIn(_,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
@@ -567,7 +567,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 			let new_b =
 			  replace_var_by_term
 			    id
-			    (RVar(dummy_loc,id))
+			    (GVar(dummy_loc,id))
 			    b
 			in
 			(Name new_id,new_b,new_avoid)
@@ -577,27 +577,26 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 		  env
 		  funnames
 		  avoid
-		  (mkRLetIn(new_n,t,mkRApp(new_b,args)))
-	    | RCases _  | RIf _ | RLetTuple _ ->
+		  (mkGLetIn(new_n,t,mkGApp(new_b,args)))
+	    | GCases _  | GIf _ | GLetTuple _ ->
 		(* we have [(match e1, ...., en with ..... end) t1 tn]
 		   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,_) ->
+	    | GCast(_,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"
+		build_entry_lc env funnames avoid (mkGApp(b,args))
+	    | GRec _ -> error "Not handled GRec"
+	    | GProd _ -> error "Cannot apply a type"
 	end (* end of the application treatement *)
 
-    | RLambda(_,n,_,t,b) ->
+    | GLambda(_,n,_,t,b) ->
 	(* we first compute the list of constructor
 	   corresponding to the body of the function,
 	   then the one corresponding to the type
@@ -612,7 +611,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	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) ->
+    | GProd(_,n,_,t,b) ->
 	(* we first compute the list of constructor
 	   corresponding to the body of the function,
 	   then the one corresponding to the type
@@ -622,7 +621,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	let new_env = raw_push_named (n,None,t) env in
 	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) ->
+    | GLetIn(_,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]
@@ -638,21 +637,21 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	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) ->
+    | GCases(_,_,_,el,brl) ->
 	(* we create the discrimination function
 	   and treat the case itself
 	*)
 	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) ->
+    | GIf(_,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 " ++
-			       Printer.pr_rawconstr b ++ str " in " ++
-			       Printer.pr_rawconstr rt ++ str ". try again with a cast")
+			       Printer.pr_glob_constr b ++ str " in " ++
+			       Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	in
 	let case_pats = build_constructors_of_type ind [] in
 	assert (Array.length case_pats = 2);
@@ -663,17 +662,17 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	    [lhs;rhs]
 	in
 	let match_expr =
-	  mkRCases(None,[(b,(Anonymous,None))],brl)
+	  mkGCases(None,[(b,(Anonymous,None))],brl)
 	in
-	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
+	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *)
 	build_entry_lc env funnames avoid match_expr
-    | RLetTuple(_,nal,_,b,e) ->
+    | GLetTuple(_,nal,_,b,e) ->
 	begin
-	  let nal_as_rawconstr =
+	  let nal_as_glob_constr =
 	    List.map
 	      (function
-		   Name id -> mkRVar id
-		 | Anonymous -> mkRHole ()
+		   Name id -> mkGVar id
+		 | Anonymous -> mkGHole ()
 	      )
 	      nal
 	  in
@@ -683,26 +682,25 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	    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")
+				 Printer.pr_glob_constr b ++ str " in " ++
+				 Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	  in
-	  let case_pats = build_constructors_of_type ind nal_as_rawconstr in
+	  let case_pats = build_constructors_of_type ind nal_as_glob_constr in
 	  assert (Array.length case_pats = 1);
 	  let br =
 	    (dummy_loc,[],[case_pats.(0)],e)
 	  in
-	  let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
+	  let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in
 	  build_entry_lc env funnames avoid match_expr
 
 	end
-    | RRec _ -> error "Not handled RRec"
-    | RCast(_,b,_) ->
+    | GRec _ -> error "Not handled GRec"
+    | GCast(_,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 =
+    (brl:Glob_term.cases_clauses) avoid :
+    glob_constr build_entry_return =
   match el with
     | [] -> assert false (* this case correspond to match <nothing> with .... !*)
     | el ->
@@ -762,7 +760,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	   (will be used in the following recursive calls)
 	*)
 	let new_env = List.fold_right2 add_pat_variables patl types env in
-	let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
+	let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list =
 	  List.map2
 	    (fun pat typ ->
 	       fun avoid pat'_as_term ->
@@ -778,9 +776,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 			  Detyping.detype false []
 			    (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
 			in
-			mkRProd (Name id,raw_typ_of_id,acc))
+			mkGProd (Name id,raw_typ_of_id,acc))
 		     pat_ids
-		     (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
+		     (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))
 	    )
 	    patl
 	    types
@@ -835,7 +833,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 		      else acc
 		   )
 		   idl
-		   [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
+		   [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)]
 	      )
 	      patl
 	      matched_expr.value
@@ -879,16 +877,16 @@ let is_res id =
 
 let same_raw_term rt1 rt2 = 
   match rt1,rt2 with 
-    | RRef(_,r1), RRef (_,r2) -> r1=r2
-    | RHole _, RHole _ -> true
+    | GRef(_,r1), GRef (_,r2) -> r1=r2
+    | GHole _, GHole _ -> true
     | _ -> false
 let decompose_raw_eq lhs rhs = 
   let rec decompose_raw_eq lhs rhs acc = 
-    observe (str "decomposing eq for " ++ pr_rawconstr lhs ++ str " " ++ pr_rawconstr rhs);
-    let (rhd,lrhs) = raw_decompose_app rhs in 
-    let (lhd,llhs) = raw_decompose_app lhs in 
-    observe (str "lhd := " ++ pr_rawconstr lhd);
-    observe (str "rhd := " ++ pr_rawconstr rhd);
+    observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs);
+    let (rhd,lrhs) = glob_decompose_app rhs in 
+    let (lhd,llhs) = glob_decompose_app lhs in 
+    observe (str "lhd := " ++ pr_glob_constr lhd);
+    observe (str "rhd := " ++ pr_glob_constr rhd);
     observe (str "llhs := " ++ int (List.length llhs));
     observe (str "lrhs := " ++ int (List.length lrhs));
     let sllhs = List.length llhs in 
@@ -905,29 +903,29 @@ let decompose_raw_eq lhs rhs =
 exception Continue
 (*
    The second phase which reconstruct the real type of the constructor.
-   rebuild the raw constructors expression.
+   rebuild the globalized constructors expression.
    eliminates some meaningless equalities, applies some rewrites......
 *)
 let rec rebuild_cons env nb_args relname args crossed_types depth rt =
-  observe (str "rebuilding : " ++ pr_rawconstr rt);
+  observe (str "rebuilding : " ++ pr_glob_constr rt);
 
   match rt with
-    | RProd(_,n,k,t,b) ->
+    | GProd(_,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
-	    | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
+	    | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id ->
 		begin
 		  match args' with
-		    | (RVar(_,this_relname))::args' ->
+		    | (GVar(_,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])
+			  mkGApp(mkGVar(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
@@ -937,17 +935,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			    args new_crossed_types
 			    (depth + 1) b
 			in
-			mkRProd(n,new_t,new_b),
+			mkGProd(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
 		end
-	    | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
+	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt])
 		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
 		  ->
 		begin
 		  try
-		    observe (str "computing new type for eq : " ++ pr_rawconstr rt);
+		    observe (str "computing new type for eq : " ++ pr_glob_constr rt);
 		    let t' =
 		      try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
 		    in
@@ -968,7 +966,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			new_args new_crossed_types
 			(depth + 1) subst_b
 		    in
-		    mkRProd(n,t,new_b),id_to_exclude
+		    mkGProd(n,t,new_b),id_to_exclude
 		  with Continue ->
 		    let jmeq = Libnames.IndRef (destInd (jmeq ())) in
 		    let ty' = Pretyping.Default.understand Evd.empty env ty in
@@ -979,20 +977,20 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		      ((Util.list_chop nparam args'))
 		    in
 		    let rt_typ =
-		       RApp(Util.dummy_loc,
-			    RRef (Util.dummy_loc,Libnames.IndRef ind),
+		       GApp(Util.dummy_loc,
+			    GRef (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 ()))))
+					 (mkGHole ()))))
 		    in
 		    let eq' =
-		      RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
+		      GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt])
 		    in
-		    observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
+		    observe (str "computing new type for jmeq : " ++ pr_glob_constr eq');
 		    let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
 		    observe (str " computing new type for jmeq : done") ;
 		    let new_args =
@@ -1051,14 +1049,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			new_args new_crossed_types
 			(depth + 1) subst_b
 		    in
-		    mkRProd(n,eq',new_b),id_to_exclude
+		    mkGProd(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
+		     mkGProd(n,t,new_b),id_to_exclude
 		     else new_b, Idset.add id id_to_exclude
 		  *)
-	    | RApp(loc1,RRef(loc2,eq_as_ref),[ty;rt1;rt2])
+	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2])
 		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
 		  ->
 	      begin
@@ -1069,8 +1067,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    let new_rt =
 		      List.fold_left 
 			(fun acc (lhs,rhs) -> 
-			  mkRProd(Anonymous,
-				  mkRApp(mkRRef(eq_as_ref),[mkRHole ();lhs;rhs]),acc)
+			  mkGProd(Anonymous,
+				  mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc)
 			)
 			b
 			l
@@ -1078,7 +1076,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    rebuild_cons env nb_args relname args crossed_types depth new_rt
 		  else raise Continue
 	      with Continue -> 
-		observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+		observe (str "computing new type for prod : " ++ pr_glob_constr 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 =
@@ -1091,10 +1089,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  | 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)
-		  | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	      end
 	    | _ ->
-		observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+		observe (str "computing new type for prod : " ++ pr_glob_constr 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 =
@@ -1107,13 +1105,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  | 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)
-		  | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	end
-    | RLambda(_,n,k,t,b) ->
+    | GLambda(_,n,k,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
-	  observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
+	  observe (str "computing new type for lambda : " ++ pr_glob_constr rt);
 	  let t' = Pretyping.Default.understand Evd.empty env t in
 	  match n with
 	    | Name id ->
@@ -1121,19 +1119,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
-		    (args@[mkRVar id])new_crossed_types
+		    (args@[mkGVar id])new_crossed_types
 		    (depth + 1 ) b
 		in
 		if Idset.mem id id_to_exclude && depth >= nb_args
 		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
+		  GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	    | _ -> anomaly "Should not have an anonymous function here"
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
 
 	end
-    | RLetIn(_,n,t,b) ->
+    | GLetIn(_,n,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let t' = Pretyping.Default.understand Evd.empty env t in
@@ -1147,10 +1145,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	  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),
+	    | _ -> GLetIn(dummy_loc,n,t,new_b),
 		Idset.filter not_free_in_t id_to_exclude
 	end
-    | RLetTuple(_,nal,(na,rto),t,b) ->
+    | GLetTuple(_,nal,(na,rto),t,b) ->
 	assert (rto=None);
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
@@ -1173,22 +1171,22 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 (* 	    | Name id when Idset.mem id id_to_exclude ->  *)
 (* 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
 (* 	    | _ -> *)
-	  RLetTuple(dummy_loc,nal,(na,None),t,new_b),
+	  GLetTuple(dummy_loc,nal,(na,None),t,new_b),
 		Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
 
 	end
 
-    | _ -> mkRApp(mkRVar  relname,args@[rt]),Idset.empty
+    | _ -> mkGApp(mkGVar  relname,args@[rt]),Idset.empty
 
 
 (* debuging wrapper *)
 let rebuild_cons env nb_args relname args crossed_types rt =
-  observe  (str "rebuild_cons : rt := "++ pr_rawconstr rt ++
-		 str "nb_args := " ++ str (string_of_int nb_args));
+(*   observennl  (str "rebuild_cons : rt := "++ pr_glob_constr rt ++  *)
+(* 		 str "nb_args := " ++ str (string_of_int nb_args)); *)
   let res =
     rebuild_cons env nb_args relname args crossed_types 0 rt
   in
-  observe (str " leads to "++ pr_rawconstr (fst res));
+(*   observe (str " leads to "++ pr_glob_constr (fst res)); *)
   res
 
 
@@ -1200,30 +1198,30 @@ let rebuild_cons env nb_args relname args crossed_types rt =
    TODO: Find a valid way to deal with implicit arguments here!
 *)
 let rec compute_cst_params relnames params = function
-  | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
-  | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+  | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params
+  | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames ->
       compute_cst_params_from_app [] (params,rtl)
-  | RApp(_,f,args) ->
+  | GApp(_,f,args) ->
       List.fold_left (compute_cst_params relnames) params (f::args)
-  | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
+  | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) ->
       let t_params = compute_cst_params relnames params t in
       compute_cst_params relnames t_params b
-  | RCases _ ->
+  | GCases _ ->
       params  (* If there is still cases at this point they can only be
 		 discriminitation ones *)
-  | RSort _ -> params
-  | RHole _ -> params
-  | RIf _ | RRec _ | RCast _ | RDynamic _  ->
+  | GSort _ -> params
+  | GHole _ -> params
+  | GIf _ | GRec _ | GCast _ ->
       raise (UserError("compute_cst_params", str "Not handled case"))
 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'
+    | ((Name id,_,is_defined) as param)::params',(GVar(_,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 compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts =
   let rels_params =
     Array.mapi
       (fun i args ->
@@ -1242,7 +1240,7 @@ let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool)
 	   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')
+		n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined')
 	     rels_params
 	   then
 	     l := param::!l
@@ -1261,15 +1259,15 @@ let rec rebuild_return_type rt =
 	Topconstr.CArrow(loc,t,rebuild_return_type t')
     | Topconstr.CLetIn(loc,na,t,t') ->
 	Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
-    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
+    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None))
 
 
 let do_build_inductive
-    funnames (funsargs: (Names.name * rawconstr * bool) list list)
+    funnames (funsargs: (Names.name * glob_constr * bool) list list)
     returned_types
-    (rtl:rawconstr list) =
+    (rtl:glob_constr list) =
   let _time1 = System.get_time () in
-(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
+(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr 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
@@ -1286,7 +1284,7 @@ let do_build_inductive
   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
+	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id))  env
       )
       funnames
       (Global.env ())
@@ -1294,19 +1292,19 @@ let do_build_inductive
   let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in
   let env_with_graphs =
     let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-      let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  =
+      let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list  =
 	funargs
       in
       List.fold_right
 	(fun (n,t,is_defined) acc ->
 	   if is_defined
 	   then
-	     Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+	     Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
 			      acc)
 	   else
 	     Topconstr.CProdN
 	       (dummy_loc,
-		[[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+		[[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
 		acc
 	       )
 	)
@@ -1325,9 +1323,9 @@ let do_build_inductive
   let constr i res =
     List.map
       (function result (* (args',concl') *) ->
-	 let rt = compose_raw_context result.context result.value in
+	 let rt = compose_glob_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; *)
+	 (*  with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *)
 	 fst (
 	   rebuild_cons env_with_graphs nb_args relnames.(i)
 	     []
@@ -1346,7 +1344,7 @@ let do_build_inductive
       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*glob_constr) list =
     next_constructor_id := (-1);
     List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
   in
@@ -1360,19 +1358,19 @@ let do_build_inductive
     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 * Glob_term.glob_constr * bool ) list  =
       (snd (list_chop nrel_params funargs))
     in
     List.fold_right
       (fun (n,t,is_defined) acc ->
 	 if is_defined
 	 then
-	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
 			    acc)
 	 else
 	   Topconstr.CProdN
 	   (dummy_loc,
-	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
 	    acc
 	   )
       )
@@ -1389,10 +1387,10 @@ let do_build_inductive
       (fun (n,t,is_defined) ->
 	 if is_defined
 	 then
-	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
+	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t)
 	 else
 	 Topconstr.LocalRawAssum
-	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
+	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t)
       )
       rels_params
   in
@@ -1402,7 +1400,7 @@ let do_build_inductive
 	 false,((dummy_loc,id),
 		Flags.with_option
 		  Flags.raw_print
-		  (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
+		  (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t)
 	       )
       ))
       (rel_constructors)
@@ -1465,7 +1463,7 @@ let do_build_inductive
 	  str "while trying to define"++ spc () ++
 	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
 	    ++ fnl () ++
-	    Cerrors.explain_exn e
+	    Errors.print e
 	in
  	observe msg;
 	raise e
diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/glob_term_to_relation.mli
index a314050f..5c91292b 100644
--- a/plugins/funind/rawterm_to_relation.mli
+++ b/plugins/funind/glob_term_to_relation.mli
@@ -9,8 +9,8 @@
 
 val build_inductive :
   Names.identifier list -> (* The list of function name *)
-  (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
+  (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
   Topconstr.constr_expr list -> (* The list of function returned type *)
-  Rawterm.rawconstr list -> (* the list of body *)
+  Glob_term.glob_constr list -> (* the list of body *)
   unit
 
diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/glob_termops.ml
index e31f1452..cdd0eaf7 100644
--- a/plugins/funind/rawtermops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,89 +1,89 @@
 open Pp
-open Rawterm
+open Glob_term
 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
+   Some basic functions to rebuild glob_constr
    In each of them the location is Util.dummy_loc
 *)
-let mkRRef ref = RRef(dummy_loc,ref)
-let mkRVar id = RVar(dummy_loc,id)
-let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl)
-let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b)
-let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b)
-let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b)
-let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl)
-let mkRSort s = RSort(dummy_loc,s)
-let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
-let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
+let mkGRef ref = GRef(dummy_loc,ref)
+let mkGVar id = GVar(dummy_loc,id)
+let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl)
+let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b)
+let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b)
+let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b)
+let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl)
+let mkGSort s = GSort(dummy_loc,s)
+let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous)
+let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
 
 (*
-  Some basic functions to decompose rawconstrs
+  Some basic functions to decompose glob_constrs
   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 glob_decompose_prod =
+  let rec glob_decompose_prod args = function
+  | GProd(_,n,k,t,b) ->
+      glob_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
+  glob_decompose_prod []
+
+let glob_decompose_prod_or_letin =
+  let rec glob_decompose_prod args = function
+  | GProd(_,n,k,t,b) ->
+      glob_decompose_prod ((n,None,Some t)::args) b
+  | GLetIn(_,n,t,b) ->
+      glob_decompose_prod ((n,Some t,None)::args) b
   | rt -> args,rt
   in
-  raw_decompose_prod []
+  glob_decompose_prod []
 
-let raw_compose_prod =
-  List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
+let glob_compose_prod =
+  List.fold_left (fun b (n,t) -> mkGProd(n,t,b))
 
-let raw_compose_prod_or_letin =
+let glob_compose_prod_or_letin =
   List.fold_left (
       fun concl decl ->
 	match decl with
-	  | (n,None,Some t) -> mkRProd(n,t,concl)
-	  | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
+	  | (n,None,Some t) -> mkGProd(n,t,concl)
+	  | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl)
 	  | _ -> assert false)
 
-let raw_decompose_prod_n n =
-  let rec raw_decompose_prod i args c =
+let glob_decompose_prod_n n =
+  let rec glob_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
+	| GProd(_,n,_,t,b) ->
+	    glob_decompose_prod (i-1) ((n,t)::args) b
 	| rt -> args,rt
   in
-  raw_decompose_prod n []
+  glob_decompose_prod n []
 
 
-let raw_decompose_prod_or_letin_n n =
-  let rec raw_decompose_prod i args c =
+let glob_decompose_prod_or_letin_n n =
+  let rec glob_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
+	| GProd(_,n,_,t,b) ->
+	    glob_decompose_prod (i-1) ((n,None,Some t)::args) b
+	| GLetIn(_,n,t,b) ->
+	    glob_decompose_prod (i-1) ((n,Some t,None)::args) b
 	| rt -> args,rt
   in
-  raw_decompose_prod n []
+  glob_decompose_prod n []
 
 
-let raw_decompose_app =
+let glob_decompose_app =
   let rec decompose_rapp acc rt =
-(*     msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
+(*     msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *)
     match rt with
-    | RApp(_,rt,rtl) ->
+    | GApp(_,rt,rtl) ->
 	decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
     | rt -> rt,List.rev acc
   in
@@ -92,24 +92,24 @@ let raw_decompose_app =
 
 
 
-(* [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])
+(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *)
+let glob_make_eq ?(typ= mkGHole ()) t1 t2  =
+  mkGApp(mkGRef (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 =
-  mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
+(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *)
+let glob_make_neq t1 t2 =
+  mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2])
 
-(* [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])
+(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
+let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
 
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
    to [P1 \/ ( .... \/ Pn)]
 *)
-let rec raw_make_or_list = function
+let rec glob_make_or_list = function
   | [] -> raise (Invalid_argument "mk_or")
   | [e] -> e
-  | e::l -> raw_make_or e (raw_make_or_list l)
+  | e::l -> glob_make_or e (glob_make_or_list l)
 
 
 let remove_name_from_mapping mapping na =
@@ -120,70 +120,69 @@ let remove_name_from_mapping mapping na =
 let change_vars =
   let rec change_vars mapping rt =
     match rt with
-      | RRef _ -> rt
-      | RVar(loc,id) ->
+      | GRef _ -> rt
+      | GVar(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) ->
-	  RApp(loc,
+	  GVar(loc,new_id)
+      | GEvar _ -> rt
+      | GPatVar _ -> rt
+      | GApp(loc,rt',rtl) ->
+	  GApp(loc,
 	       change_vars mapping rt',
 	       List.map (change_vars mapping) rtl
 	      )
-      | RLambda(loc,name,k,t,b) ->
-	  RLambda(loc,
+      | GLambda(loc,name,k,t,b) ->
+	  GLambda(loc,
 		  name,
 		  k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | RProd(loc,name,k,t,b) ->
-	  RProd(loc,
+      | GProd(loc,name,k,t,b) ->
+	  GProd(loc,
 		  name,
 	          k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | RLetIn(loc,name,def,b) ->
-	  RLetIn(loc,
+      | GLetIn(loc,name,def,b) ->
+	  GLetIn(loc,
 		 name,
 		 change_vars mapping def,
 		 change_vars (remove_name_from_mapping mapping name) b
 		)
-      | RLetTuple(loc,nal,(na,rto),b,e) ->
+      | GLetTuple(loc,nal,(na,rto),b,e) ->
 	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
-	  RLetTuple(loc,
+	  GLetTuple(loc,
 		    nal,
 		    (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,
+      | GCases(loc,sty,infos,el,brl) ->
+	  GCases(loc,sty,
 		 infos,
 		 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,
+      | GIf(loc,b,(na,e_option),lhs,rhs) ->
+	  GIf(loc,
 	      change_vars mapping b,
 	      (na,Option.map (change_vars mapping) e_option),
 	      change_vars mapping lhs,
 	      change_vars mapping rhs
 	     )
-      | RRec _ -> error "Local (co)fixes are not supported"
-      | 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,change_vars mapping b,CastCoerce)
-      | RDynamic _ -> error "Not handled RDynamic"
+      | GRec _ -> error "Local (co)fixes are not supported"
+      | GSort _ -> rt
+      | GHole _ -> rt
+      | GCast(loc,b,CastConv (k,t)) ->
+	  GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
+      | GCast(loc,b,CastCoerce) ->
+	  GCast(loc,change_vars mapping b,CastCoerce)
   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
@@ -262,22 +261,22 @@ let get_pattern_id pat = raw_get_pattern_id pat []
 let rec alpha_rt excluded rt =
   let new_rt =
     match rt with
-      | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
-      | RLambda(loc,Anonymous,k,t,b) ->
+      | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt
+      | GLambda(loc,Anonymous,k,t,b) ->
 	  let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
 	  let new_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) ->
+	  GLambda(loc,Name new_id,k,new_t,new_b)
+      | GProd(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) ->
+	GProd(loc,Anonymous,k,new_t,new_b)
+    | GLetIn(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) ->
+	GLetIn(loc,Anonymous,new_t,new_b)
+    | GLambda(loc,Name id,k,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
 	  if new_id = id
@@ -289,8 +288,8 @@ let rec alpha_rt excluded rt =
 	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) ->
+	GLambda(loc,Name new_id,k,new_t,new_b)
+    | GProd(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 =
@@ -302,8 +301,8 @@ let rec alpha_rt excluded rt =
 	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) ->
+	GProd(loc,Name new_id,k,new_t,new_b)
+    | GLetIn(loc,Name id,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
 	  if new_id = id
@@ -315,10 +314,10 @@ let rec alpha_rt excluded rt =
 	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)
+	GLetIn(loc,Name new_id,new_t,new_b)
 
 
-    | RLetTuple(loc,nal,(na,rto),t,b) ->
+    | GLetTuple(loc,nal,(na,rto),t,b) ->
 	let rev_new_nal,new_excluded,mapping =
 	  List.fold_left
 	    (fun (nal,excluded,mapping) na ->
@@ -345,28 +344,27 @@ let rec alpha_rt excluded rt =
 	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) ->
+	GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
+    | GCases(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,
+	GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
+    | GIf(loc,b,(na,e_o),lhs,rhs) ->
+	GIf(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)) ->
-	RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
-    | RCast (loc,b,CastCoerce) ->
-	RCast(loc,alpha_rt excluded b,CastCoerce)
-    | RDynamic _ -> error "Not handled RDynamic"
-    | RApp(loc,f,args) ->
-	RApp(loc,
+    | GRec _ -> error "Not handled GRec"
+    | GSort _ -> rt
+    | GHole _ -> rt
+    | GCast (loc,b,CastConv (k,t)) ->
+	GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
+    | GCast (loc,b,CastCoerce) ->
+	GCast(loc,alpha_rt excluded b,CastCoerce)
+    | GApp(loc,f,args) ->
+	GApp(loc,
 	     alpha_rt excluded f,
 	     List.map (alpha_rt excluded) args
 	    )
@@ -386,35 +384,34 @@ and alpha_br excluded (loc,ids,patl,res) =
 *)
 let is_free_in id =
   let rec is_free_in = function
-    | RRef _ ->  false
-    | RVar(_,id') -> id_ord id' id == 0
-    | REvar _ -> false
-    | RPatVar _ -> false
-    | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
-    | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) ->
+    | GRef _ ->  false
+    | GVar(_,id') -> id_ord id' id == 0
+    | GEvar _ -> false
+    | GPatVar _ -> false
+    | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
+    | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) ->
 	let check_in_b =
 	  match n with
 	    | Name id' -> id_ord id' id <> 0
 	    | _ -> true
 	in
 	is_free_in t || (check_in_b && is_free_in b)
-    | RCases(_,_,_,el,brl) ->
+    | GCases(_,_,_,el,brl) ->
 	(List.exists (fun (e,_) -> is_free_in e) el) ||
 	  List.exists is_free_in_br brl
-    | RLetTuple(_,nal,_,b,t) ->
+    | GLetTuple(_,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) ->
+    | GIf(_,cond,_,br1,br2) ->
 	is_free_in cond || is_free_in br1 || is_free_in br2
-    | RRec _ -> raise (UserError("",str "Not handled RRec"))
-    | RSort _ -> false
-    | RHole _ -> false
-    | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
-    | RCast (_,b,CastCoerce) -> is_free_in b
-    | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+    | GRec _ -> raise (UserError("",str "Not handled GRec"))
+    | GSort _ -> false
+    | GHole _ -> false
+    | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
+    | GCast (_,b,CastCoerce) -> is_free_in b
   and is_free_in_br (_,ids,_,rt) =
     (not (List.mem id ids)) && is_free_in rt
   in
@@ -425,7 +422,7 @@ let is_free_in id =
 let rec pattern_to_term  = function
   | PatVar(loc,Anonymous) -> assert false
   | PatVar(loc,Name id) ->
-	mkRVar id
+	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
 	Inductiveops.mis_constructor_nargs_env
@@ -436,13 +433,13 @@ let rec pattern_to_term  = function
 	Array.to_list
 	  (Array.init
 	     (cst_narg - List.length patternl)
-	     (fun _ -> mkRHole ())
+	     (fun _ -> mkGHole ())
 	  )
       in
       let patl_as_term =
 	List.map pattern_to_term patternl
       in
-      mkRApp(mkRRef(Libnames.ConstructRef constr),
+      mkGApp(mkGRef(Libnames.ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
 
@@ -451,69 +448,68 @@ let rec pattern_to_term  = function
 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) ->
-	  RApp(loc,
+      | GRef _ -> rt
+      | GVar(_,id) when id_ord id x_id == 0 -> term
+      | GVar _ -> rt
+      | GEvar _ -> rt
+      | GPatVar _ -> rt
+      | GApp(loc,rt',rtl) ->
+	  GApp(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,
+      | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GLambda(loc,name,k,t,b) ->
+	  GLambda(loc,
 		  name,
 		  k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
-      | RProd(loc,name,k,t,b) ->
-	  RProd(loc,
+      | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GProd(loc,name,k,t,b) ->
+	  GProd(loc,
 		  name,
 	          k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
-      | RLetIn(loc,name,def,b) ->
-	  RLetIn(loc,
+      | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | GLetIn(loc,name,def,b) ->
+	  GLetIn(loc,
 		 name,
 		 replace_var_by_pattern def,
 		 replace_var_by_pattern b
 		)
-      | RLetTuple(_,nal,_,_,_)
+      | GLetTuple(_,nal,_,_,_)
 	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->
 	  rt
-      | RLetTuple(loc,nal,(na,rto),def,b) ->
-	  RLetTuple(loc,
+      | GLetTuple(loc,nal,(na,rto),def,b) ->
+	  GLetTuple(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,
+      | GCases(loc,sty,infos,el,brl) ->
+	  GCases(loc,sty,
 		 infos,
 		 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, replace_var_by_pattern b,
+      | GIf(loc,b,(na,e_option),lhs,rhs) ->
+	  GIf(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)) ->
-	  RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
-      | RCast(loc,b,CastCoerce) ->
-	  RCast(loc,replace_var_by_pattern b,CastCoerce)
-      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+      | GRec _ -> raise (UserError("",str "Not handled GRec"))
+      | GSort _ -> rt
+      | GHole _ -> rt
+      | GCast(loc,b,CastConv(k,t)) ->
+	  GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
+      | GCast(loc,b,CastCoerce) ->
+	  GCast(loc,replace_var_by_pattern b,CastCoerce)
   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
@@ -586,28 +582,28 @@ let id_of_name = function
   | Names.Name x -> x
 
 (* TODO: finish Rec caes *)
-let ids_of_rawterm c =
-  let rec ids_of_rawterm acc c =
+let ids_of_glob_constr c =
+  let rec ids_of_glob_constr acc c =
     let idof = id_of_name in
     match c with
-      | RVar (_,id) -> id::acc
-      | 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
-      | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
-      | 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) ->
-          List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
-      | 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 _) -> []
+      | GVar (_,id) -> id::acc
+      | GApp (loc,g,args) ->
+          ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc
+      | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
+      | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
+      | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
+      | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
+      | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc
+      | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
+      | GLetTuple (_,nal,(na,po),b,c) ->
+          List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
+      | GCases (loc,sty,rtntypopt,tml,brchl) ->
+	  List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl)
+      | GRec _ -> failwith "Fix inside a constructor branch"
+      | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
   in
   (* build the set *)
-  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
+  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c)
 
 
 
@@ -616,59 +612,58 @@ let 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) ->
-	  RApp(loc,
+      | GRef _ -> rt
+      | GVar _ -> rt
+      | GEvar _ -> rt
+      | GPatVar _ -> rt
+      | GApp(loc,rt',rtl) ->
+	  GApp(loc,
 	       zeta_normalize_term rt',
 	       List.map zeta_normalize_term rtl
 	      )
-      | RLambda(loc,name,k,t,b) ->
-	  RLambda(loc,
+      | GLambda(loc,name,k,t,b) ->
+	  GLambda(loc,
 		  name,
 		  k,
 		  zeta_normalize_term t,
 		  zeta_normalize_term b
 		 )
-      | RProd(loc,name,k,t,b) ->
-	  RProd(loc,
+      | GProd(loc,name,k,t,b) ->
+	  GProd(loc,
 		name,
 	        k,
 		zeta_normalize_term t,
 		zeta_normalize_term b
 		 )
-      | RLetIn(_,Name id,def,b) ->
+      | GLetIn(_,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,
+      | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
+      | GLetTuple(loc,nal,(na,rto),def,b) ->
+	  GLetTuple(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,
+      | GCases(loc,sty,infos,el,brl) ->
+	  GCases(loc,sty,
 		 infos,
 		 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, zeta_normalize_term b,
+      | GIf(loc,b,(na,e_option),lhs,rhs) ->
+	  GIf(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)) ->
-	  RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
-      | RCast(loc,b,CastCoerce) ->
-	  RCast(loc,zeta_normalize_term b,CastCoerce)
-      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+      | GRec _ -> raise (UserError("",str "Not handled GRec"))
+      | GSort _ -> rt
+      | GHole _ -> rt
+      | GCast(loc,b,CastConv(k,t)) ->
+	  GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
+      | GCast(loc,b,CastCoerce) ->
+	  GCast(loc,zeta_normalize_term b,CastCoerce)
   and zeta_normalize_br (loc,idl,patl,res) =
     (loc,idl,patl,zeta_normalize_term res)
   in
@@ -688,29 +683,28 @@ let expand_as =
   in
   let rec expand_as map rt =
     match rt with
-      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
-      | RVar(_,id) ->
+      | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt
+      | GVar(_,id) ->
 	  begin
 	    try
 	      Idmap.find id map
 	    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)
-      | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b)
-      | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
-      | RLetTuple(loc,nal,(na,po),v,b) ->
-	  RLetTuple(loc,nal,(na,Option.map (expand_as map) po),
+      | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args)
+      | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b)
+      | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b)
+      | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b)
+      | GLetTuple(loc,nal,(na,po),v,b) ->
+	  GLetTuple(loc,nal,(na,Option.map (expand_as map) po),
 		    expand_as map v, expand_as map b)
-      | RIf(loc,e,(na,po),br1,br2) ->
-	  RIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
+      | GIf(loc,e,(na,po),br1,br2) ->
+	  GIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
 	      expand_as map br1, expand_as map br2)
-      | RRec _ ->  error "Not handled RRec"
-      | RDynamic _ -> error "Not handled RDynamic"
-      | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t))
-      | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce)
-      | 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,
+      | GRec _ ->  error "Not handled GRec"
+      | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t))
+      | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce)
+      | GCases(loc,sty,po,el,brl) ->
+	  GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
   and expand_as_br map (loc,idl,cpl,rt) =
     (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli
new file mode 100644
index 00000000..bfd15357
--- /dev/null
+++ b/plugins/funind/glob_termops.mli
@@ -0,0 +1,126 @@
+open Glob_term
+
+(* Ocaml 3.06 Map.S does not handle is_empty *)
+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 glob_constr corresponding to [pat].
+   [pat] must not contain occurences of anonymous pattern
+*)
+val pattern_to_term : cases_pattern -> glob_constr
+
+(*
+   Some basic functions to rebuild glob_constr
+   In each of them the location is Util.dummy_loc
+*)
+val mkGRef : Libnames.global_reference -> glob_constr
+val mkGVar : Names.identifier -> glob_constr
+val mkGApp  : glob_constr*(glob_constr list) -> glob_constr
+val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr
+val mkGSort : glob_sort -> glob_constr
+val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *)
+val mkGCast : glob_constr* glob_constr -> glob_constr
+(*
+  Some basic functions to decompose glob_constrs
+  These are analogous to the ones constrs
+*)
+val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod_or_letin :
+  glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr
+val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod_or_letin_n : int -> glob_constr ->
+  (Names.name*glob_constr option*glob_constr option) list * glob_constr
+val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list  ->  glob_constr
+val glob_compose_prod_or_letin: glob_constr ->
+  (Names.name*glob_constr option*glob_constr option) list  ->  glob_constr
+val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
+
+
+(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *)
+val  glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr
+(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *)
+val  glob_make_neq : glob_constr -> glob_constr -> glob_constr
+(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
+val  glob_make_or : glob_constr -> glob_constr -> glob_constr
+
+(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
+   to [P1 \/ ( .... \/ Pn)]
+*)
+val  glob_make_or_list : glob_constr list -> glob_constr
+
+
+(* alpha_conversion functions *)
+
+
+
+(* Replace the var mapped in the glob_constr/context *)
+val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
+
+
+
+(* [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
+   [avoid] with the variables appearing in the result.
+*)
+  val alpha_pat :
+    Names.Idmap.key list ->
+    Glob_term.cases_pattern ->
+    Glob_term.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
+*)
+val alpha_rt : Names.identifier list -> glob_constr -> glob_constr
+
+(* same as alpha_rt but for case branches *)
+val alpha_br : Names.identifier list ->
+    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+    Glob_term.glob_constr ->
+    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+    Glob_term.glob_constr
+
+
+(* Reduction function *)
+val replace_var_by_term  :
+  Names.identifier ->
+  Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr
+
+
+
+(*
+   [is_free_in id rt] checks if [id] is a free variable in [rt]
+*)
+val is_free_in : Names.identifier -> glob_constr -> 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
+*)
+val   ids_of_pat : cases_pattern -> Names.Idset.t
+
+(* TODO: finish this function (Fix not treated) *)
+val ids_of_glob_constr: glob_constr -> Names.Idset.t
+
+(*
+   removing let_in construction in a glob_constr
+*)
+val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr
+
+
+val expand_as : glob_constr -> glob_constr
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index a61671f8..8caeca57 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -4,7 +4,7 @@ open Term
 open Pp
 open Indfun_common
 open Libnames
-open Rawterm
+open Glob_term
 open Declarations
 
 let is_rec_info scheme_info =
@@ -19,13 +19,11 @@ let is_rec_info scheme_info =
   in
   Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
 
-
 let choose_dest_or_ind scheme_info =
     if is_rec_info scheme_info
     then Tactics.new_induct false
     else Tactics.new_destruct false
 
-
 let functional_induction with_clean c princl pat =
   Dumpglob.pause ();
   let res = let f,args = decompose_app c in
@@ -65,9 +63,8 @@ let functional_induction with_clean c princl pat =
 			  errorlabstrm "" (str "Cannot find induction principle for "
 					   ++Printer.pr_lconstr (mkConst c') )
 		    in
-		    (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
+		    (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ)
 		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
-
 	    end
 	| Some ((princ,binding)) ->
 	    princ,binding,Tacmach.pf_type_of g princ
@@ -78,7 +75,7 @@ let functional_induction with_clean c princl pat =
 	if princ_infos.Tactics.farg_in_concl
 	then [c] else []
       in
-      List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
+      List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list)
     in
     let princ' = Some (princ,bindings) in
     let princ_vars =
@@ -104,9 +101,9 @@ let functional_induction with_clean c princl pat =
 	    (Tacmach.pf_ids_of_hyps g)
 	in
 	let flag =
-	  Rawterm.Cbv
-	    {Rawterm.all_flags
-	     with Rawterm.rDelta = false;
+	  Glob_term.Cbv
+	    {Glob_term.all_flags
+	     with Glob_term.rDelta = false;
 	    }
 	in
 	Tacticals.tclTHEN
@@ -114,7 +111,6 @@ let functional_induction with_clean c princl pat =
 	  (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
 	  g
       else Tacticals.tclIDTAC g
-
     in
     Tacticals.tclTHEN
       (choose_dest_or_ind
@@ -129,56 +125,43 @@ let functional_induction with_clean c princl pat =
     Dumpglob.continue ();
     res
 
-
-
-
-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
-
-
-type newfixpoint_expr =
-    identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr
-
-let rec abstract_rawconstr c = function
+let rec abstract_glob_constr c = function
   | [] -> c
-  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl)
+  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl)
   | Topconstr.LocalRawAssum (idl,k,t)::bl ->
       List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl
-        (abstract_rawconstr c bl)
+        (abstract_glob_constr c bl)
 
 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
     ~allow_patvar:false  ~ltacvars:([],[]) c
 
-
 (*
-   Construct a fixpoint as a Rawterm
+   Construct a fixpoint as a Glob_term
    and not as a constr
 *)
+
 let build_newrecursive
-(lnameargsardef)  =
+    lnameargsardef  =
   let env0 = Global.env()
   and sigma = Evd.empty
   in
   let (rec_sign,rec_impls) =
     List.fold_left
-      (fun (env,impls) ((_,recname),_,bl,arityc,_) ->
+      (fun (env,impls) ((_,recname),bl,arityc,_) ->
         let arityc = Topconstr.prod_constr_expr arityc bl in
         let arity = Constrintern.interp_type sigma env0 arityc in
 	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
-        (Environ.push_named (recname,None,arity) env, (recname, impl) :: impls))
-      (env0,[]) lnameargsardef in
+        (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls))
+      (env0,Constrintern.empty_internalization_env) lnameargsardef in
   let recdef =
     (* Declare local notations *)
     let fs = States.freeze() in
     let def =
       try
 	List.map
-	  (fun (_,_,bl,_,def)  ->
-             let def = abstract_rawconstr def bl in
+	  (fun (_,bl,_,def)  ->
+             let def = abstract_glob_constr def bl in
              interp_casted_constr_with_implicits
 	       sigma rec_sign rec_impls def
 	  )
@@ -189,34 +172,31 @@ let build_newrecursive
   in
   recdef,rec_impls
 
-
-let compute_annot (name,annot,args,types,body) =
-  let names = List.map snd (Topconstr.names_of_local_assums args) in
-  match annot with
-    | None ->
-        if List.length names > 1 then
-          user_err_loc
-            (dummy_loc,"Function",
-             Pp.str "the recursive argument needs to be specified");
-        let new_annot = (id_of_name (List.hd names)) in
-	(name,Struct new_annot,args,types,body)
-    | Some r -> (name,r,args,types,body)
-
+let build_newrecursive l = 
+  let l' = List.map 
+    (fun ((fixna,_,bll,ar,body_opt),lnot) -> 
+       match body_opt with 
+	 | Some body -> 
+	     (fixna,bll,ar,body)
+	 | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given")
+    ) l
+  in
+  build_newrecursive l'
 
 (* Checks whether or not the mutual bloc is recursive *)
 let rec is_rec names =
   let names = List.fold_right Idset.add names Idset.empty in
   let check_id id names =  Idset.mem id names in
   let 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) ->
+    | GVar(_,id) -> check_id id names
+    | GRef _ | GEvar _ | GPatVar _ | GSort _ |  GHole _ -> false
+    | GCast(_,b,_) -> lookup names b
+    | GRec _ -> error "GRec not handled"
+    | GIf(_,b,_,lhs,rhs) ->
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
-    | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b)  ->
+    | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b)  ->
 	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
-    | RLetTuple(_,nal,_,t,b) -> lookup names t ||
+    | GLetTuple(_,nal,_,t,b) -> lookup names t ||
 	lookup
 	  (List.fold_left
 	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
@@ -224,8 +204,8 @@ let rec is_rec names =
 	     nal
 	  )
 	  b
-    | RApp(_,f,args) -> List.exists (lookup names) (f::args)
-    | RCases(_,_,_,el,brl) ->
+    | GApp(_,f,args) -> List.exists (lookup names) (f::args)
+    | GCases(_,_,_,el,brl) ->
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
   and lookup_br names (_,idl,_,rt) =
@@ -240,9 +220,9 @@ let rec local_binders_length = function
   | 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 prepare_body ((name,_,args,types,_),_) 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); *)
+(*   Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *)
   let fun_args,rt' = chop_rlambda_n n rt in
   (fun_args,rt')
 
@@ -251,7 +231,7 @@ let derive_inversion fix_names =
   try
     (* we first transform the fix_names identifier into their corresponding constant *)
     let fix_names_as_constant =
-      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names
+      List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names
     in
     (*
        Then we check that the graphs have been defined
@@ -268,20 +248,22 @@ let derive_inversion fix_names =
 	  Ensures by : register_built
 	  i*)
 	(List.map
-	   (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
+	   (fun id -> destInd (Constrintern.global_reference (mk_rel_id id)))
 	   fix_names
 	)
     with e ->
+      let e' = Cerrors.process_vernac_interp_error e in
       msg_warning
-	(str "Cannot built inversion information" ++
-	   if do_observe () then Cerrors.explain_exn e else mt ())
+	(str "Cannot build inversion information" ++
+	   if do_observe () then (fnl() ++ Errors.print e') else mt ())
   with _ -> ()
 
 let warning_error names e =
+  let e = Cerrors.process_vernac_interp_error e in
   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 ()
+      | ToShow e -> spc () ++ Errors.print e
+      | _ -> if do_observe () then (spc () ++ Errors.print e) else mt ()
   in
   match e with
     | Building_graph e ->
@@ -297,10 +279,11 @@ let warning_error names e =
     | _ -> raise e
 
 let error_error names e =
+  let e = Cerrors.process_vernac_interp_error e in
   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 ()
+      | ToShow e -> spc () ++ Errors.print e
+      | _ -> if do_observe () then (spc () ++ Errors.print e) else mt ()
   in
   match e with
     | Building_graph e ->
@@ -311,16 +294,16 @@ let error_error names e =
     | _ -> raise e
 
 let generate_principle  on_error
-    is_general do_built fix_rec_l recdefs  interactive_proof
+    is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs  interactive_proof
     (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
       Tacmach.tactic) : unit =
-  let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in
+  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
+  let funs_types =  List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in
   try
     (* We then register the Inductive graphs of the functions  *)
-    Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
+    Glob_term_to_relation.build_inductive names funs_args funs_types recdefs;
     if do_built
     then
       begin
@@ -334,7 +317,7 @@ let generate_principle  on_error
 		 locate_ind
 		 f_R_mut)
 	in
-	let fname_kn (fname,_,_,_,_) =
+	let fname_kn ((fname,_,_,_,_),_) =
 	  let f_ref = Ident fname in
 	  locate_with_msg
 	    (pr_reference f_ref++str ": Not an inductive type!")
@@ -366,21 +349,18 @@ let generate_principle  on_error
   with e ->
     on_error names e
 
-let register_struct is_rec fixpoint_exprl =
+let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
   match fixpoint_exprl with
     | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
+      let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
 	let ce,imps =
-	  Command.interp_definition
-	    (Flags.boxed_definitions ()) bl None body (Some ret_type)
+	  Command.interp_definition bl None body (Some ret_type)
 	in
 	Command.declare_definition
 	  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())
+	Command.do_fixpoint fixpoint_exprl
 
 let generate_correction_proof_wf f_ref tcc_lemma_ref
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
@@ -402,8 +382,8 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
     in
     match wf_arg with
       | None ->
-	  if List.length names = 1 then 1
-	  else error "Recursive argument must be specified"
+	if List.length names = 1 then 1
+	else error "Recursive argument must be specified"
       | Some wf_arg ->
 	  list_index (Name wf_arg) names
   in
@@ -447,7 +427,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
     using_lemmas
 
 
-let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body =
+let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body =
   let wf_arg_type,wf_arg =
     match wf_arg with
       | None ->
@@ -473,28 +453,186 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
 	      | _ -> 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_path
-      (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
-  in
-  let fun_from_mes =
-    let applied_mes =
-      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
-  in
-  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)
+  let wf_rel_from_mes,is_mes = 
+    match wf_rel_expr_opt with 
+      | None ->
+	  let ltof =
+	    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
+	    Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
+			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
+	  in
+	  let fun_from_mes =
+	    let applied_mes =
+	      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
+	    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
+	  in
+	  let wf_rel_from_mes =
+	    Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
+	  in
+	  wf_rel_from_mes,true
+      | Some wf_rel_expr -> 
+	  let wf_rel_with_mes = 
+	    let a = Names.id_of_string "___a" in 
+	    let b = Names.id_of_string "___b" in 
+	    Topconstr.mkLambdaC(
+	      [dummy_loc,Name a;dummy_loc,Name b],
+	      Topconstr.Default Lib.Explicit,
+	      wf_arg_type,
+	      Topconstr.mkAppC(wf_rel_expr,
+			       [
+				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]);
+				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b])
+			       ])
+			      )
+	  in
+	  wf_rel_with_mes,false
+  in			       
+  register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg)
     using_lemmas args ret_type body
 
+let map_option f = function 
+  | None -> None 
+  | Some v -> Some (f v)
+    
+let decompose_lambda_n_assum_constr_expr = 
+  let rec decompose_lambda_n_assum_constr_expr acc n e = 
+  if n = 0 then (List.rev acc,e)
+  else
+    match e with 
+      | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e'
+      | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
+	let nal_length = List.length nal in 
+	if nal_length <= n 
+	then
+	  decompose_lambda_n_assum_constr_expr 
+	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
+	    (n - nal_length) 
+	    (Topconstr.CLambdaN(lambda_loc,bl,e')) 
+  	else
+	  let nal_keep,nal_expr = list_chop n nal in 
+	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
+	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
+	  )
+      | Topconstr.CLetIn(_, na,nav,e') -> 
+	decompose_lambda_n_assum_constr_expr 
+	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
+      | _ -> error "Not enough product or assumption"
+  in
+  decompose_lambda_n_assum_constr_expr []
+
+let decompose_prod_n_assum_constr_expr = 
+  let rec decompose_prod_n_assum_constr_expr acc n e = 
+    (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *)
+    (* 		str "e := " ++ Ppconstr.pr_lconstr_expr e); *)
+  if n = 0 then 
+    (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in  *)
+      (List.rev acc,e)
+  else
+    match e with 
+      | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e'
+      | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
+	let nal_length = List.length nal in 
+	if nal_length <= n 
+	then
+	  (* let _ = Pp.msgnl (str "first case") in  *)
+	  decompose_prod_n_assum_constr_expr 
+	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
+	    (n - nal_length) 
+	    (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e')))
+  	else
+	  (* let _ = Pp.msgnl (str "second case") in  *)
+	  let nal_keep,nal_expr = list_chop n nal in 
+	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
+	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
+	  )
+      | Topconstr.CArrow(_,premisse,concl) -> 
+	(* let _ = Pp.msgnl (str "arrow case") in  *)
+	decompose_prod_n_assum_constr_expr 
+	  (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous],
+				   Topconstr.Default Lib.Explicit,premisse)
+	  ::acc)
+	  (pred n)
+	  concl
+      | Topconstr.CLetIn(_, na,nav,e') -> 
+	decompose_prod_n_assum_constr_expr 
+	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
+      | _ -> error "Not enough product or assumption"
+  in
+  decompose_prod_n_assum_constr_expr []
 
-let do_generate_principle on_error register_built interactive_proof fixpoint_exprl  =
-  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+open Topconstr
+    
+let id_of_name = function 
+  | Name id -> id 
+  | _ -> assert false
+
+ let rec rebuild_bl (aux,assoc) bl typ = 
+	match bl,typ with 
+	  | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc)
+	  | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> 
+	     rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ
+	  | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') ->
+	    rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
+	      bl' typ'
+	  | _ -> assert false
+      and rebuild_nal (aux,assoc) bk bl' nal lnal typ = 
+	match nal,typ with 
+	  | [], _ -> rebuild_bl (aux,assoc) bl' typ
+	  | na::nal,CArrow(_,nat,typ') -> 
+	    rebuild_nal 
+	      ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) 
+	      bk bl' nal (pred lnal) typ'
+	  | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ
+	  | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> 
+	    let lnal' = List.length nal' in 
+	    if lnal' >= lnal 
+	    then 
+	      let old_nal',new_nal' = list_chop lnal nal' in 
+	      rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal'))  (List.map id_of_name (List.map snd nal))) assoc)) bl' 
+		(if new_nal' = [] && rest = []
+		 then  typ' 
+		 else if new_nal' = [] 
+		 then CProdN(dummy_loc,rest,typ')
+		 else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ'))
+	    else 
+	      let captured_nal,non_captured_nal = list_chop lnal' nal in 
+	      rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc))
+		bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ'))
+	  | _ -> assert false
+
+let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ
+
+let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = 
+  let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in
+  let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in
+  let constr_expr_typel = 
+    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in 
+  let fixpoint_exprl_with_new_bl = 
+    List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> 
+     
+      let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in 
+      (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
+    )
+      fixpoint_exprl constr_expr_typel 
+  in 
+  fixpoint_exprl_with_new_bl
+  
+
+let do_generate_principle on_error register_built interactive_proof
+    (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit =
+  List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl;
   let _is_struct =
     match fixpoint_exprl with
-      | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
+      | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
+ 	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
+	    match recompute_binder_list [fixpoint_expr] with 
+	      | [e] -> e
+	      | _ -> assert false
+	  in 
+	  let fixpoint_exprl = [fixpoint_expr] in 
+	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
+	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+	  let using_lemmas = [] in 
 	  let pre_hook =
 	    generate_principle
 	      on_error
@@ -505,9 +643,18 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	      true
 	  in
 	  if register_built
-	  then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
+	  then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook;
 	  false
-      | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
+      |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
+ 	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
+	    match recompute_binder_list [fixpoint_expr] with 
+	      | [e] -> e
+	      | _ -> assert false
+	  in 
+	  let fixpoint_exprl = [fixpoint_expr] in 
+	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+	  let using_lemmas = [] in
+	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
 	  let pre_hook =
 	    generate_principle
 	      on_error
@@ -518,56 +665,35 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	      true
 	  in
 	  if register_built
-	  then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
+	  then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook;
 	  true
       | _ ->
-	  let fix_names =
-	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
-	  in
-	  let is_one_rec = is_rec fix_names  in
-	  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),([]: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
-		       let loc, na = List.hd names in
-			 (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body),
-		     ([]: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
+	  List.iter (function ((_na,(_,ord),_args,_body,_type),_not) ->
+		       match ord with 
+			 | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> 
+			     error
+			       ("Cannot use mutual definition with well-founded recursion or measure")
+			 | _ -> ()
+		    )
+	    fixpoint_exprl;
+	let fixpoint_exprl = recompute_binder_list fixpoint_exprl in 
+	let fix_names =
+	  List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl
+	in
 	  (* 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;
-	  generate_principle
-	    on_error
-	    false
-	    register_built
-	    fixpoint_exprl
-	    recdefs
-	    interactive_proof
-	    (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
-	  if register_built then derive_inversion fix_names;
-	  true;
+  	let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+	let is_rec = List.exists (is_rec fix_names) recdefs in
+	if register_built then register_struct is_rec fixpoint_exprl;
+	generate_principle
+	  on_error
+	  false
+	  register_built
+	  fixpoint_exprl
+	  recdefs
+	  interactive_proof
+	  (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
+	if register_built then derive_inversion fix_names;
+	true; 
   in
   ()
 
@@ -638,7 +764,6 @@ let rec add_args id new_args b =
   | CGeneralization _ -> anomaly "add_args : CGeneralization"
   | CPrim _ -> b
   | CDelimiters _ -> anomaly "add_args : CDelimiters"
-  | CDynamic _ -> anomaly "add_args : CDynamic"
 exception Stop of  Topconstr.constr_expr
 
 
@@ -701,75 +826,71 @@ let rec get_args b t : Topconstr.local_binder list *
 
 
 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 ->
-	      raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
-	    end
-	| _ -> raise (UserError ("", str "Not a function reference") )
-
+  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
-   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,
-		Constrextern.extern_type false env
-                  (Typeops.type_of_constant_type env c_body.const_type)
-	       )
-	    )
-	    ()
-	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 =
-		  List.map
-		    (fun (id,(n,recexp),bl,t,b) ->
-		       let loc, rec_id = Option.get n in
-		       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)))
-				       nal
-			      )
-			      nal_tas
-			   )
-		       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
-		[((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);
+  Dumpglob.pause ();
+  (match body_of_constant c_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,
+		 Constrextern.extern_type false env
+                   (Typeops.type_of_constant_type env c_body.const_type)
+		)
+	     )
+	     ()
+	 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 =
+		   List.map
+		     (fun (id,(n,recexp),bl,t,b) ->
+			let loc, rec_id = Option.get n in
+			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)))
+					nal
+			       )
+			       nal_tas
+			    )
+			in
+			let b' = add_args (snd id) new_args b in
+			(((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
+		     )
+		     fixexprl
+		 in
+		 l
+	     | _ ->
+		 let id = id_of_label (con_label c) in
+		 [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]]
+	 in
+	 do_generate_principle error_error false false expr_list;
+	 (* We register the infos *)
+	 let mp,dp,_ = repr_con c in
+	 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
 
 
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
new file mode 100644
index 00000000..e65b5808
--- /dev/null
+++ b/plugins/funind/indfun.mli
@@ -0,0 +1,24 @@
+open Util
+open Names
+open Term
+open Pp
+open Indfun_common
+open Libnames
+open Glob_term
+open Declarations
+
+val do_generate_principle :  
+  bool -> 
+  (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> 
+  unit
+
+
+val functional_induction :  
+  bool ->
+  Term.constr ->
+  (Term.constr * Term.constr Glob_term.bindings) option ->
+  Genarg.intro_pattern_expr Util.located option ->
+  Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma
+
+
+val make_graph :  Libnames.global_reference -> unit
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index 0f048f59..dd475315 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -76,8 +76,8 @@ let chop_rlambda_n  =
       then List.rev acc,rt
       else
 	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
+	  | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
+	  | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
 	  | _ ->
 	      raise (Util.UserError("chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
@@ -90,7 +90,7 @@ let chop_rprod_n  =
       then List.rev acc,rt
       else
 	match rt with
-	  | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
+	  | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
 	  | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
@@ -120,9 +120,9 @@ let const_of_id id =
 let def_of_const t =
    match (Term.kind_of_term t) with
     Term.Const sp ->
-      (try (match (Global.lookup_constant sp) with
-             {Declarations.const_body=Some c} -> Declarations.force c
-	     |_ -> assert false)
+      (try (match Declarations.body_of_constant (Global.lookup_constant sp) with
+             | Some c -> Declarations.force c
+	     | _ -> assert false)
        with _ -> assert false)
     |_ -> assert false
 
@@ -158,6 +158,7 @@ let definition_message id =
 
 let save with_clean id const (locality,kind) hook =
   let {const_entry_body = pft;
+       const_entry_secctx = _;
        const_entry_type = tpo;
        const_entry_opaque = opacity } = const in
   let l,r = match locality with
@@ -180,48 +181,9 @@ 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 exl = Evarutil.non_instantiated tpfsigma  in
-  if subgoals <> [] or exl <> [] then
-    Util.errorlabstrm "extract_proof"
-      (if subgoals <> [] then
-        str "Attempt to save an incomplete proof"
-      else
-        str "Attempt to save a proof with existential variables still non-instantiated");
-  let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in
-  env,tpfsigma,pfterm
-
-
-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
-
-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
-
-let cook_proof do_reduce =
-  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 =
-    if do_reduce
-    then nf_betaiota env sigma pfterm
-    else pfterm
-  in
-  (ident,
-   ({ const_entry_body = pfterm;
-      const_entry_type = Some concl;
-      const_entry_opaque = false;
-      const_entry_boxed = false},
-    strength, hook))
-
+let cook_proof _ =
+  let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in
+  (id,(entry,strength,hook))
 
 let new_save_named opacity =
   let id,(const,persistence,hook) = cook_proof true  in
@@ -401,7 +363,7 @@ 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 : function_info -> Libobject.obj =
   Libobject.declare_object
     {(Libobject.default_object "FUNCTIONS_DB") with
        Libobject.cache_function = cache_Function;
@@ -490,6 +452,7 @@ open Goptions
 let functional_induction_rewrite_dependent_proofs_sig = 
   {
     optsync = false;
+    optdepr = false;
     optname = "Functional Induction Rewrite Dependent";
     optkey =  ["Functional";"Induction";"Rewrite";"Dependent"];
     optread = (fun () -> !functional_induction_rewrite_dependent_proofs);
@@ -502,6 +465,7 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t
 let function_debug_sig =
   {
     optsync = false;
+    optdepr = false;
     optname = "Function debug";
     optkey =  ["Function_debug"];
     optread = (fun () -> !function_debug);
@@ -521,6 +485,7 @@ let is_strict_tcc () = !strict_tcc
 let strict_tcc_sig =
   {
     optsync = false;
+    optdepr = false;
     optname = "Raw Function Tcc";
     optkey =  ["Function_raw_tcc"];
     optread = (fun () -> !strict_tcc);
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index 6f6607fc..e0076735 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -35,11 +35,11 @@ val list_union_eq :
 val list_add_set_eq :
   ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
 
-val chop_rlambda_n : int -> Rawterm.rawconstr ->
-  (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr
+val chop_rlambda_n : int -> Glob_term.glob_constr ->
+  (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
 
-val chop_rprod_n : int -> Rawterm.rawconstr ->
-  (name*Rawterm.rawconstr) list * Rawterm.rawconstr
+val chop_rprod_n : int -> Glob_term.glob_constr ->
+  (name*Glob_term.glob_constr) list * Glob_term.glob_constr
 
 val def_of_const : Term.constr -> Term.constr
 val eq : Term.constr Lazy.t
@@ -50,15 +50,8 @@ 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]
-
-
-
-   DON'T USE IT if you cannot ensure that there is no VMcast in the proof
-
 *)
 
-(* val nf_betaiotazeta : Reductionops.reduction_function *)
-
 val new_save_named : bool -> unit
 
 val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind ->
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index aa42f6cd..0b04a572 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,7 +16,6 @@ open Tacticals
 open Tactics
 open Indfun_common
 open Tacmach
-open Termops
 open Sign
 open Hiddentac
 
@@ -24,17 +23,17 @@ open Hiddentac
 
 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, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Rawterm.ImplicitBindings l ->
+  | Glob_term.ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
       Util.prlist_with_sep spc prc l
-  | Rawterm.ExplicitBindings l ->
+  | Glob_term.ExplicitBindings l ->
       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 ()
+  | Glob_term.NoBindings -> mt ()
 
 
 let pr_with_bindings prc prlc (c,bl) =
@@ -60,12 +59,13 @@ 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
+  let goal = begin try (Printer.pr_goal g) with _ -> assert false end in
   try
     let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
   with e ->
+    let e' = Cerrors.process_vernac_interp_error e in
     msgnl (str "observation "++ s++str " raised exception " ++
-	     Cerrors.explain_exn e ++ str " on goal " ++ goal );
+	     Errors.print e' ++ str " on goal " ++ goal );
     raise e;;
 
 
@@ -84,7 +84,7 @@ let nf_zeta =
 (* [id_to_constr id] finds the term associated to [id] in the global environment *)
 let id_to_constr id =
   try
-    Tacinterp.constr_of_id (Global.env ())  id
+    Constrintern.global_reference id
   with Not_found ->
     raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
 
@@ -248,7 +248,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	     | [] | [_] | [_;_] -> anomaly "bad context"
 	     | hres::res::(x,_,t)::ctxt ->
 		 Termops.it_mkLambda_or_LetIn
-		   ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res])
+		   (Termops.it_mkProd_or_LetIn concl [hres;res])
 		   ((x,None,t)::ctxt)
 	)
 	lemmas_types_infos
@@ -313,7 +313,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 		 | None -> (id::pre_args,pre_tac)
 		 | Some b ->
 		     (pre_args,
-		      tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
+		      tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
 		     )
 
 	     else (pre_args,pre_tac)
@@ -395,10 +395,10 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	    observe_tac "unfolding" pre_tac;
 	    (* $zeta$ normalizing of the conclusion *)
 	    h_reduce
-	      (Rawterm.Cbv
-		 { Rawterm.all_flags with
-		     Rawterm.rDelta = false ;
-		     Rawterm.rConst = []
+	      (Glob_term.Cbv
+		 { Glob_term.all_flags with
+		     Glob_term.rDelta = false ;
+		     Glob_term.rConst = []
 		 }
 	      )
 	      onConcl;
@@ -424,7 +424,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
+	     (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
@@ -434,12 +434,12 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Rawterm.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
+	     (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
 	  (lemmas)))
       in
-      Rawterm.ExplicitBindings (params_bindings@lemmas_bindings)
+      Glob_term.ExplicitBindings (params_bindings@lemmas_bindings)
     in
     tclTHENSEQ
       [ observe_tac "intro args_names" (tclMAP h_intro args_names);
@@ -526,15 +526,15 @@ and intros_with_rewrite_aux : tactic =
 		      Tauto.tauto g
 		  | Case(_,_,v,_) ->
 		      tclTHENSEQ[
-			h_case false (v,Rawterm.NoBindings);
+			h_case false (v,Glob_term.NoBindings);
 			intros_with_rewrite
 		      ] g
 		  | LetIn _ ->
 		      tclTHENSEQ[
 			h_reduce
-			  (Rawterm.Cbv
-			     {Rawterm.all_flags
-			      with Rawterm.rDelta = false;
+			  (Glob_term.Cbv
+			     {Glob_term.all_flags
+			      with Glob_term.rDelta = false;
 			     })
 			  onConcl
 			;
@@ -547,9 +547,9 @@ and intros_with_rewrite_aux : tactic =
 	  | LetIn _ ->
 	      tclTHENSEQ[
 		h_reduce
-		  (Rawterm.Cbv
-		     {Rawterm.all_flags
-		      with Rawterm.rDelta = false;
+		  (Glob_term.Cbv
+		     {Glob_term.all_flags
+		      with Glob_term.rDelta = false;
 		     })
 		  onConcl
 		;
@@ -563,7 +563,7 @@ let rec reflexivity_with_destruct_cases g =
       match kind_of_term (snd (destApp (pf_concl g))).(2) with
 	| Case(_,_,v,_) ->
 	    tclTHENSEQ[
-	      h_case false (v,Rawterm.NoBindings);
+	      h_case false (v,Glob_term.NoBindings);
 	      intros;
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
 	    ]
@@ -636,7 +636,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     *)
     let lemmas =
       Array.map
-	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
+	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt))
 	lemmas_types_infos
     in
     (* We get the constant and the principle corresponding to this lemma *)
@@ -686,16 +686,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	  Equality.rewriteLR (mkConst eq_lemma);
 	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
 	  h_reduce
-	    (Rawterm.Cbv
-	       {Rawterm.all_flags
-		with Rawterm.rDelta = false;
+	    (Glob_term.Cbv
+	       {Glob_term.all_flags
+		with Glob_term.rDelta = false;
 	       })
 	    onConcl
 	  ;
 	  h_generalize (List.map mkVar ids);
 	  thin ids
 	]
-      else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
+      else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))]
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in
@@ -733,7 +733,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(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 "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
+	  (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings)))))
 	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
       ]
       g
@@ -763,7 +763,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	   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
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn 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
@@ -784,7 +784,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	       (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))
+	       (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs))
 	    )
     in
     let proving_tac =
@@ -806,7 +806,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	 let finfo = find_Function_infos f_as_constant in
 	 update_Function
 	   {finfo with
-	      correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
+	      correctness_lemma = Some (destConst (Constrintern.global_reference (mk_correct_id f_id)))
 	   }
 
       )
@@ -818,7 +818,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	   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
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn 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
@@ -858,7 +858,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	 let finfo = find_Function_infos f_as_constant in
 	 update_Function
 	   {finfo with
-	      completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
+	      completeness_lemma = Some (destConst (Constrintern.global_reference (mk_complete_id f_id)))
 	   }
       )
       funs;
@@ -955,7 +955,7 @@ let functional_inversion kn hid fconst f_correct : tactic =
 	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
 	    thin [hid];
 	    h_intro hid;
-	    Inv.inv FullInversion None (Rawterm.NamedHyp hid);
+	    Inv.inv FullInversion None (Glob_term.NamedHyp hid);
 	    (fun g ->
 	       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
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index 40ee116d..4eedf8dc 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,6 @@
 
 (* Merging of induction principles. *)
 
-(*i $Id: i*)
 open Libnames
 open Tactics
 open Indfun_common
@@ -21,12 +20,12 @@ open Term
 open Termops
 open Declarations
 open Environ
-open Rawterm
-open Rawtermops
+open Glob_term
+open Glob_termops
 
 (** {1 Utilities}  *)
 
-(** {2 Useful operations on constr and rawconstr} *)
+(** {2 Useful operations on constr and glob_constr} *)
 
 let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
 
@@ -61,7 +60,7 @@ 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 =
     match x with
-      | RVar (_,x) -> Pervasives.compare x f = 0
+      | GVar (_,x) -> Pervasives.compare x f = 0
       | _ -> false
 
 (** [ident_global_exist id] returns true if identifier [id] is linked
@@ -98,7 +97,7 @@ let prNamedConstr s c =
 let prNamedRConstr s c =
   begin
     msg(str "");
-    msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
+    msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} ");
     msg(str "");
   end
 let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
@@ -130,7 +129,7 @@ let prNamedRLDecl s lc =
   end
 
 let showind (id:identifier) =
-  let cstrid = Tacinterp.constr_of_id (Global.env()) id in
+  let cstrid = Constrintern.global_reference id in
   let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
   let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
   List.iter (fun (nm, optcstr, tp) ->
@@ -378,15 +377,15 @@ let verify_inds mib1 mib2 =
 let build_raw_params prms_decl avoid =
   let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in
   let _ = prNamedConstr "DUMMY" dummy_constr in
-  let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
-  let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in
-  let res,_ = raw_decompose_prod dummy_rawconstr in
+  let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in
+  let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in
+  let res,_ = glob_decompose_prod dummy_glob_constr in
   let comblist = List.combine prms_decl res in
-  comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
+  comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr)))
 *)
 
 let ids_of_rawlist avoid rawl =
-    List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl)
+    List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl)
 
 
 
@@ -464,7 +463,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
       ([],[],[],[]) arity_ctxt in
 (*  let arity_ctxt2 =
     build_raw_params oib2.mind_arity_ctxt
-      (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*)
+      (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
   let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
   let _ = prstr "\n\n\n" in
   let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
@@ -512,37 +511,37 @@ exception NoMerge
 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 ->
+    | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
         let _ = prstr "\nICI1!\n";Pp.flush_all() in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
-    | RApp(_,f1, arr1), RApp(_,f2,arr2)  -> raise NoMerge
-    | RLetIn(_,nme,bdy,trm) , _ ->
+        GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args)
+    | GApp(_,f1, arr1), GApp(_,f2,arr2)  -> raise NoMerge
+    | GLetIn(_,nme,bdy,trm) , _ ->
         let _ = prstr "\nICI2!\n";Pp.flush_all() in
         let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
-        RLetIn(dummy_loc,nme,bdy,newtrm)
-    | _, RLetIn(_,nme,bdy,trm) ->
+        GLetIn(dummy_loc,nme,bdy,newtrm)
+    | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3!\n";Pp.flush_all() in
         let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
-        RLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(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 lnk = Array.append shift.lnk1 shift.lnk2 in
   match c1 , c2 with
-    | RApp(_,f1, arr1), RApp(_,f2,arr2) ->
+    | GApp(_,f1, arr1), GApp(_,f2,arr2) ->
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
+        GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args)
           (* FIXME: what if the function appears in the body of the let? *)
-    | RLetIn(_,nme,bdy,trm) , _ ->
+    | GLetIn(_,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) ->
+        GLetIn(dummy_loc,nme,bdy,newtrm)
+    | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
-        RLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(dummy_loc,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
 
 
@@ -551,24 +550,24 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
    calls of branch 1 with all rec calls of branch 2. *)
 (* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
 let rec merge_rec_hyps shift accrec
-    (ltyp:(Names.name * rawconstr option * rawconstr option) list)
-    filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list =
+    (ltyp:(Names.name * glob_constr option * glob_constr option) list)
+    filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list =
   let mergeonehyp t reldecl =
     match reldecl with
-      | (nme,x,Some (RApp(_,i,args) as ind))
+      | (nme,x,Some (GApp(_,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,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 (GApp(_,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 * glob_constr) list) concl2 shift =
   List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
 
 
@@ -578,7 +577,7 @@ let find_app (nme:identifier) ltyp =
       (List.map
           (fun x ->
             match x with
-              | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+              | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0)
               | _ -> ())
           ltyp);
     false
@@ -592,9 +591,9 @@ let prnt_prod_or_letin nm letbdy typ =
 
 
 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 =
+    (ltyp1:(name * glob_constr option * glob_constr option) list)
+    (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2
+    : (name * glob_constr option * glob_constr option) list * glob_constr =
   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
@@ -638,7 +637,7 @@ let rec merge_types shift accrec1
           rechyps , concl
       | (nme,None, Some t1)as e ::lt1 ->
           (match t1 with
-            | RApp(_,f,carr) when isVarf ind1name f ->
+            | GApp(_,f,carr) when isVarf ind1name f ->
                 merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
             | _ ->
                 let recres, recconcl2 =
@@ -705,8 +704,8 @@ let build_link_map allargs1 allargs2 lnk =
     Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
 
     TODO: return nothing if equalities (after linking) are contradictory. *)
-let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
-    (typcstr2:rawconstr) : rawconstr =
+let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr)
+    (typcstr2:glob_constr) : glob_constr =
   (* 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 *)
@@ -714,17 +713,17 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
     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 allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in
+  let allargs2,rest2 = glob_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 hyps1,concl1 = glob_decompose_prod_or_letin rest1 in
+  let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in
   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 typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in
   let revargs1 =
     list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
   let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
@@ -734,7 +733,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
   let _ = prNamedRLDecl "ltyp allargs2" allargs2 in
   let _ = prNamedRLDecl "ltyp revargs2" revargs2 in
   let typwithprms =
-    raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in
+    glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in
   typwithprms
 
 
@@ -757,11 +756,11 @@ let merge_constructor_id id1 id2 shift:identifier =
 
 
 (** [merge_constructors lnk shift avoid] merges the two list of
-    constructor [(name*type)]. These are translated to rawterms
+    constructor [(name*type)]. These are translated to glob_constr
     first, each of them having distinct var names. *)
 let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * rawconstr) list)
-    (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
+    (typcstr1:(identifier * glob_constr) list)
+    (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list =
   List.flatten
     (List.map
         (fun (id1,rawtyp1) ->
@@ -779,12 +778,12 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
     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 *)
+  (* building glob_constr type of constructors *)
   let mkrawcor nme avoid typ =
     (* first replace rel 1 by a varname *)
     let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
     Detyping.detype false (Idset.elements avoid) [] substindtyp in
-  let lcstr1: rawconstr list =
+  let lcstr1: glob_constr list =
     Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
   (* add  to avoid all indentifiers of lcstr1 *)
   let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
@@ -793,10 +792,10 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
   let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
 
   let params1 =
-    try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
+    try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
     with _ -> [] in
   let params2 =
-    try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
+    try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
     with _ -> [] in
 
   let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
@@ -817,8 +816,8 @@ let rec merge_mutual_inductive_body
   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 glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *)
+  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x
 
 let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
   let params = prms2 @ prms1 in
@@ -828,7 +827,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
         let _ = prstr "param :" in
         let _ = prNamedRConstr (string_of_name nme) tp in
         let _ = prstr "  ;  " in
-        let typ = rawterm_to_constr_expr tp in
+        let typ = glob_constr_to_constr_expr tp in
         LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
       [] params in
   let concl = Constrextern.extern_constr false (Global.env()) concl in
@@ -845,38 +844,38 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
 
 
 
-(** [rawterm_list_to_inductive_expr ident rawlist] returns the
+(** [glob_constr_list_to_inductive_expr ident rawlist] returns the
     induct_expr corresponding to the the list of constructor types
     [rawlist], named ident.
     FIXME: params et cstr_expr (arity) *)
-let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
-    (rawlist:(identifier * rawconstr) list) =
+let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
+    (rawlist:(identifier * glob_constr) list) =
   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  =
     List.map (* zeta_normalize t ? *)
-      (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
+      (fun (id,t) -> false, ((dummy_loc,id),glob_constr_to_constr_expr t))
       rawlist in
   lident , bindlist , Some cstr_expr , lcstor_expr
 
 
 
-let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
   match rdecl with
     | (nme,None,t) ->
         let traw = Detyping.detype false [] [] t in
-        RProd (dummy_loc,nme,Explicit,traw,t2)
+        GProd (dummy_loc,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
 
 
 
 
-let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
   match rdecl with
     | (nme,None,t) ->
         let traw = Detyping.detype false [] [] t in
-        RProd (dummy_loc,nme,Explicit,traw,t2)
+        GProd (dummy_loc,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
 
 
@@ -902,7 +901,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
       recprms1=prms1;
       recprms1=prms1;
     } in *)
-  let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
+  let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
   (* Declare inductive *)
   let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
   let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in
@@ -1024,9 +1023,3 @@ let relprinctype_to_funprinctype relprinctype nfuns =
     url = "citeseer.ist.psu.edu/bundy93rippling.html" }
 
  *)
-(*
-*** Local Variables: ***
-*** compile-command: "make -C ../.. plugins/funind/merge.cmo" ***
-*** indent-tabs-mode: nil ***
-*** End: ***
-*)
diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli
deleted file mode 100644
index 455e7c89..00000000
--- a/plugins/funind/rawtermops.mli
+++ /dev/null
@@ -1,126 +0,0 @@
-open Rawterm
-
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-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
-*)
-val pattern_to_term : cases_pattern -> rawconstr
-
-(*
-   Some basic functions to rebuild rawconstr
-   In each of them the location is Util.dummy_loc
-*)
-val mkRRef : Libnames.global_reference -> rawconstr
-val mkRVar : Names.identifier -> rawconstr
-val mkRApp  : rawconstr*(rawconstr list) -> rawconstr
-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 mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
-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 :
-  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 ->
-  (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 ->
-  (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] *)
-val  raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
-(* [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] *)
-val  raw_make_or : rawconstr -> rawconstr -> rawconstr
-
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
-   to [P1 \/ ( .... \/ Pn)]
-*)
-val  raw_make_or_list : rawconstr list -> rawconstr
-
-
-(* alpha_conversion functions *)
-
-
-
-(* Replace the var mapped in the rawconstr/context *)
-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
-   a fresh variable for each occurence of the anonymous pattern.
-
-   Also returns a mapping  from old variables to new ones and the concatenation of
-   [avoid] with the variables appearing in the result.
-*)
-  val alpha_pat :
-    Names.Idmap.key list ->
-    Rawterm.cases_pattern ->
-    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
-*)
-val alpha_rt : Names.identifier list -> rawconstr -> rawconstr
-
-(* same as alpha_rt but for case branches *)
-val alpha_br : Names.identifier list ->
-    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
-    Rawterm.rawconstr ->
-    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
-    Rawterm.rawconstr
-
-
-(* 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 eq_cases_pattern : cases_pattern -> cases_pattern -> bool
-
-
-
-(*
-   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
-
-(* TODO: finish this function (Fix not treated) *)
-val ids_of_rawterm: rawconstr -> Names.Idset.t
-
-(*
-   removing let_in construction in a rawterm
-*)
-val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
-
-
-val expand_as : rawconstr -> rawconstr
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 83868da9..55ebd31b 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,10 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: recdef.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
-open Termops
 open Namegen
 open Environ
 open Declarations
@@ -36,7 +33,7 @@ open Proof_type
 open Vernacinterp
 open Pfedit
 open Topconstr
-open Rawterm
+open Glob_term
 open Pretyping
 open Pretyping.Default
 open Safe_typing
@@ -69,45 +66,39 @@ let pf_get_new_id id g =
 let h_intros l =
   tclMAP h_intro l
 
-let debug_queue = Queue.create ()
+let debug_queue = Stack.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
+let rec print_debug_queue b e = 
+  if  not (Stack.is_empty debug_queue) 
+  then
     begin
-      print_debug_queue e;
-      msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+      let lmsg,goal = Stack.pop debug_queue in 
+      if b then 
+	msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+      else
+	begin
+	  msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	end;
+      print_debug_queue false e;
     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;
+  let goal = Printer.pr_goal g in
+  let lmsg = (str "recdef : ") ++ (str s) in 
+  Stack.push (lmsg,goal) debug_queue;
   try 
     let v = tac g in 
-    ignore(Queue.pop debug_queue);
+    ignore(Stack.pop debug_queue);
     v
   with e -> 
-    if not (Queue.is_empty debug_queue)
+    if not (Stack.is_empty debug_queue)
     then
-      print_debug_queue e;
+      print_debug_queue true 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 );
-   raise e;;
-*)
-
 let observe_tac s tac g =
   if Tacinterp.get_debug () <> Tactic_debug.DebugOff
   then do_observe_tac s tac g
@@ -145,9 +136,9 @@ let message s = if Flags.is_verbose () then msgnl(str s);;
 let def_of_const t =
    match (kind_of_term t) with
     Const sp ->
-      (try (match (Global.lookup_constant sp) with
-             {const_body=Some c} -> Declarations.force c
-	     |_ -> assert false)
+      (try (match body_of_constant (Global.lookup_constant sp) with
+             | Some c -> Declarations.force c
+	     | _ -> assert false)
        with _ ->
 	 anomaly ("Cannot find definition of constant "^
 		    (string_of_id (id_of_label (con_label sp))))
@@ -180,11 +171,23 @@ 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 check_not_nested f t = 
+  match kind_of_term t with 
+    | App(g, _) when eq_constr f g -> 
+	errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
+    | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
+    | _ -> iter_constr (check_not_nested f) t 
+
+
+
+
+let rec (find_call_occs : int -> int -> constr -> constr ->
   (constr list -> constr) * constr list list) =
- fun nb_lam f expr ->
+ fun nb_arg nb_lam f expr ->
   match (kind_of_term expr) with
-    App (g, args) when g = f ->
+    App (g, args) when eq_constr g f ->
+      if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function");
+      Array.iter (check_not_nested f) args;
       (fun l -> List.hd l), [Array.to_list args]
   | App (g, args) ->
      let (largs: constr list) = Array.to_list args in
@@ -193,7 +196,7 @@ let rec (find_call_occs : int -> constr -> constr ->
        | a::upper_tl ->
          (match find_aux upper_tl with
           (cf, ((arg1::args) as args_for_upper_tl)) ->
-           (match find_call_occs nb_lam f a with
+           (match find_call_occs nb_arg nb_lam f a with
              cf2, (_ :: _ as other_args) ->
                let rec avoid_duplicates args =
                   match args with
@@ -217,7 +220,7 @@ let rec (find_call_occs : int -> constr -> constr ->
                      other_args'@args_for_upper_tl
            | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
 	 | _, [] ->
-	   (match find_call_occs nb_lam f a with
+	   (match find_call_occs nb_arg nb_lam f a with
 	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
 	   | _, [] -> (fun x -> a::upper_tl), [])) in
      begin
@@ -227,15 +230,16 @@ let rec (find_call_occs : int -> constr -> constr ->
 	     (fun l -> mkApp (g, Array.of_list (cf l))), args
      end
   | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[])
+  | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function")
   | Var(id) -> (fun l -> expr), []
   | Meta(_) -> error "find_call_occs : Meta"
   | Evar(_) -> error "find_call_occs : Evar"
   | Sort(_)  -> (fun l -> expr), []
-  | Cast(b,_,_) -> find_call_occs nb_lam f b
+  | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b
   | Prod(_,_,_) -> error "find_call_occs : Prod"
   | Lambda(na,t,b) ->
       begin
-	match find_call_occs (succ nb_lam) f b with
+	match find_call_occs nb_arg (succ nb_lam) f b with
 	  | _, [] ->  (* Lambda are authorized as long as they do not contain
 			 recursives calls *)
 	      (fun l -> expr),[]
@@ -243,7 +247,7 @@ let rec (find_call_occs : int -> constr -> constr ->
       end
   | 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_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with
 	  | (_,[]),(_,[]) ->
 	      ((fun l -> expr), [])
 	  | (_,[]),(cf,(_::_ as l)) ->
@@ -256,7 +260,7 @@ let rec (find_call_occs : int -> constr -> constr ->
   | Ind(_) -> (fun l -> expr), []
   | Construct (_, _) -> (fun l -> expr), []
   | Case(i,t,a,r) ->
-      (match find_call_occs nb_lam f a with
+      (match find_call_occs nb_arg nb_lam f a with
 	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
       | _ -> (fun l -> expr),[])
   | Fix(_) -> error "find_call_occs : Fix"
@@ -369,15 +373,15 @@ let rec  mk_intros_and_continue thin_intros (extra_eqn:bool)
 		h_intros thin_intros;
 
 		tclMAP
-		  (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences (* deps proofs also: *) true teq eq false))
+		  (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false))
 		  (List.rev eqs);
 		(fun g1 ->
 		   let ty_teq = pf_type_of g1 (mkVar teq) in
 		   let teq_lhs,teq_rhs =
-		     let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in
+		     let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in
 		     args.(1),args.(2)
 		   in
-	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
+	           cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1
 		)
 	      ]
 	      
@@ -430,7 +434,7 @@ let tclUSER tac is_mes l g =
       clear_tac;
       if is_mes
       then tclTHEN
-             (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
+             (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference
                                       (delayed_force ltof_ref))])
              tac
       else tac
@@ -529,8 +533,8 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
 	   Nameops.out_name k_na,Nameops.out_name def_na
 	 in
 	 tclTHENS
-	   (general_rewrite_bindings false all_occurrences
-	      (* dep proofs also: *) true
+	   (general_rewrite_bindings false Termops.all_occurrences
+	      (* dep proofs also: *) true true
 	      (mkVar eq,
 	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
 				dummy_loc, NamedHyp def_id, mkVar def]) false)
@@ -572,7 +576,7 @@ let rec introduce_all_equalities func eqs values specs bound 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 ids = Termops.ids_of_named_context (pf_hyps g) in
 	let p = next_ident_away_in_goal p_id ids in
         let ids = p::ids in
 	let pmax = next_ident_away_in_goal pmax_id ids in
@@ -618,7 +622,7 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
 	   (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])]
   | arg::args ->
       (fun g ->
-	let ids = ids_of_named_context (pf_hyps g) in
+	let ids = Termops.ids_of_named_context (pf_hyps g) in
 	let rec_res = next_ident_away_in_goal rec_res_id ids in
         let ids = rec_res::ids in
 	let hspec = next_ident_away_in_goal hspec_id ids in
@@ -657,13 +661,13 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
     )
 
 
-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
+let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
+  match find_call_occs nb_arg 0 f_constr expr with
   | context_fn, args ->
       observe_tac "introduce_all_values"
 	(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
 
-let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
+let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier)
   (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
   let rec proveterminate (eqs:constr list) (expr:constr)  =
     try
@@ -671,7 +675,7 @@ let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
       let v =
         match (kind_of_term expr) with
 	  Case (ci, t, a, l) ->
-	  (match find_call_occs 0 f_constr a with
+	  (match find_call_occs nb_arg 0 f_constr a with
 	    _,[] ->
 	    (fun g ->
 	      let destruct_tac, rev_to_thin_intro =
@@ -683,16 +687,16 @@ let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
 				true
 				proveterminate
 				eqs
-				ci.ci_cstr_nargs.(i))
+				ci.ci_cstr_ndecls.(i))
 		    0 (Array.to_list l)) g)
 		  | _, _::_ ->
-		    (match find_call_occs  0 f_constr expr with
+		    (match find_call_occs  nb_arg 0 f_constr expr with
 	     	      _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
 		    | _, _:: _ ->
 		      observe_tac "rec_leaf"
 		      (rec_leaf is_mes acc_inv hrec  func eqs expr)))
 	  | _ ->
-            (match find_call_occs  0 f_constr expr with
+            (match find_call_occs  nb_arg 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 ))
@@ -831,7 +835,7 @@ let rec instantiate_lambda t l =
 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 ids = Termops.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 =
@@ -864,6 +868,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	rec_arg_id
 	(fun rec_arg_id hrec acc_inv g ->
            (proveterminate
+	      nb_args
 	      [rec_arg_id]
 	      is_mes
 	      acc_inv
@@ -871,7 +876,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	      (mkVar f_id)
 	      func
 	      base_leaf_terminate
-	      (rec_leaf_terminate (mkVar f_id) concl_tac)
+	      (rec_leaf_terminate nb_args (mkVar f_id) concl_tac)
 	      []
 	      expr
 	   )
@@ -882,9 +887,9 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
   end
 
 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 p = Proof_global.give_me_the_proof () in
+  let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in
+  List.map (Goal.V82.abstract_type sigma) sgs
 
 let build_and_l l =
   let and_constr =  Coqlib.build_coq_and () in
@@ -918,7 +923,7 @@ let clear_goals =
       | Prod(Name id as na,t',b) ->
 	  let b' = clear_goal b in
 	  if noccurn 1 b' && (is_rec_res id)
-	  then pop b'
+	  then Termops.pop b'
 	  else if b' == b then t
 	  else mkProd(na,t',b')
       | _ -> map_constr clear_goal t
@@ -934,6 +939,13 @@ let build_new_goal_type () =
   let res = build_and_l sub_gls_types in
   res
 
+let is_opaque_constant c =
+  let cb = Global.lookup_constant c in
+  match cb.Declarations.const_body with
+    | Declarations.OpaqueDef _ -> true
+    | Declarations.Undef _ -> true
+    | Declarations.Def _ -> false
+
 let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
   (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
   let current_proof_name = get_current_proof_name () in
@@ -943,20 +955,16 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 	try (add_suffix current_proof_name "_subproof")
 	with _ -> anomaly "open_new_goal with an unamed theorem"
   in
-  let sign = Global.named_context () in
-  let sign = clear_proofs sign in
+  let sign = initialize_named_context_for_proof () in
   let na = next_global_ident_away name [] in
-  if occur_existential gls_type then
+  if Termops.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 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
+	  ConstRef c -> is_opaque_constant c
 	| _ -> anomaly "equation_lemma: not a constant"
     in
     let lemma = mkConst (Lib.make_con na) in
@@ -1000,7 +1008,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 		      Eauto.eauto_with_bases
 			false
 			(true,5)
-			[delayed_force refl_equal]
+			[Evd.empty,delayed_force refl_equal]
 			[Auto.Hint_db.empty empty_transparent_state false]
 		      ]
 		    )
@@ -1101,38 +1109,31 @@ let (value_f:constr list -> global_reference -> constr) =
 	  al
       )
     in
-    let fun_body =
-      RCases
+    let context = List.map
+      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
+    in
+    let env = Environ.push_rel_context context (Global.env ()) in
+    let glob_body =
+      GCases
 	(d0,RegularStyle,None,
-	 [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l),
+	 [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
 	  (Anonymous,None)],
 	 [d0, [v_id], [PatCstr(d0,(ind_of_ref
 				     (delayed_force coq_sig_ref),1),
 			       [PatVar(d0, Name v_id);
 				PatVar(d0, Anonymous)],
 			       Anonymous)],
-	  RVar(d0,v_id)])
-    in
-    let value =
-      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
-	(List.rev al)
+	  GVar(d0,v_id)])
     in
-    understand Evd.empty (Global.env()) value;;
+    let body = understand Evd.empty env glob_body in
+    it_mkLambda_or_LetIn body context
 
 let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
   fun f_id kind value ->
     let ce = {const_entry_body = value;
+              const_entry_secctx = None;
 	      const_entry_type = None;
-	      const_entry_opaque = false;
-              const_entry_boxed = true} in
+	      const_entry_opaque = false } in
       ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
 
 let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) =
@@ -1152,7 +1153,7 @@ let start_equation (f:global_reference) (term_f:global_reference)
   let x = n_x_id ids nargs in
   tclTHENLIST [
     h_intros x;
-    unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)];
+    unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)];
     observe_tac "simplest_case"
       (simplest_case (mkApp (terminate_constr,
                              Array.of_list (List.map mkVar x))));
@@ -1194,7 +1195,7 @@ let rec introduce_all_values_eq cont_tac functional termine
            simpl_iter (onHyp heq2);
            unfold_in_hyp [((true,[1]), evaluable_of_global_reference
                              (global_of_constr functional))]
-             (heq2, InHyp);
+             (heq2, Termops.InHyp);
            tclTHENS
 	     (fun gls ->
 		let t_eq = compute_renamed_type gls (mkVar heq2) in
@@ -1202,8 +1203,8 @@ let rec introduce_all_values_eq cont_tac functional termine
 		  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
-		(* dep proofs also: *) true (mkVar heq2,
+		observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences
+		true (* dep proofs also: *) true (mkVar heq2,
 		 ExplicitBindings[dummy_loc,NamedHyp def_id,
 				  f]) false) gls)
 	     [tclTHENLIST
@@ -1258,7 +1259,7 @@ 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 (* dep proofs also: *) true
+			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true
 							       c_b false))
 			     g
 		     )
@@ -1293,12 +1294,12 @@ let rec_leaf_eq termine f ids functional eqs expr fn args =
 	 functional termine f p heq1 p [] [] eqs ids args);
        observe_tac "failing here" (apply (delayed_force refl_equal))]
 
-let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
+let rec prove_eq nb_arg  (termine:constr) (f:constr)(functional:global_reference)
     (eqs:constr list) (expr:constr) =
 (*   tclTRY *)
   observe_tac "prove_eq"  (match kind_of_term expr with
      Case(ci,t,a,l) ->
-     (match find_call_occs 0 f a with
+     (match find_call_occs nb_arg 0 f a with
 	_,[] ->
 	(fun g ->
 	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
@@ -1307,38 +1308,35 @@ let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
 	    (list_map_i
 	       (fun i -> mk_intros_and_continue
                           (List.rev rev_to_thin_intro) true
-			  (prove_eq termine f functional)
-			  eqs ci.ci_cstr_nargs.(i))
+			  (prove_eq nb_arg termine f functional)
+			  eqs ci.ci_cstr_ndecls.(i))
 	       0 (Array.to_list l)) g)
 	   | _,_::_ ->
-	      (match find_call_occs 0 f expr with
+	      (match find_call_occs nb_arg 0 f expr with
 		_,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f)
 	      | fn,args ->
 	        fun g ->
-		  let ids = ids_of_named_context (pf_hyps g) in
+		  let ids = Termops.ids_of_named_context (pf_hyps g) in
 	          observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids
 		    (constr_of_global functional)
 		    eqs expr fn args) g))
        | _ ->
-	   (match find_call_occs 0 f expr with
+	   (match find_call_occs nb_arg 0 f expr with
 		_,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f)
 	      | fn,args ->
 		  fun g ->
-		    let ids = ids_of_named_context (pf_hyps g) in
+		    let ids = Termops.ids_of_named_context (pf_hyps g) in
 		    observe_tac "rec_leaf_eq" (rec_leaf_eq
 		      termine f ids (constr_of_global functional)
 		      eqs expr fn args) g));;
 
-let (com_eqn : identifier ->
+let (com_eqn : int -> identifier ->
        global_reference -> global_reference -> global_reference
 	 -> constr -> unit) =
-  fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
+  fun nb_arg 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
+	| ConstRef c -> is_opaque_constant c
 	| _ -> anomaly "terminate_lemma: not a constant"
     in
     let (evmap, env) = Lemmas.get_current_context() in
@@ -1349,7 +1347,7 @@ let (com_eqn : identifier ->
      by
        (start_equation f_ref terminate_ref
 	  (fun  x ->
-	     prove_eq
+	     prove_eq nb_arg
 	       (constr_of_global terminate_ref)
 	       f_constr
 	       functional_ref
@@ -1382,12 +1380,12 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
     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); *)
+  (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type);  *)
   let equation_lemma_type = 
     nf_betaiotazeta
       (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) 
   in
-(*  Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
+ (* 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
@@ -1406,7 +1404,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let equation_id = add_suffix function_name "_equation" in
   let functional_id =  add_suffix function_name "_F" in
   let term_id = add_suffix function_name "_terminate" in
-  let functional_ref = declare_fun functional_id (IsDefinition Definition) res in
+  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.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 =
     interp_constr
@@ -1420,14 +1418,15 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let hook _ _ =
     let term_ref = Nametab.locate (qualid_of_ident term_id) in
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
+    let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in 
 (*     message "start second proof"; *)
     let stop = ref false in
     begin
-      try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
       with e ->
 	begin
 	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
-	  then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e)
+	  then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e)
 	  else anomaly "Cannot create equation Lemma"
 	  ;
 (* 	  ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *)
diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib
index 31818c39..ec1f5436 100644
--- a/plugins/funind/recdef_plugin.mllib
+++ b/plugins/funind/recdef_plugin.mllib
@@ -1,7 +1,7 @@
 Indfun_common
-Rawtermops
+Glob_termops
 Recdef
-Rawterm_to_relation
+Glob_term_to_relation
 Functional_principles_proofs
 Functional_principles_types
 Invfun
diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
index 8f0f86c5..3031fd22 100644
--- a/plugins/micromega/CheckerMaker.v
+++ b/plugins/micromega/CheckerMaker.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,6 +12,8 @@
 (*                                                                      *)
 (************************************************************************)
 
+(* FK: scheduled for deletion *)
+(*
 Require Import Setoid.
 Require Import Decidable.
 Require Import List.
@@ -127,3 +129,4 @@ apply <- negate_correct. intro; now elim H3. exact (H1 H2).
 Qed.
 
 End CheckerMaker.
+*)
\ No newline at end of file
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index 5aa30fed..5f6c60be 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -17,27 +17,21 @@ Require Import Coq.Arith.Max.
 Require Import List.
 Set Implicit Arguments.
 
-(* 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.
-   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
-*)
-
 Section S.
 
   Variable D :Type.
 
   Definition Env := positive -> D.
 
-  Definition jump  (j:positive) (e:Env) := fun x => e (Pplus x j).
+  Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j).
 
-  Definition nth  (n:positive) (e : Env ) := e n.
+  Definition nth (n:positive) (e : Env ) := e n.
 
-  Definition hd (x:D)  (e: Env)  := nth xH e.
+  Definition hd (x:D) (e: Env)  := nth xH e.
 
   Definition tail (e: Env) := jump xH e.
 
-  Lemma psucc : forall p,  (match p with
+  Lemma psucc : forall p, (match p with
                               | xI y' => xO (Psucc y')
                               | xO y' => xI y'
                               | 1%positive => 2%positive
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index 8968a014..309ebdef 100644
--- a/plugins/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -43,7 +43,7 @@ Section MakeRingPol.
                                 cO cI cadd cmul csub copp ceqb phi.
 
   (* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -105,12 +105,12 @@ Section MakeRingPol.
   match P, P' with
   | Pc c, Pc c' => c ?=! c'
   | Pinj j Q, Pinj j' Q' =>
-    match Pcompare j j' Eq with
+    match j ?= j' with
     | Eq => Peq Q Q'
     | _ => false
     end
   | PX P i Q, PX P' i' Q' =>
-    match Pcompare i i' Eq with
+    match i ?= i' with
     | Eq => if Peq P P' then Peq Q Q' else false
     | _ => false
     end
@@ -421,7 +421,7 @@ Section MakeRingPol.
         _, mon0 => (Pc cO, P)
    | Pc _, _    => (P, Pc cO)
    | Pinj j1 P1, zmon j2 M1 =>
-      match (j1 ?= j2) Eq with
+      match (j1 ?= j2) with
         Eq => let (R,S) := MFactor P1 M1 in
                  (mkPinj j1 R, mkPinj j1 S)
       | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
@@ -435,7 +435,7 @@ Section MakeRingPol.
              let (R2, S2) := MFactor Q1 M2 in
                (mkPX R1 i R2, mkPX S1 i S2)
   | PX P1 i Q1, vmon j M1 =>
-      match (i ?= j) Eq with
+      match (i ?= j) with
         Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
                  (mkPX R1 i Q1, S1)
       | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
@@ -537,10 +537,10 @@ Section MakeRingPol.
  Proof.
   induction P;destruct P';simpl;intros;try discriminate;trivial.
   apply (morph_eq CRmorph);trivial.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+  assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0);
    try discriminate H.
   rewrite (IHP P' H); rewrite H1;trivial;rrefl.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+  assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0);
    try discriminate H.
   rewrite H1;trivial. clear H1.
   assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
@@ -1019,8 +1019,8 @@ Qed.
    intros i P Hrec M l; case M; simpl; clear M.
      rewrite (morph0 CRmorph); rsimpl.
      intros j M.
-     case_eq ((i ?= j) Eq); intros He; simpl.
-       rewrite (Pcompare_Eq_eq _ _ He).
+     case_eq (i ?= j); intros He; simpl.
+       rewrite (Pos.compare_eq _ _ He).
        generalize (Hrec M (jump j l)); case (MFactor P M);
         simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
        generalize (Hrec (zmon (j -i) M) (jump i l));
@@ -1048,8 +1048,8 @@ Qed.
      rewrite (ARadd_comm ARth); rsimpl.
      rewrite zmon_pred_ok;rsimpl.
    intros j M1.
-     case_eq ((i ?= j) Eq); intros He; simpl.
-       rewrite (Pcompare_Eq_eq _ _ He).
+     case_eq (i ?= j); intros He; simpl.
+       rewrite (Pos.compare_eq _ _ He).
        generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rewrite mkPX_ok; rsimpl.
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 5afe7e37..19a98f87 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -23,7 +23,7 @@ Require Import NArith.
 Require Import QArith.
 
 Extract Inductive prod => "( * )" [ "(,)" ].
-Extract Inductive List.list => list [ "[]" "(::)" ].
+Extract Inductive list => list [ "[]" "(::)" ].
 Extract Inductive bool => bool [ true false ].
 Extract Inductive sumbool => bool [ true false ].
 Extract Inductive option => option [ Some None ].
@@ -38,10 +38,23 @@ Extract Inductive sumor => option [ Some None ].
     Let's rather use the ocaml && *)
 Extract Inlined Constant andb => "(&&)".
 
+Require Import Reals.
+
+Extract Constant R => "int".  
+Extract Constant R0 => "0".  
+Extract Constant R1 => "1".  
+Extract Constant Rplus => "( + )".
+Extract Constant Rmult => "( * )".
+Extract Constant Ropp  => "fun x -> - x".
+Extract Constant Rinv   => "fun x -> 1 / x".
+
 Extraction "micromega.ml"
   List.map simpl_cone (*map_cone  indexes*)
   denorm Qpower
-  n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+  n_of_Z N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+
+
+
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
index e4f91fb6..97517957 100644
--- a/plugins/micromega/OrderedRing.v
+++ b/plugins/micromega/OrderedRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index fde0f29a..7f6cf79b 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -18,7 +18,7 @@ Require Import RMicromega.
 Require Import QArith.
 Require Export Ring_normalize.
 Require Import ZArith.
-Require Import Raxioms.
+Require Import Rdefinitions.
 Require Export RingMicromega.
 Require Import VarMap.
 Require Tauto.
@@ -66,6 +66,7 @@ Ltac psatzl dom :=
         change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
         apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
   | R =>
+    unfold Rdiv in * ; 
     psatzl_R ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
@@ -75,12 +76,25 @@ Ltac psatzl dom :=
   | _ => fail "Unsupported domain"
   end in tac.
 
+
+Ltac lra := 
+  first [ psatzl R | psatzl Q ].
+
 Ltac lia :=
-  xlia ;
+  zify ; unfold Zsucc in * ; 
+  (*cbv delta - [Zplus Zminus Zopp Zmult Zpower Zgt Zge Zle Zlt iff not] ;*) xlia ; 
   intros __wit __varmap __ff ;
     change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
       apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
 
+Ltac nia :=
+  zify ; unfold Zsucc in * ; 
+  xnlia ;
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+
 (* Local Variables: *)
 (* coding: utf-8 *)
 (* End: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index 5ff6a1a7..f64504a5 100644
--- a/plugins/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -173,8 +173,15 @@ 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 qunsat := check_inconsistent 0 Qeq_bool Qle_bool.
+
+Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool.
+
+
+
 Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
   @tauto_checker (Formula Q) (NFormula Q)
+  qunsat qdeduce
   Qnormalise
   Qnegate QWitness QWeakChecker f w.
 
@@ -186,6 +193,11 @@ Proof.
   unfold QTautoChecker.
   apply (tauto_checker_sound  Qeval_formula Qeval_nformula).
   apply Qeval_nformula_dec.
+  intros until env.
+  unfold eval_nformula. unfold RingMicromega.eval_nformula.
+  destruct t.
+  apply (check_inconsistent_sound Qsor QSORaddon) ; auto.
+  unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon).
   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.
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 305d553c..2be99da1 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,6 +16,10 @@ Require Import OrderedRing.
 Require Import RingMicromega.
 Require Import Refl.
 Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Import QArith.
+Require Import Qfield.
+
+
 Require Setoid.
 (*Declare ML Module "micromega_plugin".*)
 
@@ -60,32 +64,405 @@ Proof.
   apply (Rmult_lt_compat_r) ; auto.
 Qed.
 
-Require ZMicromega.
-(* R with coeffs in Z *)
+Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R.
+
+
+Lemma Rinv_elim : forall x y z, 
+  y <> 0 -> (z * y = x <->   x * / y = z).
+Proof.
+  intros.
+  split ; intros.
+  subst.
+  rewrite Rmult_assoc.
+  rewrite Rinv_r; auto.
+  ring.
+  subst.
+  rewrite Rmult_assoc.
+  rewrite (Rmult_comm (/ y)).
+  rewrite Rinv_r ; auto.
+  ring.
+Qed.  
+
+Ltac INR_nat_of_P :=
+  match goal with
+    | H : context[INR (nat_of_P ?X)] |- _ => 
+      revert H ; 
+      let HH := fresh in
+        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (nat_of_P X))
+    | |- context[INR (nat_of_P ?X)] =>
+      let HH := fresh in
+        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (nat_of_P X))
+  end.
+
+Ltac add_eq expr val := set (temp := expr) ; 
+  generalize (refl_equal temp) ; 
+    unfold temp at 1 ; generalize temp ; intro val ; clear temp.
+
+Ltac Rinv_elim :=
+  match goal with
+    | |- context[?x * / ?y] => 
+      let z := fresh "v" in 
+      add_eq (x * / y) z  ;
+      let H := fresh in intro H ; rewrite <- Rinv_elim in H
+  end.
+
+Lemma Rlt_neq : forall r , 0 < r -> r <> 0.
+Proof.
+  red. intros.
+  subst.
+  apply (Rlt_irrefl 0 H).  
+Qed.
+
+
+Lemma Rinv_1 : forall x, x * / 1 = x.
+Proof.
+  intro.
+  Rinv_elim.
+  subst ; ring.
+  apply R1_neq_R0.
+Qed.
+
+Lemma Qeq_true : forall x y,  
+  Qeq_bool x y = true -> 
+   IQR x = IQR y.
+Proof.
+  unfold IQR.
+  simpl.
+  intros.
+  apply Qeq_bool_eq in H.
+  unfold Qeq in H.
+  assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z.
+     rewrite H. reflexivity.
+  repeat rewrite mult_IZR in H0.
+  simpl in H0.
+  revert H0.
+  repeat INR_nat_of_P.
+  intros.
+  apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto].
+  rewrite <- H2.
+  field.
+  split ; apply Rlt_neq ; auto.
+Qed.
+
+Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y.
+Proof.
+  intros.
+  apply Qeq_bool_neq  in H.
+  intro. apply H.   clear H.
+  unfold Qeq,IQR in *.
+  simpl in *.
+  revert H0.
+  repeat Rinv_elim.
+  intros.
+  subst.
+  assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z).
+  repeat rewrite mult_IZR.  
+  simpl.
+  rewrite <- H0. rewrite <- H.
+  ring.
+  apply eq_IZR ; auto.
+  INR_nat_of_P; intros; apply Rlt_neq ; auto. 
+  INR_nat_of_P; intros ; apply Rlt_neq ; auto. 
+Qed.
+
+  
+
+Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y.
+Proof.
+  intros.
+  apply Qle_bool_imp_le in H.
+  unfold Qle in H.
+  unfold IQR.
+  simpl in *.
+  apply IZR_le in H.
+  repeat rewrite mult_IZR in H.
+  simpl in H.
+  repeat INR_nat_of_P; intros.
+  assert (Hr := Rlt_neq r H).
+  assert (Hr0 := Rlt_neq r0 H0).
+  replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)).
+  replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)).
+  apply Rmult_le_compat_r ; auto.
+  apply Rmult_le_pos.
+  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
+  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
+  field ; intuition.
+  field ; intuition.
+Qed.
+
+
+
+Lemma IQR_0 : IQR 0 = 0.
+Proof.
+  compute. apply Rinv_1.
+Qed.
+
+Lemma IQR_1 : IQR 1 = 1.
+Proof.
+  compute. apply Rinv_1.
+Qed.
+
+Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y.
+Proof.
+  intros.
+  unfold IQR.
+  simpl in *.
+  rewrite plus_IZR in *.
+  rewrite mult_IZR in *.
+  simpl.  
+  rewrite nat_of_P_mult_morphism.
+  rewrite mult_INR.
+  rewrite mult_IZR.
+  simpl.
+  repeat INR_nat_of_P.
+  intros. field. 
+  split ; apply Rlt_neq ; auto.
+Qed.
+
+Lemma IQR_opp : forall x, IQR (- x) = - IQR x.
+Proof.
+  intros.
+  unfold IQR.
+  simpl.
+  rewrite opp_IZR.
+  ring.  
+Qed.
+
+Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y.
+Proof.
+  intros.
+  unfold Qminus.
+  rewrite IQR_plus.
+  rewrite IQR_opp.
+  ring.
+Qed.
+
+
+Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y.
+Proof.
+  unfold IQR ; intros.
+  simpl.
+  repeat rewrite mult_IZR.
+  simpl.  
+  rewrite nat_of_P_mult_morphism.
+  rewrite mult_INR.
+  repeat INR_nat_of_P.
+  intros. field ; split ; apply Rlt_neq ; auto.
+Qed.
+
+Lemma IQR_inv_lt : forall x, (0 < x)%Q -> 
+  IQR (/ x) =  / IQR x.
+Proof.
+  unfold IQR ; simpl.
+  intros.
+  unfold Qlt in H.
+  revert H.
+  simpl.
+  intros.
+  unfold Qinv.
+  destruct x ; simpl in *.
+  destruct Qnum ; simpl.
+  exfalso. auto with zarith.
+  clear H.
+  repeat INR_nat_of_P.
+  intros.
+  assert (HH := Rlt_neq _ H).
+  assert (HH0 := Rlt_neq _ H0).
+  rewrite Rinv_mult_distr ; auto.
+  rewrite Rinv_involutive ; auto.
+  ring.
+  apply Rinv_0_lt_compat in H0.
+  apply Rlt_neq ; auto.
+  simpl in H.
+  exfalso.
+  rewrite Pmult_comm  in H.
+  compute in H.
+  discriminate.
+Qed.
+
+Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q.
+Proof.
+  destruct x ; destruct Qnum ; reflexivity.
+Qed.
+
+Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q.
+Proof.
+  intros.
+  destruct x.
+  unfold Qopp.
+  simpl.
+  rewrite Zopp_involutive.
+  reflexivity.
+Qed.
+
+Lemma Ropp_0 : forall r , - r = 0 -> r = 0.
+Proof.
+  intros.
+  rewrite <- (Ropp_involutive r).
+  apply Ropp_eq_0_compat ; auto.
+Qed.
+
+Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q.
+Proof.
+  destruct x ; simpl.
+  unfold IQR.
+  simpl.
+  INR_nat_of_P.
+  intros.
+  apply Rmult_integral in H0.  
+  destruct H0.
+  apply eq_IZR_R0 in H0.
+  subst.
+  reflexivity.
+  exfalso.
+  apply Rinv_0_lt_compat in H.
+  rewrite <- H0 in H.
+  apply Rlt_irrefl in H. auto.
+Qed.
+  
+
+Lemma IQR_inv_gt : forall x, (0 > x)%Q -> 
+  IQR (/ x) =  / IQR x.
+Proof.
+  intros.
+  rewrite <- (Qopp_involutive_strong x).
+  rewrite <- Qinv_opp.
+  rewrite IQR_opp.
+  rewrite IQR_inv_lt.
+  repeat rewrite IQR_opp.
+  rewrite Ropp_inv_permute.
+  auto.
+  intro.
+  apply Ropp_0 in H0.
+  apply IQR_x_0 in H0.
+  rewrite H0 in H.
+  compute in H. discriminate.
+  unfold Qlt in *.
+  destruct x ; simpl in *.
+  auto with zarith.
+Qed.
+
+Lemma IQR_inv : forall x, ~ x ==  0 -> 
+  IQR (/ x) =  / IQR x.
+Proof.
+  intros.
+  assert ( 0 > x \/ 0 < x)%Q.
+   destruct x ; unfold Qlt, Qeq in * ; simpl in *.
+   rewrite Zmult_1_r in *.
+   destruct Qnum ; simpl in * ; intuition auto.
+   right. reflexivity.
+   left ; reflexivity.
+  destruct H0.
+  apply IQR_inv_gt ; auto.
+  apply IQR_inv_lt ; auto.
+Qed.
 
-Lemma RZSORaddon :
-  SORaddon R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
-  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
-  Zeq_bool Zle_bool
-  IZR Nnat.nat_of_N pow.
+Lemma IQR_inv_ext : forall x, 
+  IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x).
+Proof.
+  intros.
+  case_eq (Qeq_bool x 0).
+  intros.
+  apply Qeq_bool_eq in H.
+  destruct x ; simpl.
+  unfold Qeq in H.
+  simpl in H.
+  replace Qnum with 0%Z.
+  compute. rewrite Rinv_1.
+  reflexivity.
+  rewrite <- H. ring.
+  intros.
+  apply IQR_inv.
+  intro.
+  rewrite <- Qeq_bool_iff in H0.
+  congruence.
+Qed.
+
+
+Notation to_nat := N.to_nat. (*Nnat.nat_of_N*)
+
+Lemma QSORaddon :
+  @SORaddon R
+  R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
+  Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *)
+  Qeq_bool Qle_bool
+  IQR nat to_nat pow.
 Proof.
   constructor.
   constructor ; intros ; try reflexivity.
-  apply plus_IZR.
-  symmetry. apply Z_R_minus.
-  apply mult_IZR.
-  apply Ropp_Ropp_IZR.
-  apply IZR_eq.
-  apply Zeq_bool_eq ; auto.
+  apply IQR_0.
+  apply IQR_1.
+  apply IQR_plus.
+  apply IQR_minus.
+  apply IQR_mult.
+  apply IQR_opp.
+  apply Qeq_true ; auto.
   apply R_power_theory.
-  intros x y.
-  intro.
-  apply IZR_neq.
-  apply Zeq_bool_neq ; auto.
-  intros. apply IZR_le.  apply Zle_bool_imp_le. auto.
+  apply Qeq_false.
+  apply Qle_true.
 Qed.
 
 
+(* Syntactic ring coefficients. 
+   For computing, we use Q. *)
+Inductive Rcst :=
+| C0
+| C1
+| CQ (r : Q)
+| CZ (r : Z)
+| CPlus (r1 r2 : Rcst)
+| CMinus (r1  r2 : Rcst)
+| CMult (r1 r2 : Rcst)
+| CInv  (r : Rcst)
+| COpp  (r : Rcst).
+
+
+Fixpoint Q_of_Rcst (r : Rcst) : Q :=
+  match r with
+    | C0 => 0 # 1
+    | C1 => 1 # 1
+    | CZ z => z # 1
+    | CQ q => q
+    | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CMult r1 r2  => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CInv r        => Qinv (Q_of_Rcst r)
+    | COpp r       => Qopp (Q_of_Rcst r)
+  end.
+
+
+Fixpoint R_of_Rcst (r : Rcst) : R :=
+  match r with
+    | C0 => R0
+    | C1 => R1
+    | CZ z => IZR z
+    | CQ q => IQR q
+    | CPlus r1 r2  => (R_of_Rcst r1) + (R_of_Rcst r2)
+    | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2)
+    | CMult r1 r2  => (R_of_Rcst r1) * (R_of_Rcst r2)
+    | CInv r       => 
+      if Qeq_bool (Q_of_Rcst r) (0 # 1)
+        then R0 
+        else Rinv (R_of_Rcst r)
+      | COpp r       => - (R_of_Rcst r)
+  end.
+
+Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c.
+Proof.
+    induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2).
+    apply IQR_0. 
+    apply IQR_1. 
+    reflexivity.
+    unfold IQR. simpl. rewrite Rinv_1. reflexivity.
+    apply IQR_plus.
+    apply IQR_minus.
+    apply IQR_mult.
+    rewrite <- IHc.
+    apply IQR_inv_ext.
+    rewrite <- IHc.
+    apply IQR_opp.
+  Qed.
+
 Require Import EnvRing.
 
 Definition INZ (n:N) : R :=
@@ -94,7 +471,7 @@ Definition INZ (n:N) : R :=
     | Npos p => IZR (Zpos p)
   end.
 
-Definition Reval_expr := eval_pexpr  Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow.
+Definition Reval_expr := eval_pexpr  Rplus Rmult Rminus Ropp R_of_Rcst nat_of_N pow.
 
 
 Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
@@ -108,11 +485,15 @@ Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
     end.
 
 
-Definition Reval_formula (e: PolEnv R) (ff : Formula Z) :=
+Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) :=
   let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).
 
+
 Definition Reval_formula' :=
-  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+  eval_sformula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt nat_of_N pow R_of_Rcst.
+
+Definition QReval_formula := 
+  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR nat_of_N pow .
 
 Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
 Proof.
@@ -126,57 +507,74 @@ Proof.
   apply Rle_ge.
 Qed.
 
-Definition Reval_nformula :=
-  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt IZR.
+Definition Qeval_nformula :=
+  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt IQR.
 
 
-Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
+Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
 Proof.
-  exact (fun env d =>eval_nformula_dec Rsor IZR env d).
+  exact (fun env d =>eval_nformula_dec Rsor IQR env d).
 Qed.
 
-Definition RWitness := Psatz Z.
+Definition RWitness := Psatz Q.
 
-Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult  Zeq_bool Zle_bool.
+Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult  Qeq_bool Qle_bool.
 
 Require Import List.
 
-Lemma RWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : RWitness),
+Lemma RWeakChecker_sound :   forall (l : list (NFormula Q)) (cm : RWitness),
   RWeakChecker l cm = true ->
-  forall env, make_impl (Reval_nformula env) l False.
+  forall env, make_impl (Qeval_nformula env) l False.
 Proof.
   intros l cm H.
   intro.
-  unfold Reval_nformula.
-  apply (checker_nf_sound Rsor RZSORaddon l cm).
+  unfold Qeval_nformula.
+  apply (checker_nf_sound Rsor QSORaddon l cm).
   unfold RWeakChecker in H.
   exact H.
 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 Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
+Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
+
+Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool.
 
-Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness)  : bool :=
-  @tauto_checker (Formula Z) (NFormula Z)
+Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool.
+
+Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness)  : bool :=
+  @tauto_checker (Formula Q) (NFormula Q)
+  runsat rdeduce
   Rnormalise Rnegate
-  RWitness RWeakChecker f w.
+  RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst)  f) w.
 
 Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f  (Reval_formula env)  f.
 Proof.
   intros f w.
   unfold RTautoChecker.
-  apply (tauto_checker_sound  Reval_formula Reval_nformula).
+  intros TC env.
+  apply (tauto_checker_sound  QReval_formula Qeval_nformula) with (env := env) in TC.
+  rewrite eval_f_map in TC.
+  rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto.
+  intro.
+  unfold QReval_formula.
+  rewrite <- eval_formulaSC  with (phiS := R_of_Rcst).
+  rewrite Reval_formula_compat.
+  tauto.
+  intro. rewrite Q_of_RcstR. reflexivity.
   apply Reval_nformula_dec.
-  intros. rewrite Reval_formula_compat.
-  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).
+  destruct t.
+  apply (check_inconsistent_sound Rsor QSORaddon) ; auto.
+  unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon).
+  now apply (cnf_normalise_correct Rsor QSORaddon).  
+  intros. now apply (cnf_negate_correct Rsor QSORaddon).
   intros t w0.
   apply RWeakChecker_sound.
 Qed.
 
 
+
 (* Local Variables: *)
 (* coding: utf-8 *)
 (* End: *)
diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v
index 53413b4a..b839195c 100644
--- a/plugins/micromega/Refl.v
+++ b/plugins/micromega/Refl.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index b10cf784..4af65086 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -308,7 +308,7 @@ Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :
     | Some x => f x
   end.
 
-Implicit Arguments map_option [A B].
+Arguments map_option [A B] f o.
 
 Definition map_option2 (A B C : Type) (f : A -> B -> option C)
   (o: option A) (o': option B) : option C :=
@@ -318,7 +318,7 @@ Definition map_option2 (A B C : Type) (f : A -> B -> option C)
     | Some x , Some x' => f x x'
   end.
 
-Implicit Arguments map_option2 [A B C].
+Arguments map_option2 [A B C] f o o'.
 
 Definition Rops_wd := mk_reqe rplus rtimes ropp req
                        sor.(SORplus_wd)
@@ -355,6 +355,7 @@ Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula
     | 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'.
@@ -490,6 +491,99 @@ Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz)  : list nat :=
     | PsatzIn n => if ge_bool n base then (n::acc) else acc
   end.
 
+Fixpoint nhyps_of_psatz (prf : Psatz) : list nat :=
+  match prf with
+    | PsatzC _ | PsatzZ | PsatzSquare _ => nil
+    | PsatzMulC _ prf => nhyps_of_psatz prf
+    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2
+    | PsatzIn n => n :: nil
+  end.
+
+
+Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula  :=
+  match ln with
+    | nil => nil
+    | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln
+  end.
+      
+Lemma extract_hyps_app : forall l ln1 ln2,
+  extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2).
+Proof.
+  induction ln1.
+  reflexivity.
+  simpl.
+  intros.
+  rewrite IHln1. reflexivity.
+Qed.
+  
+Ltac inv H := inversion H ; try subst ; clear H.
+
+Lemma nhyps_of_psatz_correct :  forall (env : PolEnv) (e:Psatz)  (l : list NFormula)  (f: NFormula),
+  eval_Psatz l e = Some f -> 
+  ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') ->  eval_nformula env f).
+Proof.
+  induction e ; intros.
+  (*PsatzIn*)
+  simpl in *. 
+  apply H0. intuition congruence.
+  (* PsatzSquare *)
+  simpl in *.
+  inv H.
+  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 in *.
+  case_eq (eval_Psatz l e).
+  intros. rewrite H1 in H. simpl in H.
+  apply pexpr_times_nformula_correct with (2:= H).
+  apply IHe with (1:= H1); auto.
+  intros. rewrite H1 in H. simpl in H ; discriminate.
+  (* PsatzMulE *)
+  simpl in *.
+  revert H.
+  case_eq (eval_Psatz l e1).
+  case_eq (eval_Psatz l e2) ; simpl ; intros.
+  apply nformula_times_nformula_correct with (3:= H2).
+  apply IHe1 with (1:= H1) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  apply IHe2 with (1:= H) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  discriminate. simpl. discriminate.
+  (* PsatzAdd *)
+  simpl in *.
+  revert H.
+  case_eq (eval_Psatz l e1).
+  case_eq (eval_Psatz l e2) ; simpl ; intros.
+  apply nformula_plus_nformula_correct with (3:= H2).
+  apply IHe1 with (1:= H1) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  apply IHe2 with (1:= H) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  discriminate. simpl. discriminate.
+  (* PsatzC *)
+  simpl in H.
+  case_eq (cO [<] c).
+  intros.  rewrite H1 in H. inv H.
+  unfold eval_nformula. simpl.
+  rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+  intros. rewrite H1 in H. discriminate.
+  (* PsatzZ *)
+  simpl in *. inv H. 
+  unfold eval_nformula. simpl.
+  apply  addon.(SORrm).(morph0).
+Qed.
+  
+
+
+
+
 
 (* roughly speaking, normalise_pexpr_correct is a proof of
   forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
@@ -546,6 +640,7 @@ 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
@@ -592,16 +687,17 @@ 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;
+Record Formula (T:Type) : Type := {
+  Flhs : PExpr T;
   Fop : Op2;
-  Frhs : PExpr C
+  Frhs : PExpr T
 }.
 
-Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
+Definition eval_formula (env : PolEnv) (f : Formula C) : 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.
@@ -610,7 +706,7 @@ Definition psub := Psub cO  cplus cminus copp ceqb.
 
 Definition padd  := Padd cO  cplus ceqb.
 
-Definition normalise (f : Formula) : NFormula :=
+Definition normalise (f : Formula C) : NFormula :=
 let (lhs, op, rhs) := f in
   let lhs := norm lhs in
     let rhs := norm rhs in
@@ -623,7 +719,7 @@ let (lhs, op, rhs) := f in
   | OpLt => (psub  rhs lhs, Strict)
   end.
 
-Definition negate (f : Formula) : NFormula :=
+Definition negate (f : Formula C) : NFormula :=
 let (lhs, op, rhs) := f in
   let lhs := norm lhs in
     let rhs := norm rhs in
@@ -659,7 +755,7 @@ Qed.
 
 
 Theorem normalise_sound :
-  forall (env : PolEnv) (f : Formula),
+  forall (env : PolEnv) (f : Formula C),
     eval_formula env f -> eval_nformula env (normalise f).
 Proof.
 intros env f H; destruct f as [lhs op rhs]; simpl in *.
@@ -673,7 +769,7 @@ now apply -> (Rlt_lt_minus sor).
 Qed.
 
 Theorem negate_correct :
-  forall (env : PolEnv) (f : Formula),
+  forall (env : PolEnv) (f : Formula C),
     eval_formula env f <-> ~ (eval_nformula env (negate f)).
 Proof.
 intros env f; destruct f as [lhs op rhs]; simpl.
@@ -687,9 +783,9 @@ 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 **)
+(** Another normalisation - this is used for cnf conversion **)
 
-Definition xnormalise (t:Formula) : list (NFormula)  :=
+Definition xnormalise (t:Formula C) : list (NFormula)  :=
   let (lhs,o,rhs) := t in
   let lhs := norm lhs in
     let rhs := norm rhs in
@@ -705,16 +801,16 @@ Definition xnormalise (t:Formula) : list (NFormula)  :=
 
 Require Import Tauto.
 
-Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
+Definition cnf_normalise (t:Formula C) : 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.
+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.
+  unfold eval_cnf, eval_clause.
   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);
@@ -730,7 +826,7 @@ Proof.
   rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
 Qed.
 
-Definition xnegate (t:Formula) : list (NFormula)  :=
+Definition xnegate (t:Formula C) : list (NFormula)  :=
   let (lhs,o,rhs) := t in
     let lhs := norm lhs in
       let rhs := norm rhs in
@@ -743,13 +839,13 @@ Definition xnegate (t:Formula) : list (NFormula)  :=
       | OpLe  => (psub rhs lhs,NonStrict) :: nil
     end.
 
-Definition cnf_negate (t:Formula) : cnf (NFormula) :=
+Definition cnf_negate (t:Formula C) : 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.
+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.
+  unfold eval_cnf, eval_clause.
   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);
@@ -841,6 +937,63 @@ Proof.
 Qed.
 
 
+(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real"
+coefficients that are used to actually compute *)
+
+
+
+Variable S : Type.
+
+Variable C_of_S : S -> C.
+
+Variable phiS : S -> R.
+
+Variable phi_C_of_S :   forall c,  phiS c =  phi (C_of_S c).
+
+Fixpoint map_PExpr (e : PExpr S) : PExpr C :=
+  match e with
+    | PEc c => PEc (C_of_S c)
+    | PEX p => PEX _ p
+    | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2)
+    | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2)
+    | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2)
+    | PEopp e     => PEopp (map_PExpr e)
+    | PEpow e n   => PEpow (map_PExpr e) n
+  end.
+
+Definition map_Formula (f : Formula S)  : Formula C :=
+  let (l,o,r) := f in
+    Build_Formula (map_PExpr l) o (map_PExpr r).
+
+
+Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R :=
+  PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e.
+
+Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop :=
+  let (lhs, op, rhs) := f in
+    (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs).
+
+Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s).
+Proof.
+  unfold eval_pexpr, eval_sexpr.
+  induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity.
+  apply phi_C_of_S.
+  rewrite IHs. reflexivity.
+  rewrite IHs. reflexivity.
+Qed.
+
+(** equality migth be (too) strong *)
+Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f).
+Proof.
+  destruct f.
+  simpl.
+  repeat rewrite eval_pexprSC.
+  reflexivity.
+Qed.
+
+
+
+
 (** Some syntactic simplifications of expressions  *)
 
 
@@ -881,4 +1034,4 @@ End Micromega.
 
 (* Local Variables: *)
 (* coding: utf-8 *)
-(* End: *)
\ No newline at end of file
+(* End: *)
diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v
index 0706611c..b3ccdfcc 100644
--- a/plugins/micromega/Tauto.v
+++ b/plugins/micromega/Tauto.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-20011                            *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -41,6 +41,37 @@ Set Implicit Arguments.
       | I f1 f2 => (eval_f  ev f1) -> (eval_f  ev f2)
     end.
 
+  Lemma eval_f_morph : forall  A (ev ev' : A -> Prop) (f : BFormula A),
+    (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f).
+  Proof.
+    induction f ; simpl ; try tauto.
+    intros.
+    assert (H' := H a).
+    auto.
+  Qed.
+
+
+
+  Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
+    match f with
+      | TT => TT _
+      | FF => FF _
+      | X p => X _ p
+      | A a => A (fct a)
+      | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
+      | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
+      | N f     => N (map_bformula fct f)
+      | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2)
+    end.
+
+  Lemma eval_f_map : forall T U (fct: T-> U) env f ,
+    eval_f env  (map_bformula fct f)  = eval_f (fun x => env (fct x)) f.
+  Proof.
+    induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto.
+    rewrite <- IHf.  auto.    
+  Qed.
+
+
 
   Lemma map_simpl : forall A B f l, @map A B f l = match l with
                                                  | nil => nil
@@ -52,6 +83,7 @@ Set Implicit Arguments.
 
 
 
+
   Section S.
 
     Variable Env   : Type.
@@ -64,6 +96,15 @@ Set Implicit Arguments.
 
     Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
 
+    Variable unsat : Term'  -> bool.
+
+    Variable unsat_prop : forall t, unsat t  = true ->  
+      forall env, eval' env t -> False. 
+
+    Variable deduce : Term' -> Term' -> option Term'.
+
+    Variable deduce_prop : forall env t t' u,
+      eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u.
 
     Definition clause := list  Term'.
     Definition cnf := list clause.
@@ -76,8 +117,48 @@ Set Implicit Arguments.
     Definition ff : cnf :=  cons (@nil Term') nil.
 
 
+    Fixpoint add_term (t: Term') (cl : clause) : option clause :=
+      match cl with
+        | nil => 
+          match deduce t t with
+            | None =>  Some (t ::nil)
+            | Some u => if unsat u then None else Some (t::nil)
+          end
+        | t'::cl => 
+          match deduce t t' with
+            | None => 
+              match add_term t cl with
+                | None => None
+                | Some cl' => Some (t' :: cl')
+              end
+            | Some u => 
+              if unsat u then None else 
+                match add_term t cl with
+                  | None => None
+                  | Some cl' => Some (t' :: cl')
+                end
+          end
+      end.
+
+    Fixpoint or_clause (cl1 cl2 : clause) : option clause :=
+      match cl1 with
+        | nil => Some cl2
+        | t::cl => match add_term t cl2 with
+                     | None => None
+                     | Some cl' => or_clause cl cl'
+                   end
+      end.
+
+(*    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
+      List.map (fun x => (t++x)) f. *)
+
     Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
-      List.map (fun x => (t++x)) f.
+      List.fold_right (fun e acc => 
+        match or_clause t e with
+          | None => acc
+          | Some cl => cl :: acc
+        end) nil f.
+
 
     Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
       match f with
@@ -102,46 +183,154 @@ Set Implicit Arguments.
         | 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.
+    Definition eval_clause (env : Env) (cl : clause) := ~ make_conj  (eval' env) cl.
+
+    Definition eval_cnf (env : Env) (f:cnf) := make_conj  (eval_clause  env) f.
+
+    
+    Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y.
+    Proof.
+      unfold eval_cnf.
+      intros.
+      rewrite make_conj_app in H ; auto.
+    Qed.
+
+
+    Definition eval_opt_clause (env : Env) (cl: option clause) :=
+      match cl with
+        | None => True
+        | Some cl => eval_clause env cl
+      end.
 
 
-  Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
+    Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl).
+    Proof.
+      induction cl.
+      (* BC *)
+      simpl.
+      case_eq (deduce t t) ; auto.
+      intros until 0.
+      case_eq (unsat t0) ; auto.
+      unfold eval_clause.
+      rewrite make_conj_cons. 
+      intros. intro.
+      apply unsat_prop with (1:= H) (env := env).
+      apply deduce_prop with (3:= H0) ; tauto.
+      (* IC *)
+      simpl.
+      case_eq (deduce t a).
+      intro u.
+      case_eq (unsat u).
+      simpl. intros.
+      unfold eval_clause.
+      intro.
+      apply unsat_prop  with (1:= H) (env:= env).
+      repeat rewrite make_conj_cons in H2.
+      apply deduce_prop with (3:= H0); tauto.
+      intro.
+      case_eq (add_term t cl) ; intros.
+      simpl in H2.
+      rewrite H0 in IHcl.
+      simpl in IHcl.
+      unfold eval_clause in *.
+      intros.
+      repeat rewrite make_conj_cons in *.
+      tauto.
+      rewrite H0 in IHcl ; simpl in *.
+      unfold eval_clause in *.
+      intros.
+      repeat rewrite make_conj_cons in *.
+      tauto.
+      case_eq (add_term t cl) ; intros.
+      simpl in H1.
+      unfold eval_clause in *.
+      repeat rewrite make_conj_cons in *.
+      rewrite H in IHcl.
+      simpl in IHcl.
+      tauto.
+      simpl in *.
+      rewrite H in IHcl.
+      simpl in IHcl.
+      unfold eval_clause in *.
+      repeat rewrite make_conj_cons in *.    
+      tauto.
+    Qed.
+
+
+  Lemma or_clause_correct : forall cl cl' env,  eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'.
   Proof.
-    unfold eval_cnf.
+    induction cl.
+    simpl. tauto.
+    intros until 0.
+    simpl.
+    assert (HH := add_term_correct env a cl').
+    case_eq (add_term a cl').
+    simpl in *.
+    intros.
+    apply IHcl in H0.
+    rewrite H in HH.
+    simpl in HH.
+    unfold eval_clause in *.
+    destruct H0.
+    repeat rewrite make_conj_cons in *.
+    tauto.
+    apply HH in H0.
+    apply not_make_conj_cons in H0 ; auto.
+    repeat rewrite make_conj_cons in *.
+    tauto.
+    simpl.
     intros.
-    rewrite make_conj_app in H ; auto.
+    rewrite H in HH.
+    simpl in HH.
+    unfold eval_clause in *.
+    assert (HH' := HH Coq.Init.Logic.I).
+    apply not_make_conj_cons in HH'; auto.
+    repeat rewrite make_conj_cons in *.
+    tauto.
   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).
+  Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f).
   Proof.
     unfold eval_cnf.
     unfold or_clause_cnf.
+    intros until t.
+    set (F := (fun (e : clause) (acc : list clause) =>
+         match or_clause t e with
+         | Some cl => cl :: acc
+         | None => acc
+         end)).
     induction f.
-    simpl.
-    intros ; right;auto.
+    auto.
     (**)
-    rewrite map_simpl.
+    simpl.
     intros.
-    rewrite make_conj_cons in H.
-    destruct H as [HH1 HH2].
-    generalize (IHf HH2) ; clear IHf ; intro.
-    destruct H.
-    left ; auto.
-    rewrite make_conj_cons.
-    destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1).
-    tauto.
+    destruct f.
+    simpl in H.
+    simpl in IHf. 
+    unfold F in H.
+    revert H.
+    intros.
+    apply or_clause_correct.
+    destruct (or_clause t a) ; simpl in * ; auto.
+    unfold F in H at 1.
+    revert H.
+    assert (HH := or_clause_correct t a env).
+    destruct (or_clause t a); simpl in HH ;
+    rewrite make_conj_cons in * ; intuition.
+    rewrite make_conj_cons in *.
     tauto.
   Qed.
 
- Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f).
+
+ Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f).
  Proof.
    intros.
    unfold eval_cnf in *.
    rewrite make_conj_cons ; eauto.
  Qed.
 
-  Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env)  f) \/ (eval_cnf (eval' env) f').
+  Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env  f) \/ (eval_cnf  env f').
   Proof.
     induction f.
     unfold eval_cnf.
@@ -153,19 +342,19 @@ Set Implicit Arguments.
     destruct (eval_cnf_app _ _ _ H).
     clear H.
     destruct (IHf _ H0).
-    destruct (or_clause_correct _ _ _ H1).
+    destruct (or_clause_cnf_correct _ _ _ H1).
     left.
     apply eval_cnf_cons ; auto.
     right ; auto.
     right ; auto.
   Qed.
 
-  Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t.
+  Variable normalise_correct : forall env t, eval_cnf  env (normalise t) -> eval env t.
 
-  Variable negate_correct : forall env t, eval_cnf  (eval' env) (negate t) -> ~ eval env t.
+  Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t.
 
 
-  Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
+  Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
   Proof.
     induction f.
     (* TT *)
@@ -175,15 +364,19 @@ Set Implicit Arguments.
     (* FF *)
     unfold eval_cnf.
     destruct pol; simpl ; auto.
+    unfold eval_clause ; simpl.
+    tauto.
     (* P *)
     simpl.
     destruct pol ; intros ;simpl.
     unfold eval_cnf in H.
     (* Here I have to drop the proposition *)
     simpl in H.
+    unfold eval_clause in H ; simpl in H.
     tauto.
     (* Here, I could store P in the clause *)
     unfold eval_cnf in H;simpl in H.
+    unfold eval_clause in H ; simpl in H.
     tauto.
     (* A *)
     simpl.
@@ -282,7 +475,7 @@ Set Implicit Arguments.
                 end
       end.
 
-  Lemma cnf_checker_sound : forall t  w, cnf_checker t w = true -> forall env, eval_cnf  (eval' env)  t.
+  Lemma cnf_checker_sound : forall t  w, cnf_checker t w = true -> forall env, eval_cnf  env  t.
   Proof.
     unfold eval_cnf.
     induction t.
@@ -319,7 +512,6 @@ Set Implicit Arguments.
 
 
 
-
 End S.
 
 (* Local Variables: *)
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 7d25524a..f41252b7 100644
--- a/plugins/micromega/VarMap.v
+++ b/plugins/micromega/VarMap.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -18,11 +18,12 @@ Require Import Coq.Arith.Max.
 Require Import List.
 Set Implicit Arguments.
 
-(* 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.
-   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
-*)
+(* 
+ * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v)
+ * --- it is harmless and spares a lot of Empty.
+ * It also means smaller proof-terms.
+ * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up.
+ *)
 
 Section MakeVarMap.
   Variable A : Type.
@@ -33,7 +34,7 @@ Section MakeVarMap.
   | Leaf : A -> t
   | Node : t  -> A -> t  -> t .
 
-  Fixpoint find   (vm : t ) (p:positive) {struct vm} : A :=
+  Fixpoint find (vm : t) (p:positive) {struct vm} : A :=
     match vm with
       | Empty => default
       | Leaf i => i
@@ -44,216 +45,6 @@ Section MakeVarMap.
                       end
     end.
 
- (* 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 ) :=
-    let (o,m) := l in
-      match o with
-        | None => (Some j,m)
-        | Some j0 => (Some (j+j0)%positive,m)
-      end.
-
-  Definition nth  (n:positive) (l: off_map ) :=
-    let (o,m) := l in
-      let idx  := match o with
-                    | None => n
-                    | Some i => i + n
-                  end%positive in
-      find  idx m.
-
-
-  Definition hd  (l:off_map) := nth  xH l.
-
-
-  Definition tail (l:off_map ) := jump xH l.
-
-
-  Lemma psucc : forall p,  (match p with
-                              | xI y' => xO (Psucc y')
-                              | xO y' => xI y'
-                              | 1%positive => 2%positive
-                            end) = (p+1)%positive.
-  Proof.
-    destruct p.
-    auto with zarith.
-    rewrite xI_succ_xO.
-    auto with zarith.
-    reflexivity.
-  Qed.
-
-  Lemma jump_Pplus : forall i j l,
-    (jump (i + j) l) = (jump i (jump j l)).
-  Proof.
-    unfold jump.
-    destruct l.
-    destruct o.
-    rewrite Pplus_assoc.
-    reflexivity.
-    reflexivity.
-  Qed.
-
-  Lemma jump_simpl : forall p l,
-    jump p l =
-    match p with
-      | xH => tail l
-      | xO p => jump p (jump p l)
-      | xI p  => jump p (jump p (tail l))
-    end.
-  Proof.
-    destruct p ; unfold tail ; intros ;  repeat rewrite <- jump_Pplus.
-    (* xI p = p + p + 1 *)
-    rewrite xI_succ_xO.
-    rewrite Pplus_diag.
-    rewrite <- Pplus_one_succ_r.
-    reflexivity.
-    (* xO p = p + p *)
-    rewrite Pplus_diag.
-    reflexivity.
-    reflexivity.
-  Qed.
-
-  Ltac jump_s :=
-    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.
-    unfold tail.
-    intros.
-    repeat rewrite <- jump_Pplus.
-    rewrite Pplus_comm.
-    reflexivity.
-  Qed.
-
-  Lemma jump_Psucc : forall j l,
-    (jump (Psucc j) l) = (jump 1 (jump j l)).
-  Proof.
-    intros.
-    rewrite <- jump_Pplus.
-    rewrite Pplus_one_succ_r.
-    rewrite Pplus_comm.
-    reflexivity.
-  Qed.
-
-  Lemma jump_Pdouble_minus_one : forall i l,
-    (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
-  Proof.
-    unfold tail.
-    intros.
-    repeat rewrite <- jump_Pplus.
-    rewrite <- Pplus_one_succ_r.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    rewrite Pplus_diag.
-    reflexivity.
-  Qed.
-
-  Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
-  Proof.
-    intros.
-    jump_s.
-    repeat rewrite <- jump_Pplus.
-    reflexivity.
-  Qed.
-
-
-  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.
-  Proof.
-    unfold nth.
-    destruct l.
-    destruct o.
-    simpl.
-    rewrite psucc.
-    destruct p.
-    replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
-    reflexivity.
-    rewrite xI_succ_xO.
-    rewrite Pplus_one_succ_r.
-    rewrite <- Pplus_diag.
-    rewrite Pplus_comm.
-    symmetry.
-    rewrite (Pplus_comm p0).
-    rewrite <- Pplus_assoc.
-    rewrite (Pplus_comm 1)%positive.
-    rewrite <- Pplus_assoc.
-    reflexivity.
-  (**)
-    replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
-    reflexivity.
-    rewrite <- Pplus_diag.
-    rewrite <- Pplus_assoc.
-    rewrite Pplus_comm.
-    rewrite Pplus_assoc.
-    reflexivity.
-    reflexivity.
-    simpl.
-    destruct p.
-    rewrite xI_succ_xO.
-    rewrite Pplus_one_succ_r.
-    rewrite <- Pplus_diag.
-    symmetry.
-    rewrite Pplus_comm.
-    rewrite Pplus_assoc.
-    reflexivity.
-    rewrite Pplus_diag.
-    reflexivity.
-    reflexivity.
-  Qed.
-
-
-  Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
-  Proof.
-    destruct l.
-    unfold tail.
-    unfold hd.
-    unfold jump.
-    unfold nth.
-    destruct o.
-    symmetry.
-    rewrite Pplus_comm.
-    rewrite <- Pplus_assoc.
-    rewrite (Pplus_comm p0).
-    reflexivity.
-    rewrite Pplus_comm.
-    reflexivity.
-  Qed.
-
-  Lemma nth_Pdouble_minus_one :
-    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
-  Proof.
-    destruct l.
-    unfold tail.
-    unfold nth, jump.
-    destruct o.
-    rewrite ((Pplus_comm p)).
-    rewrite <- (Pplus_assoc p0).
-    rewrite Pplus_diag.
-    rewrite <- Psucc_o_double_minus_one_eq_xO.
-    rewrite Pplus_one_succ_r.
-    rewrite (Pplus_comm (Pdouble_minus_one p)).
-    rewrite Pplus_assoc.
-    rewrite (Pplus_comm p0).
-    reflexivity.
-    rewrite <- Pplus_one_succ_l.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    rewrite Pplus_diag.
-    reflexivity.
-  Qed.
-
-*)
 
 End MakeVarMap.
 
diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
index cf2bca49..2bf3d8c3 100644
--- a/plugins/micromega/ZCoeff.v
+++ b/plugins/micromega/ZCoeff.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -138,7 +138,7 @@ Qed.
 
 Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
 Proof.
-unfold Zlt; intros x y H;
+intros x y H.
 do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
 destruct x; destruct y; simpl in *; try discriminate.
 apply phi_pos1_pos.
@@ -146,8 +146,8 @@ now apply clt_pos_morph.
 apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
 apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
 apply phi_pos1_pos.
-rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor).
-now apply clt_pos_morph.
+apply -> (Ropp_lt_mono sor); apply clt_pos_morph.
+red. now rewrite Pos.compare_antisym.
 Qed.
 
 Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index d6245681..461f53b5 100644
--- a/plugins/micromega/ZMicromega.v
+++ b/plugins/micromega/ZMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2011                             *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -194,27 +194,27 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
       | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
     end.
 
-Require Import Tauto.
+Require Import Tauto BinNums.
 
 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.
+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.
+  unfold eval_cnf, eval_clause.
   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);
+    (fun x : 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;
+    (fun x : N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
   Transparent padd.
 Qed.
@@ -235,31 +235,34 @@ Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
 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.
+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.
+  unfold eval_cnf,eval_clause.
   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);
+    (fun x : 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;
+    (fun x : N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
   Transparent padd.
 Qed.
 
+Definition Zunsat := check_inconsistent 0  Zeq_bool Zle_bool.
+
+Definition Zdeduce := nformula_plus_nformula 0 Zplus Zeq_bool.
 
 
 Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
-  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZWitness ZWeakChecker f w.
+  @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate  ZWitness ZWeakChecker f w.
 
 (* To get a complete checker, the proof format has to be enriched *)
 
@@ -273,6 +276,26 @@ Definition ceiling (a b:Z) : Z :=
       | _  => q + 1
     end.
 
+
+Require Import Znumtheory.
+
+Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Zdiv a b.
+Proof.
+  unfold ceiling.
+  intros.
+  apply Zdivide_mod in H.
+  case_eq (Zdiv_eucl a b).
+  intros.
+  change z with (fst (z,z0)).
+  rewrite <- H0.
+  change (fst (Zdiv_eucl a b)) with (Zdiv a b).
+  change z0 with (snd (z,z0)).
+  rewrite <- H0.
+  change (snd (Zdiv_eucl a b)) with (Zmod a b).
+  rewrite H.
+  reflexivity.
+Qed.
+
 Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
 Proof.
   unfold ceiling.
@@ -307,40 +330,13 @@ 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).
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof
+(*| SplitProof :   PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*).
 
-(* 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).
+(* n/d <= x  -> d*x - n >= 0 *)
 
-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
@@ -566,9 +562,11 @@ 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)))
+        if andb (Zgt_bool g Z0) (andb (negb (Zeq_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 *)
+          else (* Could be optimised Zgcd_pol is recomputed *)
+            let (p,c) := makeCuttingPlane e  in
+              Some (p,c,Equal)
       | NonEqual => Some (e,Z0,op)
       | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in
         Some (p,c,NonStrict)
@@ -596,16 +594,16 @@ Proof.
 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.
-
-
+Definition valid_cut_sign (op:Op1) :=
+  match op with 
+    | Equal => true
+    | NonStrict => true
+    | _         => false
+  end.
 
 Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :=
   match pf with
@@ -614,7 +612,7 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :
       match eval_Psatz l w  with
         | None => false
         | Some f =>
-          if check_inconsistent f then true
+          if Zunsat f then true
             else ZChecker (f::l) pf
       end
     | CutProof w pf =>
@@ -627,29 +625,24 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :
           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.
+       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) =>
+               if (valid_cut_sign op1 && valid_cut_sign op2 && 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
+              |   _    ,   _   => true
+           end
+          |   _   ,  _ => false
+    end
+end.
 
 
 
@@ -702,7 +695,7 @@ Proof.
   apply make_conj_in ; auto.
 Qed.
 
-Lemma makeCuttingPlane_sound : forall env e e' c,
+Lemma makeCuttingPlane_ns_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)).
@@ -729,7 +722,6 @@ Proof.
   intros. inv H2. auto with zarith.
 Qed.
 
-
 Lemma cutting_plane_sound : forall env f p,
   eval_nformula env f ->
   genCuttingPlane f = Some p ->
@@ -741,13 +733,51 @@ Proof.
   (* 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.
+  case_eq (Zgt_bool g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|].
+  case_eq (makeCuttingPlane e).
+  intros.
+  inv H3.
+  unfold makeCuttingPlane in H.
+  rewrite H1 in H.
+  revert H.
+  change (eval_pol env e = 0) in H2.
+  case_eq (Zgt_bool g 0).
+  intros.
+  rewrite <- Zgt_is_gt_bool in H.  
+  rewrite Zgcd_pol_correct_lt with (1:= H1)  in H2; auto with zarith.
+  unfold nformula_of_cutting_plane.  
+  change (eval_pol env (padd e' (Pc z)) = 0).
+  inv H3.
+  rewrite eval_pol_add.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Zminus e c) g)) in *; clearbody x.
+  simpl.
+  rewrite andb_false_iff in H0.
+  destruct H0.
+  rewrite Zgt_is_gt_bool in H ; congruence.
+  rewrite andb_false_iff in H0.
+  destruct H0.
+  rewrite negb_false_iff in H0.
+  apply Zeq_bool_eq in H0.
+  subst. simpl.
+  rewrite Zplus_0_r in H2.
+  apply Zmult_integral in H2.
+  intuition auto with zarith.
+  rewrite negb_false_iff in H0.
+  apply Zeq_bool_eq in H0.
+  assert (HH := Zgcd_is_gcd g c).
+  rewrite H0 in HH.
+  inv HH.
+  apply Zdivide_opp_r in H4.
+  rewrite Zdivide_ceiling ; auto.
+  apply Zeq_minus.
+  apply Z.div_unique_exact ; auto with zarith.
+  intros.
+  unfold nformula_of_cutting_plane.
+  inv H3.
+  change (eval_pol env (padd e' (Pc 0)) = 0).
+  rewrite eval_pol_add.
+  simpl.
+  auto with zarith.
   (* NonEqual *)
   intros.
   inv H0.
@@ -762,7 +792,7 @@ Proof.
   case_eq (makeCuttingPlane (PsubC Zminus e 1)).
   intros.
   inv H1.
-  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  apply makeCuttingPlane_ns_sound with (env:=env) (2:= H).
   simpl in *.
   rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
   auto with zarith.
@@ -771,7 +801,7 @@ Proof.
   case_eq (makeCuttingPlane e).
   intros.
   inv H1.
-  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  apply makeCuttingPlane_ns_sound with (env:=env) (2:= H).
   assumption.
 Qed.
 
@@ -783,23 +813,24 @@ Proof.
   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))).
+  case_eq (Zgt_bool g 0 && (negb (Zeq_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.
+  rewrite negb_true_iff in H.
+  apply Zeq_bool_neq in H.
   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.
+  contradict H5.
+  apply Zis_gcd_gcd; auto with zarith.
+  constructor; auto with zarith.
   exists (-x).
   rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith.
   (**)
-  discriminate.
+  destruct (makeCuttingPlane p);  discriminate.
   discriminate.
   destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
   destruct (makeCuttingPlane p) ; discriminate.
@@ -816,11 +847,11 @@ Proof.
   simpl.
   intro l. case_eq (eval_Psatz l w) ; [| discriminate].
   intros f Hf.
-  case_eq (check_inconsistent f).
+  case_eq (Zunsat 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.
+  unfold Zunsat in H0. assumption.
   intros.
   assert (make_impl  (eval_nformula env) (f::l) False).
    apply H with (2:= H1).
@@ -868,55 +899,54 @@ Proof.
   case_eq (eval_Psatz l w1) ; [  | discriminate].
   case_eq (eval_Psatz l w2) ; [  | discriminate].
   intros f1 Hf1 f2 Hf2.
-  case_eq (genCuttingPlane f2) ;  [  | discriminate].
+  case_eq (genCuttingPlane f2).
   destruct p as [ [p1 z1] op1].
-  case_eq (genCuttingPlane f1) ;  [  | discriminate].
+  case_eq (genCuttingPlane f1).
   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.
+  case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)).
+  intros Hcond.
+  flatten_bool.
+  rename H1 into HZ0.
+  rename H2 into Hop1.
+  rename H3 into Hop2.
+  intros HCutL HCutR Hfix env.
   (* 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 cutting_plane_sound with (1:= Hf2) in HCutR.
+   unfold nformula_of_cutting_plane in HCutR.
+   unfold eval_nformula in HCutR.
+   unfold RingMicromega.eval_nformula in HCutR.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in HCutR.
+   unfold eval_op1 in HCutR.
+   destruct op1 ; simpl in Hop1 ; try discriminate;
+     rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith.
    (**)
-   apply is_pol_Z0_eval_pol with (env := env) in H0.
-   rewrite eval_pol_add in H0.
+   apply is_pol_Z0_eval_pol with (env := env) in HZ0.
+   rewrite eval_pol_add in HZ0.
    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)).
+   apply cutting_plane_sound with (1:= Hf1) in HCutL.
+   unfold nformula_of_cutting_plane in HCutL.
+   unfold eval_nformula in HCutL.
+   unfold RingMicromega.eval_nformula in HCutL.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in HCutL.
+   unfold eval_op1 in HCutL.
+   rewrite eval_pol_add in HCutL. simpl in HCutL.
+   destruct op2 ; simpl in Hop2 ; try discriminate ;  omega.
+  revert Hfix.
+  match goal with
+    | |- context[?F pf (-z1) z2 = true] => set (FF := F)
+  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.
+  clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1.
+  revert Hfix.
   generalize (-z1). clear z1. intro z1.
   revert z1 z2.
   induction pf;simpl ;intros.
@@ -931,16 +961,22 @@ Proof.
   subst.
   exists a ; auto.
   assert (z1 + 1 <= x <= z2)%Z by omega.
-  destruct (IHpf _ _ H1 _ H3).
+  elim IHpf with (2:=H2) (3:= H4).
   destruct H4.
-  exists x0 ; split;auto.
+  intros.
+  exists x0 ; split;tauto.
+  intros until 1. 
+  apply H ; auto. 
+  unfold ltof in *.
+  simpl in *.
+  zify. omega.
   (*/asser *)
-  destruct (HH _ H7) as [pr [Hin Hcheker]].
+  destruct (HH _ H1) 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_impl in H2.
+  apply H2.
   rewrite  make_conj_cons.
   split ;auto.
   unfold  eval_nformula.
@@ -948,10 +984,23 @@ Proof.
   simpl.
   rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
   unfold eval_pol. ring.
+  discriminate.
+  (* No cutting plane *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hf1) in H3.
+  apply genCuttingPlaneNone with (2:= H3) ; auto.
+  (* No Cutting plane (bis) *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hf2) in H2.
+  apply genCuttingPlaneNone with (2:= H2) ; auto.
 Qed.
 
 Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
-  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZArithProof ZChecker f w.
+  @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce 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.
@@ -959,6 +1008,11 @@ Proof.
   unfold ZTautoChecker.
   apply (tauto_checker_sound  Zeval_formula eval_nformula).
   apply Zeval_nformula_dec.
+  intros until env.
+  unfold eval_nformula. unfold RingMicromega.eval_nformula.
+  destruct t.
+  apply (check_inconsistent_sound Zsor ZSORaddon) ; auto.
+  unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon).
   intros env t.
   rewrite normalise_correct ; auto.
   intros env t.
@@ -1009,12 +1063,7 @@ 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.
+Notation n_of_Z := Z.to_N (only parsing).
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index bcab73ec..540d1b9c 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -15,153 +15,18 @@
 (* We take as input a list of polynomials [p1...pn] and return an unfeasibility
    certificate polynomial. *)
 
-(*open Micromega.Polynomial*)
+type var = int
+
+
+
 open Big_int
 open Num
-open Sos_lib
+open Polynomial
 
 module Mc = Micromega
 module Ml2C = Mutils.CamlToCoq
 module C2Ml = Mutils.CoqToCaml
 
-let (<+>) = add_num
-let (<->) = minus_num
-let (<*>) = mult_num
-
-type var = Mc.positive
-
-module Monomial :
-sig
- type t
- val const : t
- val var : var -> t
- val find : var -> t -> int
- val mult : var -> t -> t
- val prod : t -> t -> t
- val compare : t -> t -> int
- val pp : out_channel -> t -> unit
- val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
-end
- =
-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 ->
-  if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
-  else     Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
-
- let fold = fold
-
-end
-
-
-module Poly :
- (* A polynomial is a map of monomials *)
- (*
-    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.
- *)
-sig
- type t
- val get : Monomial.t -> t -> num
- val variable : var -> t
- val add : Monomial.t -> num -> t -> t
- val constant : num -> t
- val mult : Monomial.t -> num -> t -> t
- val product : t -> t -> t
- val addition : t -> t -> t
- val uminus : t -> t
- 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 ... *)
- module P = Map.Make(Monomial)
- open P
-
- type t = num P.t
-
- let pp o p = P.iter (fun k v ->
-  if compare_num v (Int 0) <> 0
-  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
-
- (* Get the coefficient of monomial mn *)
- 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
-
- (* The addition of a monomial *)
-
- let add : Monomial.t -> num -> t -> t =
-  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 ....
- **)
-
- (* The product by a monomial *)
- let mult : Monomial.t -> num -> t -> t =
-  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 ->
-   fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
-
-
- let uminus : t -> t =
-  fun p -> map (fun v -> minus_num v) p
-
- 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
 
 open Mutils
 type 'a number_spec = {
@@ -178,10 +43,10 @@ let z_spec = {
  number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
  zero = Mc.Z0;
  unit = Mc.Zpos Mc.XH;
- mult = Mc.zmult;
+ mult = Mc.Z.mul;
  eqb  = Mc.zeq_bool
 }
-
+ 
 
 let q_spec = {
  bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
@@ -195,56 +60,58 @@ let q_spec = {
 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.PEX v ->  Poly.variable (C2Ml.positive v)
+   | Mc.PEmul(p1,p2) -> 
       let p1 = dev_form p1 in
       let p2 = dev_form p2 in
-       Poly.product p1 p2
+       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 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
-    else Mc.PEmul(mn,acc))
-  mn
-  (Mc.PEc (Mc.Zpos Mc.XH))
+let monomial_to_polynomial mn = 
+ Monomial.fold 
+  (fun v i acc -> 
+     let v = Ml2C.positive v in
+     let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+       if acc = Mc.PEc (Mc.Zpos Mc.XH)
+       then mn 
+       else Mc.PEmul(mn,acc))
+   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 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 =
@@ -252,61 +119,54 @@ let rec fixpoint f x =
   if y' = x then y'
   else fixpoint f y'
 
-
-
-
-
-
-
-
-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.PsatzMulE(t1, t2) ->
+ | Mc.PsatzMulE(t1, t2) -> 
     simpl_cone  (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.PsatzAdd(t1,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.PsatzAdd (x,r) -> cone_list  r (x::l)
    |  _        ->  c :: l in
-
+  
  let factorise c1 c2 =
   match c1 , c2 with
-   | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+   | 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') ->
+   | 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.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.PsatzAdd(p, rebuild_cone l (Some e))
           | Some f -> rebuild_cone l (Some f) )
@@ -316,15 +176,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.
@@ -334,216 +194,209 @@ 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 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 *)
+ (* Gather the monomials:  HINT add up of the polynomials ==> This does not work anymore *)
  let l' = List.map fst l in
- let monomials =
-  List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
+
+ let module MonSet = Set.Make(Monomial) in
+
+ let monomials = 
+  List.fold_left (fun acc p -> 
+                    Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) 
+    (MonSet.singleton Monomial.const) l'
  in  (* For each monomial, compute a constraint *)
- let s0 =
-  Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in
+ let s0 = 
+  MonSet.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
    | [] -> failwith "empty_certificate"
-   | e::cert' ->
-      let cst = match compare_big_int e zero_big_int with
+   | e::cert' -> 
+(*      let cst = match compare_big_int e zero_big_int with
        | 0 -> Mc.PsatzZ
-       | 1 ->  Mc.PsatzC (bint_to_cst e)
-       | _ -> failwith "positivity error"
-      in
+       | 1 ->  Mc.PsatzC (bint_to_cst e) 
+       | _ -> failwith "positivity error" 
+      in *)
       let rec scalar_product cert l =
        match cert with
         | [] -> Mc.PsatzZ
-        | c::cert -> match l with
-           | [] -> failwith "make_certificate(1)"
-           | i::l ->
-              let r = scalar_product cert l in
-               match compare_big_int c  zero_big_int with
-                | -1 -> Mc.PsatzAdd (
-                   Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
-                   r)
-                | 0  -> r
-                | _ ->  Mc.PsatzAdd (
-                   Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
-                   r) in
-
-        ((factorise_linear_cone
-             (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li)))))
+        | c::cert -> 
+	    match l with
+              | [] -> failwith "make_certificate(1)"
+              | i::l ->  
+		  let r = scalar_product cert l in
+		    match compare_big_int c  zero_big_int with
+                      | -1 -> Mc.PsatzAdd (
+			  Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), 
+			  r)
+                      | 0  -> r
+                      | _ ->  Mc.PsatzAdd (
+			  Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+			  r) in
+        (factorise_linear_cone 
+             (simplify_cone n_spec (scalar_product cert' li)))
 
 
 exception Found of Monomial.t
 
 exception Strict
 
-let primal l =
+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
+    Poly.fold (fun mn vl (map,vect) -> 
+      if mn = Monomial.const 
       then (map,vect)
-      else
+      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 (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) =
+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
     | Inr _ -> None
-    | Inl cert ->  Some (rats_to_ints (Vect.to_list cert))
+    | 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 raw_certificate l =
-  try
+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 ;
+	| 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 ;
+	      if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
 	      Some (rats_to_ints (Vect.to_list cert))
 	| Inl _   -> None
-  with Strict ->
+  with Strict -> 
     (* Fourier elimination should handle > *)
-    dual_raw_certificate l
+    dual_raw_certificate l 
 
 
-let simple_linear_prover (*to_constant*) l =
+let simple_linear_prover  l =
  let (lc,li) = List.split l in
   match raw_certificate lc with
    |  None -> None (* No certificate *)
-   | Some cert -> (* make_certificate to_constant*)Some (cert,li)
+   | Some cert -> 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 ((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'
+let linear_prover n_spec l  =
+  let build_system n_spec l = 
+    let li = List.combine l (interval 0 (List.length l -1)) in
+    let (l1,l') = List.partition 
+      (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in
+      List.map 
+	(fun ((x,y),i) -> match y with
+             Mc.NonEqual -> failwith "cannot happen"
+           |  y -> ((dev_form n_spec x, y),i)) l' in
+  let l' = build_system n_spec l in 
+    simple_linear_prover (*n_spec*) l' 
 
 
 let linear_prover n_spec l  =
  try linear_prover n_spec l with
    x -> (print_string (Printexc.to_string x); None)
 
-let linear_prover_with_cert spec l =
+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
-   Once I have an interval, I need a certificate : 2 other fourier elims.
-   (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)
 
@@ -552,130 +405,66 @@ 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
 
 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 --
+(* The prover is (probably) incomplete -- 
    only searching for naive cutting planes *)
 
-let candidates sys =
- let ll = List.fold_right (
-  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
-       (* 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 ->
-   let gcd = Big_int (Vect.gcd cstr.coeffs) in
-    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 =
- match linear_prover z_spec sys with
-  | 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 (e,k) r -> match k with
-       Mc.NonEqual -> r
-      | k -> (dev_form z_spec e ,
-             match k with
-               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 ->
-      match Fourier.optimise vect ll with
-       | None -> acc
-       | Some i ->
-(*	  Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *)
-	  flush stdout ;
-	  (vect,i) ::acc)  [] planes in
-
-     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,(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) =
-           (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)) ,
-           Ml2C.bigint (denominator ub)) in
-          let expr = list_to_polynomial var (Vect.to_list e) in
-           (match
-             (*x <= ub ->  x  > ub *)
-             linear_prover  z_spec
-              ((pplus (pmult (pconst ubd) expr) (popp (pconst  ubn)),
-                      Mc.NonStrict) :: sys),
-            (* lb <= x  -> lb > x *)
-            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
-                 with
-                  | None -> None
-                  | 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 =
- if clb >/  cub
- then Some []
- else
-  let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr 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 (prf :: prfl)
+let develop_constraint z_spec (e,k) = 
+    match k with
+      | Mc.NonStrict -> (dev_form z_spec e , Ge)
+      | Mc.Equal     ->  (dev_form z_spec e , Eq)
+      | _     -> assert false
+
+
+let op_of_op_compat = function
+  | Ge -> Mc.NonStrict
+  | Eq -> Mc.Equal
+
+
+let integer_vector coeffs = 
+  let vars , coeffs = List.split coeffs in
+    List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
+
+let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = 
+  let vars , coeffs = List.split coeffs in
+  match rats_to_ints (cst::coeffs) with
+    | cst :: coeffs -> 
+	{
+	  coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
+	  op = op ; cst = Big_int cst}
+    |  _ -> assert false
+	 
+
+let pexpr_of_cstr_compat var cstr  = 
+  let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
+  try 
+    let expr = list_to_polynomial var (Vect.to_list coeffs) in  
+    let d = Ml2C.bigint (denominator cst) in
+    let n = Ml2C.bigint (numerator cst) in
+      (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
+  with Failure _ -> failwith "pexpr_of_cstr_compat"
+
+
 
-let zlinear_prover sys =
- let candidates = candidates sys in
- (*  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_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))
@@ -708,7 +497,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
@@ -722,19 +511,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)
 
@@ -743,7 +532,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)
@@ -755,20 +544,20 @@ open Micromega
  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 =
+ 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  q_cert_of_pos  pos = 
  let rec _cert_of_pos = function
    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 ->
+  | 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)
@@ -781,7 +570,7 @@ let  q_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)
@@ -790,24 +579,649 @@ 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 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 term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add  Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
 
-let  z_cert_of_pos  pos =
+let  z_cert_of_pos  pos = 
  let s,pos = (scale_certificate pos) in
  let rec _cert_of_pos = function
    Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
   | Axiom_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 ->
+  | 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)
+  | Eqmul (t, y) -> 
+      let is_unit =
+	match t with
+	  | Const n -> n =/ Int 1 
+	  |   _     -> false in
+	if is_unit
+	then _cert_of_pos y
+	else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
   | 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)
 
+(** All constraints (initial or derived) have an index and have a justification i.e., proof.
+    Given a constraint, all the coefficients are always integers.
+*)
+open Mutils
+open Mfourier
+open Num
+open Big_int
+open Polynomial
+
+(*module Mc = Micromega*)
+(*module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+*)
+let debug = false
+
+
+
+module Env = 
+struct
+
+  type t = int list
+
+  let id_of_hyp hyp l = 
+    let rec xid_of_hyp i l = 
+      match l with
+      | [] -> failwith "id_of_hyp"
+      | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in
+      xid_of_hyp 0 l
+
+end
+
+
+let  coq_poly_of_linpol (p,c) = 
+
+  let pol_of_mon m =
+    Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
+
+    List.fold_left (fun acc (x,v) -> 
+		      let mn = LinPoly.MonT.retrieve x in
+			Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
+			
+
+
+
+let rec cmpl_prf_rule env = function
+  | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
+  | Cst i         -> Mc.PsatzC (Ml2C.bigint i)
+  | Zero          -> Mc.PsatzZ
+  | MulPrf(p1,p2)      -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
+  | AddPrf(p1,p2)      -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
+  | MulC(lp,p)  -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
+      Mc.PsatzMulC(lp,cmpl_prf_rule env p)
+  | Square lp      -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
+  | _                  -> failwith "Cuts should already be compiled"
+      
+
+let rec cmpl_proof env = function
+  | Done ->  Mc.DoneProof
+  | Step(i,p,prf) -> 
+      begin
+	match p with
+	| CutPrf p' -> 
+	    Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
+	|   _       -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
+      end
+  | Enum(i,p1,_,p2,l) -> 
+      Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
+
+
+let compile_proof env prf = 
+  let id = 1 + proof_max_id prf in
+  let _,prf = normalise_proof id prf in
+    if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
+    cmpl_proof env prf
+
+type prf_sys = (cstr_compat * prf_rule) list
+
+
+let xlinear_prover sys = 
+  match Fourier.find_point sys with
+  | Inr prf -> 
+      if debug then Printf.printf "AProof : %a\n" pp_proof prf ; 
+      let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
+	if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; 
+	Some (rats_to_ints (Vect.to_list cert))
+  | Inl _   -> None
+
+
+let output_num o n = output_string o (string_of_num n)
+let output_bigint o n = output_string o (string_of_big_int n)
+
+let proof_of_farkas prf cert = 
+(*  Printf.printf "\nproof_of_farkas  %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ;  *)
+  let rec mk_farkas acc prf cert = 
+    match prf, cert with
+    |   _  , []   -> acc
+    |  []  , _    -> failwith "proof_of_farkas : not enough hyps"
+    |  p::prf,c::cert -> 
+	   mk_farkas (add_proof (mul_proof c p) acc) prf cert in
+  let res =  mk_farkas Zero prf cert in
+    (*Printf.printf "==> %a" output_prf_rule res ; *)
+    res
+
+
+let linear_prover sys =
+  let (sysi,prfi) = List.split sys in
+    match xlinear_prover sysi with
+    | None -> None
+    | Some cert -> Some (proof_of_farkas prfi cert)
+
+let linear_prover  = 
+  if debug 
+  then 
+    fun sys -> 
+      Printf.printf "<linear_prover"; flush stdout ;
+      let res = linear_prover sys in
+	Printf.printf ">"; flush stdout ;
+	res
+  else linear_prover
+  
+
+
+
+(** A single constraint can be unsat for the following reasons:
+    - 0 >= c for c a negative constant
+    - 0 =  c for c a non-zero constant
+    - e = c  when the coeffs of e are all integers and c is rational
+*)
+
+type checksat = 
+  | Tauto (* Tautology *)
+  | Unsat of prf_rule (* Unsatisfiable *)
+  | Cut of cstr_compat * prf_rule (* Cutting plane *)
+  | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
+      
+
+(** [check_sat] 
+    - detects constraints that are not satisfiable;
+    - normalises constraints and generate cuts.
+*)
+
+let check_sat (cstr,prf) = 
+  let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
+    match coeffs with
+    | [] -> 
+	if eval_op op (Int 0) cst then Tauto else Unsat prf
+    | _  -> 
+	let gcdi =  (gcd_list (List.map snd coeffs)) in
+	let gcd = Big_int gcdi in
+	  if eq_num gcd (Int 1)
+	  then Normalise(cstr,prf) 
+	  else
+	    if sign_num (mod_num cst gcd) = 0
+	    then (* We can really normalise *)
+	      begin
+		assert (sign_num gcd >=1 ) ;
+		let cstr = {
+		  coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
+		  op = op ; cst = cst // gcd
+		} in 
+		  Normalise(cstr,Gcd(gcdi,prf))
+		    (*		    Normalise(cstr,CutPrf prf)*)
+	      end
+	    else
+	      match op with
+	      | Eq -> Unsat (CutPrf prf)
+	      | Ge -> 
+		  let cstr = {
+		    coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; 
+		    op = op ; cst = ceiling_num (cst // gcd)
+		  } in Cut(cstr,CutPrf prf)
+
+
+(** Proof generating pivoting over variable v *)
+let pivot v (c1,p1) (c2,p2) = 
+  let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+  and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+
+
+
+  (* Could factorise gcd... *)
+  let xpivot cv1 cv2 =
+    (
+      {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
+       op = Proof.add_op op1 op2 ;
+       cst = n1 */ cv1 +/ n2 */ cv2 },
+
+      AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+    
+    match Vect.get v v1 , Vect.get v v2 with
+    | None , _ | _ , None -> None
+    | Some a   , Some b   ->
+	if (sign_num a) * (sign_num b) = -1
+	then 
+	  let cv1 = abs_num b 
+	  and cv2 = abs_num a  in
+	    Some (xpivot cv1 cv2)
+	else 
+	  if op1 = Eq
+          then 
+	    let cv1 = minus_num (b */ (Int (sign_num a)))
+	    and cv2 = abs_num a in
+	      Some (xpivot cv1 cv2)
+          else if op2 = Eq
+	  then
+	    let cv1 = abs_num b 
+	    and cv2 = minus_num (a */ (Int  (sign_num b))) in
+	      Some (xpivot cv1 cv2)
+	  else  None (* op2 could be Eq ... this might happen *)
+	    
+exception FoundProof of  prf_rule
+
+let rec simpl_sys sys = 
+  List.fold_left (fun acc (c,p) -> 
+		    match check_sat (c,p) with
+		    | Tauto -> acc
+		    | Unsat prf -> raise (FoundProof prf)
+		    | Cut(c,p)  -> (c,p)::acc
+		    | Normalise (c,p) -> (c,p)::acc) [] sys
+
+
+(** [ext_gcd a b] is the extended Euclid algorithm.
+    [ext_gcd a b = (x,y,g)] iff [ax+by=g]
+    Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
+*)
+let rec ext_gcd a b = 
+  if sign_big_int b = 0 
+  then (unit_big_int,zero_big_int)
+  else
+    let (q,r) = quomod_big_int a b in
+    let (s,t) = ext_gcd b r in
+      (t, sub_big_int s (mult_big_int q t))
+
+
+let pp_ext_gcd a b = 
+  let a' = big_int_of_int a in
+  let b' = big_int_of_int b in
+    
+  let (x,y) = ext_gcd a' b' in
+    Printf.fprintf stdout "%s * %s + %s * %s = %s\n" 
+      (string_of_big_int x) (string_of_big_int a')
+      (string_of_big_int y) (string_of_big_int b')
+      (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
+
+exception Result of (int * (proof * cstr_compat))
+
+let split_equations psys = 
+  List.partition (fun (c,p) -> c.op = Eq)
+
+
+let extract_coprime (c1,p1) (c2,p2) = 
+  let rec exist2 vect1 vect2 = 
+    match vect1 , vect2 with
+    | _ , [] | [], _ -> None
+    | (v1,n1)::vect1' , (v2, n2) :: vect2' -> 
+	if v1 = v2
+	then 
+	  if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int  = 0
+	  then Some (v1,n1,n2)
+	  else 
+	    exist2 vect1' vect2'
+	else
+	  if v1 < v2 
+	  then exist2 vect1' vect2
+	  else exist2 vect1 vect2' in
+    
+    if c1.op = Eq && c2.op = Eq 
+    then exist2 c1.coeffs c2.coeffs
+    else None
+
+let extract2 pred l =
+  let rec xextract2 rl l = 
+    match l with
+    | [] -> (None,rl) (* Did not find *)
+    | e::l ->
+	match extract (pred e) l with
+	| None,_ -> xextract2 (e::rl) l
+	| Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
+    
+    xextract2 [] l
+
+
+let extract_coprime_equation psys = 
+  extract2 extract_coprime psys
+
+
+let apply_and_normalise f psys =
+  List.fold_left (fun acc pc' -> 
+		    match f pc' with
+		     | None -> pc'::acc
+		     | Some pc' -> 
+			 match check_sat pc' with
+			  | Tauto -> acc
+			  | Unsat prf -> raise (FoundProof prf)
+			  | Cut(c,p)  -> (c,p)::acc
+			  | Normalise (c,p) -> (c,p)::acc
+		 ) [] psys
+
+
+
+
+let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys
+
+
+let reduce_coprime psys = 
+  let oeq,sys = extract_coprime_equation psys in
+    match oeq with
+    | None -> None (* Nothing to do *)
+    | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> 
+	let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
+	let l1' = Big_int l1 and l2' = Big_int l2 in
+	let cstr = 
+	  {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
+	   op = Eq ; 
+	   cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) 
+	  } in
+	let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
+
+	  Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
+
+(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
+let reduce_unary psys = 
+  let is_unary_equation (cstr,prf) = 
+    if cstr.op = Eq 
+    then 
+      try 
+	Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
+      with Not_found -> None
+    else None in
+
+  let (oeq,sys) =  extract is_unary_equation psys in
+    match oeq with
+    | None -> None (* Nothing to do *)
+    | Some(v,pc) -> 
+	Some(pivot_sys v pc sys)
+
+let reduce_non_lin_unary psys = 
+
+  let is_unary_equation (cstr,prf) = 
+    if cstr.op = Eq 
+    then 
+      try 
+	let x = fst (List.find (fun (x,n) ->  (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
+	let x' = LinPoly.MonT.retrieve x in
+	  if List.for_all (fun (y,_) -> y = x  || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs 
+	  then Some x
+	  else None
+      with Not_found -> None
+    else None in
+
+
+  let (oeq,sys) =   extract is_unary_equation psys in
+    match oeq with
+     | None -> None (* Nothing to do *)
+     | Some(v,pc) -> 
+	 Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
+
+let reduce_var_change psys = 
+
+  let rec rel_prime vect = 
+    match vect with
+     | [] -> None
+     | (x,v)::vect -> 
+	 let v = numerator v in
+	   try 
+	     let (x',v') = List.find (fun (_,v') -> 
+					let v' = numerator v' in 
+					  eq_big_int (gcd_big_int  v v') unit_big_int) vect in
+	       Some ((x,v),(x',numerator v'))
+	   with Not_found -> rel_prime vect in
+
+  let rel_prime (cstr,prf) =  if cstr.op = Eq then rel_prime cstr.coeffs else None in
+
+  let (oeq,sys) = extract rel_prime psys in
+    
+    match oeq with
+     | None -> None
+     | Some(((x,v),(x',v')),(c,p)) -> 
+	 let (l1,l2) = ext_gcd  v  v' in
+	 let l1,l2 = Big_int l1 , Big_int l2 in
+
+	 let get v vect = 
+	   match Vect.get v vect with
+	    | None -> Int 0
+	    | Some n -> n in
+
+	 let pivot_eq (c',p') = 
+	   let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+	   let vx = get x coeffs in
+	   let vx' = get x' coeffs in
+	   let m = minus_num (vx */ l1 +/ vx' */ l2) in
+	     Some ({coeffs = 
+		       Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , 
+	   AddPrf(MulC(([], m),p),p')) in
+
+	   Some (apply_and_normalise pivot_eq sys)
+
+
+
+
+  let reduce_pivot psys = 
+    let is_equation (cstr,prf) = 
+      if cstr.op = Eq
+      then
+	try 
+	  Some (fst (List.hd cstr.coeffs))
+	with Not_found -> None
+      else None in
+    let (oeq,sys) = extract is_equation psys in
+      match oeq with
+      | None -> None (* Nothing to do *)
+      | Some(v,pc) -> 
+	  if debug then 
+	    Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); 
+	  Some(pivot_sys v pc sys)
+
+
+
+
+
+  let iterate_until_stable f x = 
+    let rec iter x = 
+      match f x with
+      | None -> x
+      | Some x' -> iter x' in
+      iter x
+
+  let rec app_funs l x = 
+    match l with
+    | [] -> None
+    | f::fl -> 
+	match f x with
+	| None    -> app_funs fl x
+	| Some x' -> Some x'
+
+  let reduction_equations psys =
+    iterate_until_stable (app_funs 
+			    [reduce_unary ; reduce_coprime ; 
+			     reduce_var_change (*; reduce_pivot*)]) psys 
+
+  let reduction_non_lin_equations psys =
+    iterate_until_stable (app_funs 
+			    [reduce_non_lin_unary (*; reduce_coprime ; 
+			     reduce_var_change ; reduce_pivot *)]) psys 
+
+
+
+
+  (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
+  let get_bound sys = 
+    let is_small (v,i) = 
+      match Itv.range i with
+      | None -> false
+      | Some i -> i <=/ (Int 1) in
+      
+    let select_best (x1,i1) (x2,i2) = 
+      if Itv.smaller_itv i1 i2
+      then (x1,i1) else (x2,i2) in
+
+    (* For lia, there are no equations => these precautions are not needed *)
+    (* For nlia, there are equations => do not enumerate over equations! *)
+    let all_planes sys = 
+      let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in
+	match eq with
+	  | [] -> List.rev_map (fun c -> c.coeffs) ineq
+	  | _  -> 
+	      List.fold_left (fun acc c -> 
+				if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
+				then acc else c.coeffs ::acc) [] ineq in
+
+    let smallest_interval = 
+      List.fold_left 
+	(fun acc vect ->
+	   if is_small acc
+	   then acc
+	   else 
+	     match Fourier.optimise vect sys with
+	     | None -> acc
+	     | Some i -> 
+		 if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
+		 select_best (vect,i) acc)  (Vect.null, (None,None)) (all_planes sys) in
+    let smallest_interval =
+      match smallest_interval
+      with
+      | (x,(Some i, Some j))  -> Some(i,x,j)
+      |   x        ->   None (* This should not be possible *)
+    in
+      match smallest_interval with
+      | Some (lb,e,ub) -> 
+	  let (lbn,lbd) = (sub_big_int (numerator lb)  unit_big_int, denominator lb) in
+	  let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
+	    (match
+               (* x <= ub ->  x  > ub *)
+               xlinear_prover   ({coeffs = Vect.mul (Big_int ubd)  e ; op = Ge ; cst = Big_int ubn} :: sys),
+               (* lb <= x  -> lb > x *)
+               xlinear_prover
+		 ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
+	     with
+	     | Some cub , Some clb  -> Some(List.tl clb,(lb,e,ub), List.tl cub)
+	     |         _            -> failwith "Interval without proof"
+	    )
+      | None -> None
+
+
+  let check_sys sys = 
+    List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
+
+
+  let xlia reduction_equations  sys = 
+
+  let rec enum_proof (id:int) (sys:prf_sys) : proof option = 
+    if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
+    assert (check_sys sys) ; 
+
+    let nsys,prf = List.split sys in
+      match get_bound nsys with
+      | None -> None (* Is the systeme really unbounded ? *)
+      | Some(prf1,(lb,e,ub),prf2) -> 
+	  if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; 
+	  (match start_enum  id  e  (ceiling_num lb)  (floor_num ub) sys
+	   with
+	   | Some prfl -> 
+	       Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
+	   | None -> None
+	  )
+
+  and start_enum id e clb cub sys = 
+    if clb >/ cub
+    then Some []
+    else
+      let eq = {coeffs = e ; op = Eq ; cst = clb} in
+	match aux_lia (id+1) ((eq, Def id) :: sys) with
+	| None -> None 
+	| Some prf  -> 
+	    match start_enum id e (clb +/ (Int 1)) cub sys with
+	    | None -> None
+	    | Some l -> Some (prf::l)
+
+  and aux_lia (id:int)  (sys:prf_sys) : proof option  = 
+    assert (check_sys sys) ; 
+    if debug then Printf.printf "xlia:  %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; 
+    try 
+      let sys = reduction_equations sys in
+    if debug then 
+    Printf.printf "after reduction:  %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; 	    	    
+	match linear_prover sys with
+	 | Some prf -> Some (Step(id,prf,Done))
+	 | None ->  enum_proof id sys
+    with FoundProof prf -> 
+      (* [reduction_equations] can find a proof *)
+      Some(Step(id,prf,Done)) in
+
+  (*  let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
+  let id  = List.length sys in
+  let orpf = 
+    try 
+      let sys = simpl_sys sys in
+	  aux_lia id sys
+    with FoundProof pr -> Some(Step(id,pr,Done)) in
+    match orpf with
+     | None -> None
+     | Some prf -> 
+	 (*Printf.printf "direct proof %a\n" output_proof prf ; *)
+	 let env = mapi (fun _ i -> i) sys in
+	 let prf = compile_proof env prf in
+	   (*try 
+	     if Mc.zChecker sys' prf then Some prf else 
+	     raise Certificate.BadCertificate
+	     with Failure s -> (Printf.printf "%s" s ; Some prf)
+	   *) Some prf
+	   
+
+  let cstr_compat_of_poly (p,o) = 
+    let (v,c) = LinPoly.linpol_of_pol p in
+      {coeffs = v ; op = o ; cst = minus_num c }
+
+
+  let lia sys = 
+    LinPoly.MonT.clear ();
+    let sys = List.map (develop_constraint z_spec) sys in
+    let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
+    let sys = mapi (fun c i -> (c,Hyp i)) sys in
+      xlia reduction_equations sys
+
+
+  let nlia sys = 
+    LinPoly.MonT.clear ();
+    let sys = List.map (develop_constraint z_spec) sys in
+    let sys = mapi (fun c i -> (c,Hyp i)) sys in
+
+    let is_linear =  List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
+
+    let module MonMap = Map.Make(Monomial) in
+
+    let collect_square = 
+      List.fold_left (fun acc ((p,_),_) -> Poly.fold 
+			(fun m _ acc -> 
+			   match Monomial.sqrt m with
+			     | None -> acc
+			     | Some s -> MonMap.add  s m acc)  p acc) MonMap.empty sys in
+    let sys = MonMap.fold (fun s m acc -> 
+				    let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
+				    let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
+				    ((m, Ge), (Square s))::acc) collect_square  sys in
+
+(*      List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
+
+    let sys = 
+      if is_linear then sys
+      else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> 
+			    ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
+    let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
+    assert (check_sys sys) ; 
+    xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys
+
+
+
 (* Local Variables: *)
 (* coding: utf-8 *)
 (* End: *)
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 4eb26afd..1ad49bb8 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,7 +12,7 @@
 (*                                                                      *)
 (* - Modules ISet, M, Mc, Env, Cache, CacheZ                            *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2009                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-20011                            *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -55,7 +55,7 @@ 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
@@ -86,6 +86,18 @@ let rec pp_formula o f =
 	    | None -> "") pp_formula f2
     | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
 
+
+let rec map_atoms fct f = 
+  match f with
+    | TT -> TT
+    | FF -> FF
+    | X x -> X x
+    | A (at,tg,cstr) -> A(fct at,tg,cstr)
+    | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2)
+    | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2)
+    | N f -> N(map_atoms fct f)
+    | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2)
+
 (**
   * Collect the identifiers of a (string of) implications. Implication labels
   * are inherited from Coq/CoC's higher order dependent type constructor (Pi).
@@ -125,7 +137,9 @@ let ff : 'cst cnf = [ [] ]
   * and the freeform formulas ('cst formula) that is retrieved from Coq.
   *)
 
-type 'cst mc_cnf = ('cst Micromega.nFormula) list list
+module Mc = Micromega
+
+type 'cst mc_cnf = ('cst Mc.nFormula) list list
 
 (**
   * From a freeform formula, build a cnf.
@@ -134,7 +148,12 @@ type 'cst mc_cnf = ('cst Micromega.nFormula) list list
   * and RingMicromega.v).
   *)
 
-let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) =
+type 'a tagged_option = T of tag list |  S of 'a 
+
+let cnf 
+    (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) 
+    (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) =
+
  let negate a t =
   List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in
 
@@ -143,26 +162,79 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf)
 
  let and_cnf x y = x @ y in
 
- let or_clause_cnf t f =  List.map (fun x -> t@x) f in
+let rec add_term  t0 = function
+  | [] -> 
+      (match deduce (fst t0) (fst t0) with
+	| Some u -> if unsat u then T [snd t0] else S (t0::[])
+	| None -> S (t0::[]))
+  | t'::cl0 ->
+      (match deduce (fst t0) (fst t') with
+	 | Some u ->
+	     if unsat u
+	     then T [snd t0 ; snd t']
+	     else (match add_term  t0 cl0 with
+		     | S cl' -> S (t'::cl')
+		     | T l -> T l)
+	 | None ->
+	     (match add_term  t0 cl0 with
+		| S cl' -> S (t'::cl')
+		| T l -> T l)) in
+
+
+ let rec or_clause  cl1 cl2 =
+   match cl1 with
+     | [] -> S cl2
+     | t0::cl ->
+	 (match add_term  t0 cl2 with
+	    | S cl' -> or_clause  cl cl'
+	    | T l -> T l) in
+
+
+
+ let or_clause_cnf t f =  
+   List.fold_right (fun e (acc,tg) -> 
+		      match or_clause t e with
+			| S cl -> (cl :: acc,tg)
+			| T l -> (acc,tg@l)) f ([],[]) in
+
 
  let rec or_cnf f f' =
   match f with
-   | [] -> tt
-   | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
+   | [] -> tt,[]
+   | e :: rst -> 
+       let (rst_f',t) = or_cnf rst f' in
+       let (e_f', t') = or_clause_cnf e f' in
+	 (rst_f' @ e_f', t @ t') 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
+   | 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)
+   | C(e1,e2) -> 
+       let e1,t1 = xcnf polarity e1 in
+       let e2,t2 = xcnf polarity e2 in
+      if polarity 
+       then and_cnf e1 e2, t1 @ t2
+       else let f',t' = or_cnf e1 e2 in
+	 (f', t1 @ t2 @ t')
    | D(e1,e2)  ->
-      (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2)
+       let e1,t1 = xcnf polarity e1 in
+       let e2,t2 = xcnf polarity e2 in
+      if polarity 
+       then let f',t' = or_cnf e1 e2 in
+	 (f', t1 @ t2 @ t')
+       else and_cnf e1 e2, t1 @ t2
    | I(e1,_,e2) ->
-      (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in
+       let e1 , t1 = (xcnf (not polarity) e1) in
+       let e2 , t2 = (xcnf polarity e2) in
+      if polarity 
+       then let f',t' = or_cnf e1 e2 in
+	 (f', t1 @ t2 @ t')
+       else and_cnf e1 e2, t1 @ t2 in
 
   xcnf true f
 
@@ -212,6 +284,7 @@ struct
       ["RingMicromega"];
       ["EnvRing"];
       ["Coq"; "micromega"; "ZMicromega"];
+      ["Coq"; "micromega"; "RMicromega"];
       ["Coq" ; "micromega" ; "Tauto"];
       ["Coq" ; "micromega" ; "RingMicromega"];
       ["Coq" ; "micromega" ; "EnvRing"];
@@ -220,6 +293,13 @@ struct
       ["Coq";"Reals" ; "Rpow_def"];
       ["LRing_normalise"]]
 
+  let bin_module = [["Coq";"Numbers";"BinNums"]]
+
+  let r_modules =
+    [["Coq";"Reals" ; "Rdefinitions"];
+     ["Coq";"Reals" ; "Rpow_def"] ;
+]
+
   (**
     * Initialization : a large amount of Caml symbols are derived from
     * ZMicromega.v
@@ -227,6 +307,8 @@ struct
 
   let init_constant = gen_constant_in_modules "ZMicromega" init_modules
   let constant = gen_constant_in_modules "ZMicromega" coq_modules
+  let bin_constant = gen_constant_in_modules "ZMicromega" bin_module
+  let r_constant = gen_constant_in_modules "ZMicromega" r_modules
   (* let constant = gen_constant_in_modules "Omicron" coq_modules *)
 
   let coq_and = lazy (init_constant "and")
@@ -244,34 +326,42 @@ struct
   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_N0 = lazy (bin_constant "N0")
+  let coq_Npos = lazy (bin_constant "Npos")
+
+  let coq_pair = lazy (init_constant "pair")
+  let coq_None = lazy (init_constant "None")
+  let coq_option = lazy (init_constant "option")
 
-  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_positive = lazy (bin_constant "positive")
+  let coq_xH = lazy (bin_constant "xH")
+  let coq_xO = lazy (bin_constant "xO")
+  let coq_xI = lazy (bin_constant "xI")
 
-  let coq_N0 = lazy (constant "N0")
-  let coq_N0 = lazy (constant "Npos")
+  let coq_Z = lazy (bin_constant "Z")
+  let coq_ZERO = lazy (bin_constant "Z0")
+  let coq_POS = lazy (bin_constant "Zpos")
+  let coq_NEG = lazy (bin_constant "Zneg")
 
-  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_Rcst = lazy (constant "Rcst")
+  let coq_C0   = lazy (constant "C0")
+  let coq_C1   = lazy (constant "C1")
+  let coq_CQ   = lazy (constant "CQ")
+  let coq_CZ   = lazy (constant "CZ")
+  let coq_CPlus = lazy (constant "CPlus")
+  let coq_CMinus = lazy (constant "CMinus")
+  let coq_CMult  = lazy (constant "CMult")
+  let coq_CInv   = lazy (constant "CInv")
+  let coq_COpp   = lazy (constant "COpp")
+
+
   let coq_R0    = lazy (constant "R0")
   let coq_R1    = lazy (constant "R1")
 
@@ -305,16 +395,20 @@ struct
   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_Rgt = lazy (r_constant "Rgt")
+  let coq_Rge = lazy (r_constant "Rge")
+  let coq_Rle = lazy (r_constant "Rle")
+  let coq_Rlt = lazy (r_constant "Rlt")
+
+  let coq_Rplus = lazy (r_constant "Rplus")
+  let coq_Rminus = lazy (r_constant "Rminus")
+  let coq_Ropp = lazy (r_constant "Ropp")
+  let coq_Rmult = lazy (r_constant "Rmult")
+  let coq_Rdiv = lazy (r_constant "Rdiv")
+  let coq_Rinv = lazy (r_constant "Rinv")
+  let coq_Rpower = lazy (r_constant "pow")
+  let coq_IQR    = lazy (constant "IQR")
+  let coq_IZR    = lazy (constant "IZR")
 
   let coq_PEX = lazy (constant "PEX" )
   let coq_PEc = lazy (constant"PEc")
@@ -444,8 +538,6 @@ struct
 
   (* Access the Micromega module *)
   
-  module Mc = Micromega
-
   (* parse/dump/print from numbers up to expressions and formulas *)
 
   let rec parse_nat term =
@@ -491,11 +583,6 @@ struct
 
   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) =
@@ -515,7 +602,7 @@ struct
     | 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 pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x))
 
   let dump_num bd1 =
    Term.mkApp(Lazy.force coq_Qmake,
@@ -533,6 +620,48 @@ struct
        else raise ParseError
    |  _ -> raise ParseError
 
+
+  let rec pp_Rcst o cst = 
+    match cst with
+      | Mc.C0 -> output_string o "C0"
+      | Mc.C1 ->  output_string o "C1"
+      | Mc.CQ q ->  output_string o "CQ _"
+      | Mc.CZ z -> pp_z o z
+      | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y
+      | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y
+      | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y
+      | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t
+      | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t
+
+
+  let rec dump_Rcst cst = 
+    match cst with
+      | Mc.C0 -> Lazy.force coq_C0 
+      | Mc.C1 ->  Lazy.force coq_C1
+      | Mc.CQ q ->  Term.mkApp(Lazy.force coq_CQ, [| dump_q q |])
+      | Mc.CZ z -> Term.mkApp(Lazy.force coq_CZ, [| dump_z z |])
+      | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |])
+      | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |])
+      | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |])
+      | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |])
+      | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |])
+
+  let rec parse_Rcst term = 
+    let (i,c) = get_left_construct term in
+      match i with
+	| 1 -> Mc.C0
+	| 2 -> Mc.C1
+	| 3 -> Mc.CQ (parse_q c.(0))
+	| 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1))
+	| 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1))
+	| 6 -> Mc.CMult(parse_Rcst  c.(0), parse_Rcst c.(1))
+	| 7 -> Mc.CInv(parse_Rcst c.(0))
+	| 8 -> Mc.COpp(parse_Rcst c.(0))
+	| _ -> raise ParseError
+
+
+
+
   let rec parse_list parse_elt term =
    let (i,c) = get_left_construct term in
     match i with
@@ -768,12 +897,17 @@ struct
     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 parse_variable env term =
+      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) =
@@ -781,32 +915,34 @@ struct
       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)
+       try (Mc.PEc (parse_constant term) , env)
+       with ParseError -> 
+	 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)
+               )
+		   |   _ -> parse_variable env term
                )
-            |   _ -> constant_or_variable env term
-          )
-       | _ -> constant_or_variable env term in
+	   | _ -> parse_variable env term in
      parse_expr env term
 
   let zop_spec =
@@ -836,27 +972,57 @@ struct
   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 ());
+
+  let rconst_assoc = 
+    [ 
+      coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ;
+      coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; 
+      coq_Rmult  , (fun x y -> Mc.CMult(x,y)) ; 
+      coq_Rdiv   , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;
+    ]
+
+  let rec rconstant term =
    match Term.kind_of_term term with
     | Const x ->
         if term = Lazy.force coq_R0
-        then Mc.Z0
+        then Mc.C0
         else if term = Lazy.force coq_R1
-        then Mc.Zpos Mc.XH
+        then Mc.C1
         else raise ParseError
+    | App(op,args) -> 
+	begin
+	  try 
+	    (assoc_const   op rconst_assoc) (rconstant args.(0)) (rconstant args.(1))
+	  with
+	      ParseError -> 
+		match op with
+		  | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0))
+		  | op when op = Lazy.force coq_IQR  -> Mc.CQ (parse_q args.(0))
+(*		  | op when op = Lazy.force coq_IZR  -> Mc.CZ (parse_z args.(0))*)
+		  | _ ->  raise ParseError
+	end
+
     |  _ -> raise ParseError
 
+
+  let rconstant term = 
+    if debug
+    then (Pp.pp_flush ();
+          Pp.pp (Pp.str "rconstant: ");
+          Pp.pp (Printer.prterm  term); Pp.pp_flush ());
+    let res = rconstant term in
+      if debug then 
+	(Printf.printf "rconstant -> %a" pp_Rcst res ; flush stdout) ; 
+      res
+
+
   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))
+          |   _     ->  Mc.PEpow(expr, Mc.Z.to_N exp))
     zop_spec
 
   let parse_qexpr  =  parse_expr
@@ -870,14 +1036,14 @@ struct
                 | 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
+          | _     ->  let exp = Mc.Z.to_N  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
+      let exp = Mc.N.of_nat (parse_nat x) in
         Mc.PEpow(expr,exp))
    rop_spec
 
@@ -932,7 +1098,7 @@ struct
     * This is the big generic function for formula parsers.
     *)
   
-  let parse_formula parse_atom env term =
+  let parse_formula parse_atom env tg 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
@@ -941,17 +1107,17 @@ struct
      match kind_of_term term with
       | App(l,rst) ->
           (match rst with
-           | [|a;b|] when l = Lazy.force coq_and ->
+           | [|a;b|] when eq_constr l (Lazy.force coq_and) ->
                let f,env,tg = xparse_formula env tg a in
                let g,env, tg = xparse_formula env tg b  in
                mkformula_binary mkC term f g,env,tg
-           | [|a;b|] when l = Lazy.force coq_or ->
+           | [|a;b|] when eq_constr l (Lazy.force coq_or) ->
                let f,env,tg = xparse_formula env tg a in
                let g,env,tg  = xparse_formula env tg b in
                mkformula_binary mkD term f g,env,tg
-           | [|a|] when l = Lazy.force coq_not ->
+           | [|a|] when eq_constr l (Lazy.force coq_not) ->
                let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
-           | [|a;b|] when l = Lazy.force coq_iff ->
+           | [|a;b|] when eq_constr l (Lazy.force coq_iff) ->
                let f,env,tg = xparse_formula env tg a in
                let g,env,tg = xparse_formula env tg b in
                mkformula_binary mkIff term f g,env,tg
@@ -960,10 +1126,10 @@ struct
           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)
+      | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg)
+      | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg)
       | _  -> X(term),env,tg in
-    xparse_formula env term
+    xparse_formula env tg  ((*Reductionops.whd_zeta*) term)
 
   let dump_formula typ dump_atom f =
    let rec xdump f =
@@ -1024,9 +1190,9 @@ let tags_of_clause tgs wit clause =
   |   _   -> tgs in
   xtags tgs wit
 
-let tags_of_cnf wits cnf =
+(*let tags_of_cnf wits cnf =
  List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
-  Names.Idset.empty wits cnf
+  Names.Idset.empty wits cnf *)
 
 let find_witness prover polys1 = try_any prover polys1
 
@@ -1103,6 +1269,27 @@ let rec dump_proof_term = function
 	       [|  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 rec size_of_psatz = function
+  | Micromega.PsatzIn _ -> 1
+  | Micromega.PsatzSquare _ -> 1
+  | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p)
+  | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2
+  | Micromega.PsatzC _ -> 1
+  | Micromega.PsatzZ   -> 1
+
+let rec size_of_pf = function
+  | Micromega.DoneProof -> 1
+  | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p)
+  | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p)
+  | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l)
+
+let dump_proof_term t = 
+  if debug then  Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; 
+  dump_proof_term t
+
+
+
 let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
 
 
@@ -1139,13 +1326,12 @@ let parse_goal parse_arith env hyps term =
 (**
   * 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
+type ('synt_c, 'prf) domain_spec = {
+  typ : Term.constr; (* is the type of the interpretation domain - Z, Q, R*)
+  coeff : Term.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *)
+  dump_coeff : 'synt_c -> Term.constr ; 
+  proof_typ  : Term.constr ; 
+  dump_proof   : 'prf -> Term.constr
 }
 
 let zz_domain_spec  = lazy {
@@ -1164,12 +1350,12 @@ let qq_domain_spec  = lazy {
  dump_proof = dump_psatz coq_Q dump_q
 }
 
-let rz_domain_spec  = lazy {
+let rcst_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
+ coeff = Lazy.force coq_Rcst;
+ dump_coeff = dump_Rcst;
+ proof_typ = Lazy.force coq_QWitness ;
+ dump_proof = dump_psatz coq_Q dump_q
 }
 
 (**
@@ -1260,14 +1446,14 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
     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
+(*    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 ;
+      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... *)
@@ -1327,6 +1513,20 @@ let abstract_formula hyps f =
       | TT -> TT
   in  xabs f
 
+
+(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2   *)
+let rec abstract_wrt_formula f1 f2 = 
+  match f1 , f2 with
+    | X c  , _   -> X c
+    | A _  , A _ -> f2
+    | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b')
+    | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b')
+    | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b')
+    | FF , FF -> FF
+    | TT , TT -> TT
+    | N x , N y -> N(abstract_wrt_formula x y)
+    |    _    -> failwith "abstract_wrt_formula"
+
 (**
   * This exception is raised by really_call_csdpcert if Coq's configure didn't
   * find a CSDP executable.
@@ -1339,20 +1539,22 @@ exception CsdpNotFound
   * 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) =
+let formula_hyps_concl hyps concl = 
   List.fold_right
    (fun (id,f) (cc,ids) ->
     match f with
       X _ -> (cc,ids)
      | _ -> (I(f,Some id,cc), id::ids))
-   polys1 (polys2,[]) in
+    hyps (concl,[])
+
+
+let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl =
+
+ (* Express the goal as one big implication *)
+ let (ff,ids) = formula_hyps_concl polys1 polys2 in
 
  (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *)
- let cnf_ff = cnf negate normalise ff in
+ let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in
 
  if debug then
    begin
@@ -1365,19 +1567,19 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
    end;
 
  match witness_list_tags prover cnf_ff with
-  | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+  | None -> None
   | 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
+    TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (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
+  let cnf_ff',_ = cnf negate normalise unsat deduce ff' in
 
   if debug then
     begin
@@ -1400,41 +1602,124 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
       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 (ff',res',ids) = (ff',res', 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
+    Some (ids,ff',res')
+
+
 
 (**
   * Parse the proof environment, and call micromega_tauto
   *)
 
 let micromega_gen
-    parse_arith
+    parse_arith 
     (negate:'cst atom -> 'cst mc_cnf)
     (normalise:'cst atom -> 'cst mc_cnf)
+    unsat deduce 
     spec prover gl =
   let concl = Tacmach.pf_concl gl in
   let hyps  = Tacmach.pf_hyps_types gl in
   try
    let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
    let env = Env.elements env in
-    micromega_tauto negate normalise spec prover env hyps concl gl
+   let spec = Lazy.force spec in
+
+     match micromega_tauto  negate normalise unsat deduce spec prover env hyps concl gl with
+       | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+       | Some (ids,ff',res') -> 
+	   (Tacticals.tclTHENSEQ
+	      [
+		Tactics.generalize (List.map Term.mkVar ids) ;
+		micromega_order_change  spec res' 
+		  (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
+	      ]) gl
   with
-   | Failure x -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str x) gl
+(*   | 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"
-      ^ "This executable should be in PATH")) gl
+      ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+      ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
+
+
+
+let micromega_order_changer cert env ff gl =
+  let coeff = Lazy.force coq_Rcst in
+  let dump_coeff = dump_Rcst in
+  let typ  = Lazy.force coq_R in
+  let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in
+
+ let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
+ let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
+ let vm = dump_varmap (typ) env in
+  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", [|typ|]));
+      ("__wit", cert, cert_typ)
+     ]
+     (Tacmach.pf_concl gl)
+   )
+   gl
+
+
+let micromega_genr prover gl =
+  let parse_arith = parse_rarith in
+  let negate = Mc.rnegate in
+  let normalise = Mc.rnormalise in
+  let unsat = Mc.runsat in
+  let deduce = Mc.rdeduce in
+  let spec = lazy {
+    typ = Lazy.force coq_R;
+    coeff = Lazy.force coq_Rcst;
+    dump_coeff = dump_q;
+    proof_typ = Lazy.force coq_QWitness ;
+    dump_proof = dump_psatz coq_Q dump_q
+  } in
+    
+  let concl = Tacmach.pf_concl gl in
+  let hyps  = Tacmach.pf_hyps_types gl in
+  try
+   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let env = Env.elements env in
+   let spec = Lazy.force spec in
+
+   let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
+   let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
+
+     match micromega_tauto  negate normalise unsat deduce spec prover env hyps' concl' gl with
+       | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+       | Some (ids,ff',res') -> 
+           let (ff,ids') = formula_hyps_concl 
+	     (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in
+
+           (Tacticals.tclTHENSEQ
+              [
+                Tactics.generalize (List.map Term.mkVar ids) ;
+                micromega_order_changer res' env (abstract_wrt_formula ff' ff)
+              ]) gl
+  with
+(*   | Failure x -> flush stdout ; Pp.pp_flush () ;
+      Tacticals.tclFAIL 0 (Pp.str x) gl *)
+   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
+   | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
+      Tacticals.tclFAIL 0 (Pp.str 
+      (" Skipping what remains of this tactic: the complexity of the goal requires "
+      ^ "the use of a specialized external tool called csdp. \n\n" 
+      ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+      ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
+
+
+
+
 
 let lift_ratproof  prover l =
  match prover l with
@@ -1462,13 +1747,13 @@ 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.
+  * Throw CsdpNotFound if Coq isn't aware of any csdp executable.
   *)
 
 let require_csdp =
-  match System.search_exe_in_path "csdp" with
-    | Some _ -> lazy ()
-    | _ -> lazy (raise CsdpNotFound)
+  if System.is_in_system_path "csdp" 
+  then lazy ()
+  else lazy (raise CsdpNotFound)
 
 let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option  =
   fun provername poly ->
@@ -1607,15 +1892,17 @@ let linear_prover_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) ;
+  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_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)
+  pp_prf  = pp_psatz pp_q ;
+  pp_f    =  fun o x -> pp_pol pp_q o (fst x)
 }
 
+
 let non_linear_prover_Q str o = {
   name    = "real nonlinear prover";
   prover  = call_csdpcert_q (str, o);
@@ -1627,11 +1914,11 @@ let non_linear_prover_Q str o = {
 
 let non_linear_prover_R str o = {
   name    = "real nonlinear prover";
-  prover  = call_csdpcert_z (str, o);
+  prover  = call_csdpcert_q (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)
+  pp_prf  = pp_psatz pp_q;
+  pp_f    = fun o x -> pp_pol pp_q o  (fst x)
 }
 
 let non_linear_prover_Z str o  = {
@@ -1649,7 +1936,13 @@ module CacheZ = PHashtable(struct
   let hash  = Hashtbl.hash
 end)
 
-let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)
+let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia)
+let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia)
+
+(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*)
+(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*)
+
+
 
 let linear_Z =   {
   name    = "lia";
@@ -1660,50 +1953,81 @@ let linear_Z =   {
   pp_f    = fun o x -> pp_pol pp_z o (fst x)
 }
 
+let nlinear_Z =   {
+  name    = "nlia";
+  prover  = memo_nlia ;
+  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 tauto_lia ff = 
+  let prover = linear_Z in
+  let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce  ff in
+    match witness_list_tags [prover] cnf_ff with
+      | None -> None
+      | Some l -> Some (List.map fst l)
+
+
 (** 
   * 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
+ micromega_gen parse_zarith  Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
   [ linear_prover_Z ] gl
 
 let psatzl_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
   [ linear_prover_Q ] gl
 
 let psatz_Q i gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
   [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
 
+
 let psatzl_R gl =
- micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec
-  [ linear_prover_R ] gl
+ micromega_genr [ 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
+ micromega_genr  [ 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
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
+      [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
 
 let sos_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec
+ micromega_gen parse_zarith Mc.negate Mc.normalise  Mc.zunsat Mc.zdeduce zz_domain_spec
   [ non_linear_prover_Z "pure_sos" None ] gl
 
 let sos_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  qq_domain_spec
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  Mc.qunsat Mc.qdeduce qq_domain_spec
   [ non_linear_prover_Q "pure_sos" None ] gl
 
+
 let sos_R gl =
- micromega_gen parse_rarith Mc.rnegate Mc.rnormalise  rz_domain_spec
-  [ non_linear_prover_R "pure_sos" None ] gl
+ micromega_genr  [ 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
+  try 
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
+      [ linear_Z ] gl
+  with z -> (*Printexc.print_backtrace stdout ;*) raise z
+
+let xnlia gl =
+  try 
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
+      [ nlinear_Z ] gl
+  with z -> (*Printexc.print_backtrace stdout ;*) raise z
+
+
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
index 3b47007c..1604b0eb 100644
--- a/plugins/micromega/csdpcert.ml
+++ b/plugins/micromega/csdpcert.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -28,7 +28,7 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
 type provername = string * int option
 
 
-let debug = true
+let debug = false
 let flags = [Open_append;Open_binary;Open_creat]
 
 let chan = open_out_gen flags 0o666 "trace"
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 9b6842bd..3b6b6987 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,18 +8,18 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
+(* * Mappings from Coq tactics to Caml function calls                   *)
+(*                                                                      *)
 (*  Frédéric Besson (Irisa/Inria) 2006-2008			        *)
 (*                                                                      *)
 (************************************************************************)
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_micromega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Quote
 open Ring
 open Mutils
-open Rawterm
+open Glob_term
 open Util
 
 let out_arg = function
@@ -35,6 +35,11 @@ TACTIC EXTEND ZOmicron
 [ "xlia"  ] -> [ Coq_micromega.xlia]
 END
 
+TACTIC EXTEND Nlia
+[ "xnlia"  ] -> [ Coq_micromega.xnlia]
+END
+
+
 
 TACTIC EXTEND Sos_Z
 | [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
@@ -57,8 +62,6 @@ TACTIC EXTEND QOmicron
 [ "psatzl_Q"  ] -> [ Coq_micromega.psatzl_Q]
 END
 
-
-
 TACTIC EXTEND ROmicron
 [ "psatzl_R"  ] -> [ Coq_micromega.psatzl_R]
 END
@@ -68,7 +71,6 @@ TACTIC EXTEND RMicromega
 | [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
 END
 
-
 TACTIC EXTEND QMicromega
 | [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
 | [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index 6250e324..d9201722 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -1,5 +1,8 @@
 open Num
 module Utils = Mutils
+open Polynomial
+open Vect
+
 
 let map_option = Utils.map_option
 let from_option = Utils.from_option
@@ -7,132 +10,6 @@ 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
@@ -203,11 +80,11 @@ let in_bound bnd v =
     | 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
 **)
@@ -275,10 +152,6 @@ let pp_bound o  = function
 
 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 "{" ;
@@ -366,12 +239,7 @@ let normalise_cstr vect cinfo =
 			       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 -> ">="
+(** For compatibility, there is an external representation of constraints *)
 
 
 let eval_op = function
@@ -653,7 +521,7 @@ let solve_sys black_v choose_eq choose_variable sys sys_l =
       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) ;
+	    if debug then (Printf.printf "\nV : %i estimate %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
@@ -666,7 +534,7 @@ 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 ; *)
+      if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; 
       solve_sys black_v choose_eq choose_variable sys []
   with SystemContradiction prf -> Inr prf
 
@@ -752,20 +620,33 @@ struct
 	else if i < v then unroll_until v rl else (false,l)
 
 
+  let rec choose_simple_equation eqs = 
+    match eqs with
+      | [] -> None
+      | (vect,a,prf,ln)::eqs -> 
+	  match vect with 
+	    | [i,_] -> Some (i,vect,a,prf,ln)
+	    |   _   -> choose_simple_equation eqs 
+
+
+
   let choose_primal_equation eqs sys_l =
 
+    (* Counts the number of equations refering to variable [v] --
+       It looks like nb_cst is dead...
+    *)
     let is_primal_equation_var v =
-      List.fold_left (fun (nb_eq,nb_cst) (vect,info) ->
+      List.fold_left (fun nb_eq (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
+	then if itv_point  info.bound then nb_eq +  1 else nb_eq
+	else nb_eq) 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
+	    let nb_eq = is_primal_equation_var i in
+	      if nb_eq = 2 
 	      then Some i else find_var vect in
 
     let rec find_eq_var eqs =
@@ -776,10 +657,9 @@ struct
 		| None -> find_eq_var l
 		| Some r -> Some (r,vect,a,prf,ln)
     in
-
-
-      find_eq_var eqs
-
+      match choose_simple_equation eqs with
+	| None -> find_eq_var eqs
+	| Some res -> Some res
 
 
 
@@ -913,7 +793,8 @@ struct
         | 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) ,
+            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) })
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
index c350ed0f..564126d2 100644
--- a/plugins/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1,447 +1,2786 @@
+type __ = Obj.t
+let __ = let rec f _ = Obj.repr f in Obj.repr f
+
 (** val negb : bool -> bool **)
 
 let negb = function
-  | true -> false
-  | false -> true
+| true -> false
+| false -> true
 
 type nat =
-  | O
-  | S of nat
+| O
+| S of nat
+
+(** val fst : ('a1 * 'a2) -> 'a1 **)
+
+let fst = function
+| x,y -> x
+
+(** val snd : ('a1 * 'a2) -> 'a2 **)
+
+let snd = function
+| x,y -> y
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+  match l with
+  | [] -> m
+  | a::l1 -> a::(app l1 m)
 
 type comparison =
-  | Eq
-  | Lt
-  | Gt
+| Eq
+| Lt
+| Gt
 
 (** val compOpp : comparison -> comparison **)
 
 let compOpp = function
-  | Eq -> Eq
-  | Lt -> Gt
-  | Gt -> Lt
+| Eq -> Eq
+| Lt -> Gt
+| Gt -> Lt
 
-(** val plus : nat -> nat -> nat **)
+type compareSpecT =
+| CompEqT
+| CompLtT
+| CompGtT
 
-let rec plus n0 m =
-  match n0 with
-    | O -> m
-    | S p -> S (plus p m)
+(** val compareSpec2Type : comparison -> compareSpecT **)
 
-(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+let compareSpec2Type = function
+| Eq -> CompEqT
+| Lt -> CompLtT
+| Gt -> CompGtT
 
-let rec app l m =
-  match l with
-    | [] -> m
-    | a :: l1 -> a :: (app l1 m)
+type 'a compSpecT = compareSpecT
 
-(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **)
 
-let rec nth n0 l default =
+let compSpec2Type x y c =
+  compareSpec2Type c
+
+type 'a sig0 =
+  'a
+  (* singleton inductive, whose constructor was exist *)
+
+(** val plus : nat -> nat -> nat **)
+
+let rec plus n0 m =
   match n0 with
-    | O -> (match l with
-              | [] -> default
-              | x :: l' -> x)
-    | S m -> (match l with
-                | [] -> default
-                | x :: t0 -> nth m t0 default)
+  | O -> m
+  | S p -> S (plus p m)
 
-(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
 
-let rec map f = function
-  | [] -> []
-  | a :: t0 -> (f a) :: (map f t0)
+let rec nat_iter n0 f x =
+  match n0 with
+  | O -> x
+  | S n' -> f (nat_iter n' f x)
 
 type positive =
-  | XI of positive
-  | XO of positive
-  | XH
+| XI of positive
+| XO of positive
+| XH
 
-(** val psucc : positive -> positive **)
+type n =
+| N0
+| Npos of positive
 
-let rec psucc = function
-  | XI p -> XO (psucc p)
+type z =
+| Z0
+| Zpos of positive
+| Zneg of positive
+
+module type TotalOrder' = 
+ sig 
+  type t 
+ end
+
+module MakeOrderTac = 
+ functor (O:TotalOrder') ->
+ struct 
+  
+ end
+
+module MaxLogicalProperties = 
+ functor (O:TotalOrder') ->
+ functor (M:sig 
+  val max : O.t -> O.t -> O.t
+ end) ->
+ struct 
+  module T = MakeOrderTac(O)
+ end
+
+module Pos = 
+ struct 
+  type t = positive
+  
+  (** val succ : positive -> positive **)
+  
+  let rec succ = function
+  | XI p -> XO (succ p)
   | XO p -> XI p
   | XH -> XO XH
-
-(** val pplus : positive -> positive -> positive **)
-
-let rec pplus x y =
-  match x with
+  
+  (** val add : positive -> positive -> positive **)
+  
+  let rec add x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> XO (pplus_carry p q0)
-           | XO q0 -> XI (pplus p q0)
-           | XH -> XO (psucc p))
+      (match y with
+       | XI q0 -> XO (add_carry p q0)
+       | XO q0 -> XI (add p q0)
+       | XH -> XO (succ p))
     | XO p ->
-        (match y with
-           | XI q0 -> XI (pplus p q0)
-           | XO q0 -> XO (pplus p q0)
-           | XH -> XI p)
+      (match y with
+       | XI q0 -> XI (add p q0)
+       | XO q0 -> XO (add p q0)
+       | XH -> XI p)
     | XH ->
-        (match y with
-           | XI q0 -> XO (psucc q0)
-           | XO q0 -> XI q0
-           | XH -> XO XH)
-
-(** val pplus_carry : positive -> positive -> positive **)
-
-and pplus_carry x y =
-  match x with
+      (match y with
+       | XI q0 -> XO (succ q0)
+       | XO q0 -> XI q0
+       | XH -> XO XH)
+  
+  (** val add_carry : positive -> positive -> positive **)
+  
+  and add_carry x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> XI (pplus_carry p q0)
-           | XO q0 -> XO (pplus_carry p q0)
-           | XH -> XI (psucc p))
+      (match y with
+       | XI q0 -> XI (add_carry p q0)
+       | XO q0 -> XO (add_carry p q0)
+       | XH -> XI (succ p))
     | XO p ->
-        (match y with
-           | XI q0 -> XO (pplus_carry p q0)
-           | XO q0 -> XI (pplus p q0)
-           | XH -> XO (psucc p))
+      (match y with
+       | XI q0 -> XO (add_carry p q0)
+       | XO q0 -> XI (add p q0)
+       | XH -> XO (succ p))
     | XH ->
-        (match y with
-           | XI q0 -> XI (psucc q0)
-           | XO q0 -> XO (psucc q0)
-           | XH -> XI XH)
-
-(** val p_of_succ_nat : nat -> positive **)
-
-let rec p_of_succ_nat = function
-  | O -> XH
-  | S x -> psucc (p_of_succ_nat x)
-
-(** val pdouble_minus_one : positive -> positive **)
-
-let rec pdouble_minus_one = function
+      (match y with
+       | XI q0 -> XI (succ q0)
+       | XO q0 -> XO (succ q0)
+       | XH -> XI XH)
+  
+  (** val pred_double : positive -> positive **)
+  
+  let rec pred_double = function
   | XI p -> XI (XO p)
-  | XO p -> XI (pdouble_minus_one p)
+  | XO p -> XI (pred_double p)
   | XH -> XH
-
-type positive_mask =
+  
+  (** val pred : positive -> positive **)
+  
+  let pred = function
+  | XI p -> XO p
+  | XO p -> pred_double p
+  | XH -> XH
+  
+  (** val pred_N : positive -> n **)
+  
+  let pred_N = function
+  | XI p -> Npos (XO p)
+  | XO p -> Npos (pred_double p)
+  | XH -> N0
+  
+  type mask =
   | IsNul
   | IsPos of positive
   | IsNeg
-
-(** val pdouble_plus_one_mask : positive_mask -> positive_mask **)
-
-let pdouble_plus_one_mask = function
+  
+  (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
+  
+  let mask_rect f f0 f1 = function
+  | IsNul -> f
+  | IsPos x -> f0 x
+  | IsNeg -> f1
+  
+  (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
+  
+  let mask_rec f f0 f1 = function
+  | IsNul -> f
+  | IsPos x -> f0 x
+  | IsNeg -> f1
+  
+  (** val succ_double_mask : mask -> mask **)
+  
+  let succ_double_mask = function
   | IsNul -> IsPos XH
   | IsPos p -> IsPos (XI p)
   | IsNeg -> IsNeg
-
-(** val pdouble_mask : positive_mask -> positive_mask **)
-
-let pdouble_mask = function
-  | IsNul -> IsNul
+  
+  (** val double_mask : mask -> mask **)
+  
+  let double_mask = function
   | IsPos p -> IsPos (XO p)
-  | IsNeg -> IsNeg
-
-(** val pdouble_minus_two : positive -> positive_mask **)
-
-let pdouble_minus_two = function
+  | x0 -> x0
+  
+  (** val double_pred_mask : positive -> mask **)
+  
+  let double_pred_mask = function
   | XI p -> IsPos (XO (XO p))
-  | XO p -> IsPos (XO (pdouble_minus_one p))
+  | XO p -> IsPos (XO (pred_double p))
   | XH -> IsNul
-
-(** val pminus_mask : positive -> positive -> positive_mask **)
-
-let rec pminus_mask x y =
-  match x with
+  
+  (** val pred_mask : mask -> mask **)
+  
+  let pred_mask = function
+  | IsPos q0 ->
+    (match q0 with
+     | XH -> IsNul
+     | _ -> IsPos (pred q0))
+  | _ -> IsNeg
+  
+  (** val sub_mask : positive -> positive -> mask **)
+  
+  let rec sub_mask x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> pdouble_mask (pminus_mask p q0)
-           | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0)
-           | XH -> IsPos (XO p))
+      (match y with
+       | XI q0 -> double_mask (sub_mask p q0)
+       | XO q0 -> succ_double_mask (sub_mask p q0)
+       | XH -> IsPos (XO p))
     | XO p ->
-        (match y with
-           | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
-           | XO q0 -> pdouble_mask (pminus_mask p q0)
-           | XH -> IsPos (pdouble_minus_one p))
-    | XH -> (match y with
-               | XH -> IsNul
-               | _ -> IsNeg)
-
-(** val pminus_mask_carry : positive -> positive -> positive_mask **)
-
-and pminus_mask_carry x y =
-  match x with
+      (match y with
+       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XO q0 -> double_mask (sub_mask p q0)
+       | XH -> IsPos (pred_double p))
+    | XH ->
+      (match y with
+       | XH -> IsNul
+       | _ -> IsNeg)
+  
+  (** val sub_mask_carry : positive -> positive -> mask **)
+  
+  and sub_mask_carry x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
-           | XO q0 -> pdouble_mask (pminus_mask p q0)
-           | XH -> IsPos (pdouble_minus_one p))
+      (match y with
+       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XO q0 -> double_mask (sub_mask p q0)
+       | XH -> IsPos (pred_double p))
     | XO p ->
-        (match y with
-           | XI q0 -> pdouble_mask (pminus_mask_carry p q0)
-           | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
-           | XH -> pdouble_minus_two p)
+      (match y with
+       | XI q0 -> double_mask (sub_mask_carry p q0)
+       | XO q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XH -> double_pred_mask p)
     | XH -> IsNeg
-
-(** val pminus : positive -> positive -> positive **)
-
-let pminus x y =
-  match pminus_mask x y with
+  
+  (** val sub : positive -> positive -> positive **)
+  
+  let sub x y =
+    match sub_mask x y with
     | IsPos z0 -> z0
     | _ -> XH
-
-(** val pmult : positive -> positive -> positive **)
-
-let rec pmult x y =
-  match x with
-    | XI p -> pplus y (XO (pmult p y))
-    | XO p -> XO (pmult p y)
+  
+  (** val mul : positive -> positive -> positive **)
+  
+  let rec mul x y =
+    match x with
+    | XI p -> add y (XO (mul p y))
+    | XO p -> XO (mul p y)
     | XH -> y
-
-(** val pcompare : positive -> positive -> comparison -> comparison **)
-
-let rec pcompare x y r =
-  match x with
+  
+  (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+  
+  let rec iter n0 f x =
+    match n0 with
+    | XI n' -> f (iter n' f (iter n' f x))
+    | XO n' -> iter n' f (iter n' f x)
+    | XH -> f x
+  
+  (** val pow : positive -> positive -> positive **)
+  
+  let pow x y =
+    iter y (mul x) XH
+  
+  (** val div2 : positive -> positive **)
+  
+  let div2 = function
+  | XI p2 -> p2
+  | XO p2 -> p2
+  | XH -> XH
+  
+  (** val div2_up : positive -> positive **)
+  
+  let div2_up = function
+  | XI p2 -> succ p2
+  | XO p2 -> p2
+  | XH -> XH
+  
+  (** val size_nat : positive -> nat **)
+  
+  let rec size_nat = function
+  | XI p2 -> S (size_nat p2)
+  | XO p2 -> S (size_nat p2)
+  | XH -> S O
+  
+  (** val size : positive -> positive **)
+  
+  let rec size = function
+  | XI p2 -> succ (size p2)
+  | XO p2 -> succ (size p2)
+  | XH -> XH
+  
+  (** val compare_cont : positive -> positive -> comparison -> comparison **)
+  
+  let rec compare_cont x y r =
+    match x with
+    | XI p ->
+      (match y with
+       | XI q0 -> compare_cont p q0 r
+       | XO q0 -> compare_cont p q0 Gt
+       | XH -> Gt)
+    | XO p ->
+      (match y with
+       | XI q0 -> compare_cont p q0 Lt
+       | XO q0 -> compare_cont p q0 r
+       | XH -> Gt)
+    | XH ->
+      (match y with
+       | XH -> r
+       | _ -> Lt)
+  
+  (** val compare : positive -> positive -> comparison **)
+  
+  let compare x y =
+    compare_cont x y Eq
+  
+  (** val min : positive -> positive -> positive **)
+  
+  let min p p' =
+    match compare p p' with
+    | Gt -> p'
+    | _ -> p
+  
+  (** val max : positive -> positive -> positive **)
+  
+  let max p p' =
+    match compare p p' with
+    | Gt -> p
+    | _ -> p'
+  
+  (** val eqb : positive -> positive -> bool **)
+  
+  let rec eqb p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> eqb p2 q1
+       | _ -> false)
+    | XO p2 ->
+      (match q0 with
+       | XO q1 -> eqb p2 q1
+       | _ -> false)
+    | XH ->
+      (match q0 with
+       | XH -> true
+       | _ -> false)
+  
+  (** val leb : positive -> positive -> bool **)
+  
+  let leb x y =
+    match compare x y with
+    | Gt -> false
+    | _ -> true
+  
+  (** val ltb : positive -> positive -> bool **)
+  
+  let ltb x y =
+    match compare x y with
+    | Lt -> true
+    | _ -> false
+  
+  (** val sqrtrem_step :
+      (positive -> positive) -> (positive -> positive) -> (positive * mask)
+      -> positive * mask **)
+  
+  let sqrtrem_step f g = function
+  | s,y ->
+    (match y with
+     | IsPos r ->
+       let s' = XI (XO s) in
+       let r' = g (f r) in
+       if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
+     | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
+  
+  (** val sqrtrem : positive -> positive * mask **)
+  
+  let rec sqrtrem = function
+  | XI p2 ->
+    (match p2 with
+     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
+     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
+     | XH -> XH,(IsPos (XO XH)))
+  | XO p2 ->
+    (match p2 with
+     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
+     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
+     | XH -> XH,(IsPos XH))
+  | XH -> XH,IsNul
+  
+  (** val sqrt : positive -> positive **)
+  
+  let sqrt p =
+    fst (sqrtrem p)
+  
+  (** val gcdn : nat -> positive -> positive -> positive **)
+  
+  let rec gcdn n0 a b =
+    match n0 with
+    | O -> XH
+    | S n1 ->
+      (match a with
+       | XI a' ->
+         (match b with
+          | XI b' ->
+            (match compare a' b' with
+             | Eq -> a
+             | Lt -> gcdn n1 (sub b' a') a
+             | Gt -> gcdn n1 (sub a' b') b)
+          | XO b0 -> gcdn n1 a b0
+          | XH -> XH)
+       | XO a0 ->
+         (match b with
+          | XI p -> gcdn n1 a0 b
+          | XO b0 -> XO (gcdn n1 a0 b0)
+          | XH -> XH)
+       | XH -> XH)
+  
+  (** val gcd : positive -> positive -> positive **)
+  
+  let gcd a b =
+    gcdn (plus (size_nat a) (size_nat b)) a b
+  
+  (** val ggcdn :
+      nat -> positive -> positive -> positive * (positive * positive) **)
+  
+  let rec ggcdn n0 a b =
+    match n0 with
+    | O -> XH,(a,b)
+    | S n1 ->
+      (match a with
+       | XI a' ->
+         (match b with
+          | XI b' ->
+            (match compare a' b' with
+             | Eq -> a,(XH,XH)
+             | Lt ->
+               let g,p = ggcdn n1 (sub b' a') a in
+               let ba,aa = p in g,(aa,(add aa (XO ba)))
+             | Gt ->
+               let g,p = ggcdn n1 (sub a' b') b in
+               let ab,bb = p in g,((add bb (XO ab)),bb))
+          | XO b0 ->
+            let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
+          | XH -> XH,(a,XH))
+       | XO a0 ->
+         (match b with
+          | XI p ->
+            let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
+          | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
+          | XH -> XH,(a,XH))
+       | XH -> XH,(XH,b))
+  
+  (** val ggcd : positive -> positive -> positive * (positive * positive) **)
+  
+  let ggcd a b =
+    ggcdn (plus (size_nat a) (size_nat b)) a b
+  
+  (** val coq_Nsucc_double : n -> n **)
+  
+  let coq_Nsucc_double = function
+  | N0 -> Npos XH
+  | Npos p -> Npos (XI p)
+  
+  (** val coq_Ndouble : n -> n **)
+  
+  let coq_Ndouble = function
+  | N0 -> N0
+  | Npos p -> Npos (XO p)
+  
+  (** val coq_lor : positive -> positive -> positive **)
+  
+  let rec coq_lor p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> XI (coq_lor p2 q1)
+       | XO q1 -> XI (coq_lor p2 q1)
+       | XH -> p)
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> XI (coq_lor p2 q1)
+       | XO q1 -> XO (coq_lor p2 q1)
+       | XH -> XI p2)
+    | XH ->
+      (match q0 with
+       | XO q1 -> XI q1
+       | _ -> q0)
+  
+  (** val coq_land : positive -> positive -> n **)
+  
+  let rec coq_land p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
+       | XO q1 -> coq_Ndouble (coq_land p2 q1)
+       | XH -> Npos XH)
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (coq_land p2 q1)
+       | XO q1 -> coq_Ndouble (coq_land p2 q1)
+       | XH -> N0)
+    | XH ->
+      (match q0 with
+       | XO q1 -> N0
+       | _ -> Npos XH)
+  
+  (** val ldiff : positive -> positive -> n **)
+  
+  let rec ldiff p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (ldiff p2 q1)
+       | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
+       | XH -> Npos (XO p2))
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (ldiff p2 q1)
+       | XO q1 -> coq_Ndouble (ldiff p2 q1)
+       | XH -> Npos p)
+    | XH ->
+      (match q0 with
+       | XO q1 -> Npos XH
+       | _ -> N0)
+  
+  (** val coq_lxor : positive -> positive -> n **)
+  
+  let rec coq_lxor p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
+       | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
+       | XH -> Npos (XO p2))
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
+       | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
+       | XH -> Npos (XI p2))
+    | XH ->
+      (match q0 with
+       | XI q1 -> Npos (XO q1)
+       | XO q1 -> Npos (XI q1)
+       | XH -> N0)
+  
+  (** val shiftl_nat : positive -> nat -> positive **)
+  
+  let shiftl_nat p n0 =
+    nat_iter n0 (fun x -> XO x) p
+  
+  (** val shiftr_nat : positive -> nat -> positive **)
+  
+  let shiftr_nat p n0 =
+    nat_iter n0 div2 p
+  
+  (** val shiftl : positive -> n -> positive **)
+  
+  let shiftl p = function
+  | N0 -> p
+  | Npos n1 -> iter n1 (fun x -> XO x) p
+  
+  (** val shiftr : positive -> n -> positive **)
+  
+  let shiftr p = function
+  | N0 -> p
+  | Npos n1 -> iter n1 div2 p
+  
+  (** val testbit_nat : positive -> nat -> bool **)
+  
+  let rec testbit_nat p n0 =
+    match p with
+    | XI p2 ->
+      (match n0 with
+       | O -> true
+       | S n' -> testbit_nat p2 n')
+    | XO p2 ->
+      (match n0 with
+       | O -> false
+       | S n' -> testbit_nat p2 n')
+    | XH ->
+      (match n0 with
+       | O -> true
+       | S n1 -> false)
+  
+  (** val testbit : positive -> n -> bool **)
+  
+  let rec testbit p n0 =
+    match p with
+    | XI p2 ->
+      (match n0 with
+       | N0 -> true
+       | Npos n1 -> testbit p2 (pred_N n1))
+    | XO p2 ->
+      (match n0 with
+       | N0 -> false
+       | Npos n1 -> testbit p2 (pred_N n1))
+    | XH ->
+      (match n0 with
+       | N0 -> true
+       | Npos p2 -> false)
+  
+  (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
+  
+  let rec iter_op op p a =
+    match p with
+    | XI p2 -> op a (iter_op op p2 (op a a))
+    | XO p2 -> iter_op op p2 (op a a)
+    | XH -> a
+  
+  (** val to_nat : positive -> nat **)
+  
+  let to_nat x =
+    iter_op plus x (S O)
+  
+  (** val of_nat : nat -> positive **)
+  
+  let rec of_nat = function
+  | O -> XH
+  | S x ->
+    (match x with
+     | O -> XH
+     | S n1 -> succ (of_nat x))
+  
+  (** val of_succ_nat : nat -> positive **)
+  
+  let rec of_succ_nat = function
+  | O -> XH
+  | S x -> succ (of_succ_nat x)
+ end
+
+module Coq_Pos = 
+ struct 
+  module Coq__1 = struct 
+   type t = positive
+  end
+  type t = Coq__1.t
+  
+  (** val succ : positive -> positive **)
+  
+  let rec succ = function
+  | XI p -> XO (succ p)
+  | XO p -> XI p
+  | XH -> XO XH
+  
+  (** val add : positive -> positive -> positive **)
+  
+  let rec add x y =
+    match x with
+    | XI p ->
+      (match y with
+       | XI q0 -> XO (add_carry p q0)
+       | XO q0 -> XI (add p q0)
+       | XH -> XO (succ p))
+    | XO p ->
+      (match y with
+       | XI q0 -> XI (add p q0)
+       | XO q0 -> XO (add p q0)
+       | XH -> XI p)
+    | XH ->
+      (match y with
+       | XI q0 -> XO (succ q0)
+       | XO q0 -> XI q0
+       | XH -> XO XH)
+  
+  (** val add_carry : positive -> positive -> positive **)
+  
+  and add_carry x y =
+    match x with
+    | XI p ->
+      (match y with
+       | XI q0 -> XI (add_carry p q0)
+       | XO q0 -> XO (add_carry p q0)
+       | XH -> XI (succ p))
+    | XO p ->
+      (match y with
+       | XI q0 -> XO (add_carry p q0)
+       | XO q0 -> XI (add p q0)
+       | XH -> XO (succ p))
+    | XH ->
+      (match y with
+       | XI q0 -> XI (succ q0)
+       | XO q0 -> XO (succ q0)
+       | XH -> XI XH)
+  
+  (** val pred_double : positive -> positive **)
+  
+  let rec pred_double = function
+  | XI p -> XI (XO p)
+  | XO p -> XI (pred_double p)
+  | XH -> XH
+  
+  (** val pred : positive -> positive **)
+  
+  let pred = function
+  | XI p -> XO p
+  | XO p -> pred_double p
+  | XH -> XH
+  
+  (** val pred_N : positive -> n **)
+  
+  let pred_N = function
+  | XI p -> Npos (XO p)
+  | XO p -> Npos (pred_double p)
+  | XH -> N0
+  
+  type mask = Pos.mask =
+  | IsNul
+  | IsPos of positive
+  | IsNeg
+  
+  (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
+  
+  let mask_rect f f0 f1 = function
+  | IsNul -> f
+  | IsPos x -> f0 x
+  | IsNeg -> f1
+  
+  (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
+  
+  let mask_rec f f0 f1 = function
+  | IsNul -> f
+  | IsPos x -> f0 x
+  | IsNeg -> f1
+  
+  (** val succ_double_mask : mask -> mask **)
+  
+  let succ_double_mask = function
+  | IsNul -> IsPos XH
+  | IsPos p -> IsPos (XI p)
+  | IsNeg -> IsNeg
+  
+  (** val double_mask : mask -> mask **)
+  
+  let double_mask = function
+  | IsPos p -> IsPos (XO p)
+  | x0 -> x0
+  
+  (** val double_pred_mask : positive -> mask **)
+  
+  let double_pred_mask = function
+  | XI p -> IsPos (XO (XO p))
+  | XO p -> IsPos (XO (pred_double p))
+  | XH -> IsNul
+  
+  (** val pred_mask : mask -> mask **)
+  
+  let pred_mask = function
+  | IsPos q0 ->
+    (match q0 with
+     | XH -> IsNul
+     | _ -> IsPos (pred q0))
+  | _ -> IsNeg
+  
+  (** val sub_mask : positive -> positive -> mask **)
+  
+  let rec sub_mask x y =
+    match x with
+    | XI p ->
+      (match y with
+       | XI q0 -> double_mask (sub_mask p q0)
+       | XO q0 -> succ_double_mask (sub_mask p q0)
+       | XH -> IsPos (XO p))
+    | XO p ->
+      (match y with
+       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XO q0 -> double_mask (sub_mask p q0)
+       | XH -> IsPos (pred_double p))
+    | XH ->
+      (match y with
+       | XH -> IsNul
+       | _ -> IsNeg)
+  
+  (** val sub_mask_carry : positive -> positive -> mask **)
+  
+  and sub_mask_carry x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> pcompare p q0 r
-           | XO q0 -> pcompare p q0 Gt
-           | XH -> Gt)
+      (match y with
+       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XO q0 -> double_mask (sub_mask p q0)
+       | XH -> IsPos (pred_double p))
     | XO p ->
-        (match y with
-           | XI q0 -> pcompare p q0 Lt
-           | XO q0 -> pcompare p q0 r
-           | XH -> Gt)
-    | XH -> (match y with
-               | XH -> r
-               | _ -> Lt)
-
-(** val psize : positive -> nat **)
-
-let rec psize = function
-  | XI p2 -> S (psize p2)
-  | XO p2 -> S (psize p2)
+      (match y with
+       | XI q0 -> double_mask (sub_mask_carry p q0)
+       | XO q0 -> succ_double_mask (sub_mask_carry p q0)
+       | XH -> double_pred_mask p)
+    | XH -> IsNeg
+  
+  (** val sub : positive -> positive -> positive **)
+  
+  let sub x y =
+    match sub_mask x y with
+    | IsPos z0 -> z0
+    | _ -> XH
+  
+  (** val mul : positive -> positive -> positive **)
+  
+  let rec mul x y =
+    match x with
+    | XI p -> add y (XO (mul p y))
+    | XO p -> XO (mul p y)
+    | XH -> y
+  
+  (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+  
+  let rec iter n0 f x =
+    match n0 with
+    | XI n' -> f (iter n' f (iter n' f x))
+    | XO n' -> iter n' f (iter n' f x)
+    | XH -> f x
+  
+  (** val pow : positive -> positive -> positive **)
+  
+  let pow x y =
+    iter y (mul x) XH
+  
+  (** val div2 : positive -> positive **)
+  
+  let div2 = function
+  | XI p2 -> p2
+  | XO p2 -> p2
+  | XH -> XH
+  
+  (** val div2_up : positive -> positive **)
+  
+  let div2_up = function
+  | XI p2 -> succ p2
+  | XO p2 -> p2
+  | XH -> XH
+  
+  (** val size_nat : positive -> nat **)
+  
+  let rec size_nat = function
+  | XI p2 -> S (size_nat p2)
+  | XO p2 -> S (size_nat p2)
   | XH -> S O
-
-type n =
-  | N0
-  | Npos of positive
+  
+  (** val size : positive -> positive **)
+  
+  let rec size = function
+  | XI p2 -> succ (size p2)
+  | XO p2 -> succ (size p2)
+  | XH -> XH
+  
+  (** val compare_cont : positive -> positive -> comparison -> comparison **)
+  
+  let rec compare_cont x y r =
+    match x with
+    | XI p ->
+      (match y with
+       | XI q0 -> compare_cont p q0 r
+       | XO q0 -> compare_cont p q0 Gt
+       | XH -> Gt)
+    | XO p ->
+      (match y with
+       | XI q0 -> compare_cont p q0 Lt
+       | XO q0 -> compare_cont p q0 r
+       | XH -> Gt)
+    | XH ->
+      (match y with
+       | XH -> r
+       | _ -> Lt)
+  
+  (** val compare : positive -> positive -> comparison **)
+  
+  let compare x y =
+    compare_cont x y Eq
+  
+  (** val min : positive -> positive -> positive **)
+  
+  let min p p' =
+    match compare p p' with
+    | Gt -> p'
+    | _ -> p
+  
+  (** val max : positive -> positive -> positive **)
+  
+  let max p p' =
+    match compare p p' with
+    | Gt -> p
+    | _ -> p'
+  
+  (** val eqb : positive -> positive -> bool **)
+  
+  let rec eqb p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> eqb p2 q1
+       | _ -> false)
+    | XO p2 ->
+      (match q0 with
+       | XO q1 -> eqb p2 q1
+       | _ -> false)
+    | XH ->
+      (match q0 with
+       | XH -> true
+       | _ -> false)
+  
+  (** val leb : positive -> positive -> bool **)
+  
+  let leb x y =
+    match compare x y with
+    | Gt -> false
+    | _ -> true
+  
+  (** val ltb : positive -> positive -> bool **)
+  
+  let ltb x y =
+    match compare x y with
+    | Lt -> true
+    | _ -> false
+  
+  (** val sqrtrem_step :
+      (positive -> positive) -> (positive -> positive) -> (positive * mask)
+      -> positive * mask **)
+  
+  let sqrtrem_step f g = function
+  | s,y ->
+    (match y with
+     | IsPos r ->
+       let s' = XI (XO s) in
+       let r' = g (f r) in
+       if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
+     | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
+  
+  (** val sqrtrem : positive -> positive * mask **)
+  
+  let rec sqrtrem = function
+  | XI p2 ->
+    (match p2 with
+     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
+     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
+     | XH -> XH,(IsPos (XO XH)))
+  | XO p2 ->
+    (match p2 with
+     | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
+     | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
+     | XH -> XH,(IsPos XH))
+  | XH -> XH,IsNul
+  
+  (** val sqrt : positive -> positive **)
+  
+  let sqrt p =
+    fst (sqrtrem p)
+  
+  (** val gcdn : nat -> positive -> positive -> positive **)
+  
+  let rec gcdn n0 a b =
+    match n0 with
+    | O -> XH
+    | S n1 ->
+      (match a with
+       | XI a' ->
+         (match b with
+          | XI b' ->
+            (match compare a' b' with
+             | Eq -> a
+             | Lt -> gcdn n1 (sub b' a') a
+             | Gt -> gcdn n1 (sub a' b') b)
+          | XO b0 -> gcdn n1 a b0
+          | XH -> XH)
+       | XO a0 ->
+         (match b with
+          | XI p -> gcdn n1 a0 b
+          | XO b0 -> XO (gcdn n1 a0 b0)
+          | XH -> XH)
+       | XH -> XH)
+  
+  (** val gcd : positive -> positive -> positive **)
+  
+  let gcd a b =
+    gcdn (plus (size_nat a) (size_nat b)) a b
+  
+  (** val ggcdn :
+      nat -> positive -> positive -> positive * (positive * positive) **)
+  
+  let rec ggcdn n0 a b =
+    match n0 with
+    | O -> XH,(a,b)
+    | S n1 ->
+      (match a with
+       | XI a' ->
+         (match b with
+          | XI b' ->
+            (match compare a' b' with
+             | Eq -> a,(XH,XH)
+             | Lt ->
+               let g,p = ggcdn n1 (sub b' a') a in
+               let ba,aa = p in g,(aa,(add aa (XO ba)))
+             | Gt ->
+               let g,p = ggcdn n1 (sub a' b') b in
+               let ab,bb = p in g,((add bb (XO ab)),bb))
+          | XO b0 ->
+            let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
+          | XH -> XH,(a,XH))
+       | XO a0 ->
+         (match b with
+          | XI p ->
+            let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
+          | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
+          | XH -> XH,(a,XH))
+       | XH -> XH,(XH,b))
+  
+  (** val ggcd : positive -> positive -> positive * (positive * positive) **)
+  
+  let ggcd a b =
+    ggcdn (plus (size_nat a) (size_nat b)) a b
+  
+  (** val coq_Nsucc_double : n -> n **)
+  
+  let coq_Nsucc_double = function
+  | N0 -> Npos XH
+  | Npos p -> Npos (XI p)
+  
+  (** val coq_Ndouble : n -> n **)
+  
+  let coq_Ndouble = function
+  | N0 -> N0
+  | Npos p -> Npos (XO p)
+  
+  (** val coq_lor : positive -> positive -> positive **)
+  
+  let rec coq_lor p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> XI (coq_lor p2 q1)
+       | XO q1 -> XI (coq_lor p2 q1)
+       | XH -> p)
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> XI (coq_lor p2 q1)
+       | XO q1 -> XO (coq_lor p2 q1)
+       | XH -> XI p2)
+    | XH ->
+      (match q0 with
+       | XO q1 -> XI q1
+       | _ -> q0)
+  
+  (** val coq_land : positive -> positive -> n **)
+  
+  let rec coq_land p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
+       | XO q1 -> coq_Ndouble (coq_land p2 q1)
+       | XH -> Npos XH)
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (coq_land p2 q1)
+       | XO q1 -> coq_Ndouble (coq_land p2 q1)
+       | XH -> N0)
+    | XH ->
+      (match q0 with
+       | XO q1 -> N0
+       | _ -> Npos XH)
+  
+  (** val ldiff : positive -> positive -> n **)
+  
+  let rec ldiff p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (ldiff p2 q1)
+       | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
+       | XH -> Npos (XO p2))
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (ldiff p2 q1)
+       | XO q1 -> coq_Ndouble (ldiff p2 q1)
+       | XH -> Npos p)
+    | XH ->
+      (match q0 with
+       | XO q1 -> Npos XH
+       | _ -> N0)
+  
+  (** val coq_lxor : positive -> positive -> n **)
+  
+  let rec coq_lxor p q0 =
+    match p with
+    | XI p2 ->
+      (match q0 with
+       | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
+       | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
+       | XH -> Npos (XO p2))
+    | XO p2 ->
+      (match q0 with
+       | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
+       | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
+       | XH -> Npos (XI p2))
+    | XH ->
+      (match q0 with
+       | XI q1 -> Npos (XO q1)
+       | XO q1 -> Npos (XI q1)
+       | XH -> N0)
+  
+  (** val shiftl_nat : positive -> nat -> positive **)
+  
+  let shiftl_nat p n0 =
+    nat_iter n0 (fun x -> XO x) p
+  
+  (** val shiftr_nat : positive -> nat -> positive **)
+  
+  let shiftr_nat p n0 =
+    nat_iter n0 div2 p
+  
+  (** val shiftl : positive -> n -> positive **)
+  
+  let shiftl p = function
+  | N0 -> p
+  | Npos n1 -> iter n1 (fun x -> XO x) p
+  
+  (** val shiftr : positive -> n -> positive **)
+  
+  let shiftr p = function
+  | N0 -> p
+  | Npos n1 -> iter n1 div2 p
+  
+  (** val testbit_nat : positive -> nat -> bool **)
+  
+  let rec testbit_nat p n0 =
+    match p with
+    | XI p2 ->
+      (match n0 with
+       | O -> true
+       | S n' -> testbit_nat p2 n')
+    | XO p2 ->
+      (match n0 with
+       | O -> false
+       | S n' -> testbit_nat p2 n')
+    | XH ->
+      (match n0 with
+       | O -> true
+       | S n1 -> false)
+  
+  (** val testbit : positive -> n -> bool **)
+  
+  let rec testbit p n0 =
+    match p with
+    | XI p2 ->
+      (match n0 with
+       | N0 -> true
+       | Npos n1 -> testbit p2 (pred_N n1))
+    | XO p2 ->
+      (match n0 with
+       | N0 -> false
+       | Npos n1 -> testbit p2 (pred_N n1))
+    | XH ->
+      (match n0 with
+       | N0 -> true
+       | Npos p2 -> false)
+  
+  (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
+  
+  let rec iter_op op p a =
+    match p with
+    | XI p2 -> op a (iter_op op p2 (op a a))
+    | XO p2 -> iter_op op p2 (op a a)
+    | XH -> a
+  
+  (** val to_nat : positive -> nat **)
+  
+  let to_nat x =
+    iter_op plus x (S O)
+  
+  (** val of_nat : nat -> positive **)
+  
+  let rec of_nat = function
+  | O -> XH
+  | S x ->
+    (match x with
+     | O -> XH
+     | S n1 -> succ (of_nat x))
+  
+  (** val of_succ_nat : nat -> positive **)
+  
+  let rec of_succ_nat = function
+  | O -> XH
+  | S x -> succ (of_succ_nat x)
+  
+  (** val eq_dec : positive -> positive -> bool **)
+  
+  let rec eq_dec p y0 =
+    match p with
+    | XI p2 ->
+      (match y0 with
+       | XI p3 -> eq_dec p2 p3
+       | _ -> false)
+    | XO p2 ->
+      (match y0 with
+       | XO p3 -> eq_dec p2 p3
+       | _ -> false)
+    | XH ->
+      (match y0 with
+       | XH -> true
+       | _ -> false)
+  
+  (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
+  
+  let rec peano_rect a f p =
+    let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x))
+    in
+    (match p with
+     | XI q0 -> f (XO q0) (f2 q0)
+     | XO q0 -> f2 q0
+     | XH -> a)
+  
+  (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
+  
+  let peano_rec =
+    peano_rect
+  
+  type coq_PeanoView =
+  | PeanoOne
+  | PeanoSucc of positive * coq_PeanoView
+  
+  (** val coq_PeanoView_rect :
+      'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
+      coq_PeanoView -> 'a1 **)
+  
+  let rec coq_PeanoView_rect f f0 p = function
+  | PeanoOne -> f
+  | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4)
+  
+  (** val coq_PeanoView_rec :
+      'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
+      coq_PeanoView -> 'a1 **)
+  
+  let rec coq_PeanoView_rec f f0 p = function
+  | PeanoOne -> f
+  | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4)
+  
+  (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **)
+  
+  let rec peanoView_xO p = function
+  | PeanoOne -> PeanoSucc (XH, PeanoOne)
+  | PeanoSucc (p2, q1) ->
+    PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1))))
+  
+  (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **)
+  
+  let rec peanoView_xI p = function
+  | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne)))
+  | PeanoSucc (p2, q1) ->
+    PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1))))
+  
+  (** val peanoView : positive -> coq_PeanoView **)
+  
+  let rec peanoView = function
+  | XI p2 -> peanoView_xI p2 (peanoView p2)
+  | XO p2 -> peanoView_xO p2 (peanoView p2)
+  | XH -> PeanoOne
+  
+  (** val coq_PeanoView_iter :
+      'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **)
+  
+  let rec coq_PeanoView_iter a f p = function
+  | PeanoOne -> a
+  | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1)
+  
+  (** val switch_Eq : comparison -> comparison -> comparison **)
+  
+  let switch_Eq c = function
+  | Eq -> c
+  | x -> x
+  
+  (** val mask2cmp : mask -> comparison **)
+  
+  let mask2cmp = function
+  | IsNul -> Eq
+  | IsPos p2 -> Gt
+  | IsNeg -> Lt
+  
+  module T = 
+   struct 
+    
+   end
+  
+  module ORev = 
+   struct 
+    type t = Coq__1.t
+   end
+  
+  module MRev = 
+   struct 
+    (** val max : t -> t -> t **)
+    
+    let max x y =
+      min y x
+   end
+  
+  module MPRev = MaxLogicalProperties(ORev)(MRev)
+  
+  module P = 
+   struct 
+    (** val max_case_strong :
+        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let max_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat n0 (max n0 m) __ (hl __)
+       | _ -> compat m (max n0 m) __ (hr __))
+    
+    (** val max_case :
+        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let max_case n0 m x x0 x1 =
+      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val max_dec : t -> t -> bool **)
+    
+    let max_dec n0 m =
+      max_case n0 m (fun x y _ h0 -> h0) true false
+    
+    (** val min_case_strong :
+        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let min_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat m (min n0 m) __ (hr __)
+       | _ -> compat n0 (min n0 m) __ (hl __))
+    
+    (** val min_case :
+        t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let min_case n0 m x x0 x1 =
+      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val min_dec : t -> t -> bool **)
+    
+    let min_dec n0 m =
+      min_case n0 m (fun x y _ h0 -> h0) true false
+   end
+  
+  (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let max_case_strong n0 m x x0 =
+    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let max_case n0 m x x0 =
+    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val max_dec : t -> t -> bool **)
+  
+  let max_dec =
+    P.max_dec
+  
+  (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let min_case_strong n0 m x x0 =
+    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let min_case n0 m x x0 =
+    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val min_dec : t -> t -> bool **)
+  
+  let min_dec =
+    P.min_dec
+ end
+
+module N = 
+ struct 
+  type t = n
+  
+  (** val zero : n **)
+  
+  let zero =
+    N0
+  
+  (** val one : n **)
+  
+  let one =
+    Npos XH
+  
+  (** val two : n **)
+  
+  let two =
+    Npos (XO XH)
+  
+  (** val succ_double : n -> n **)
+  
+  let succ_double = function
+  | N0 -> Npos XH
+  | Npos p -> Npos (XI p)
+  
+  (** val double : n -> n **)
+  
+  let double = function
+  | N0 -> N0
+  | Npos p -> Npos (XO p)
+  
+  (** val succ : n -> n **)
+  
+  let succ = function
+  | N0 -> Npos XH
+  | Npos p -> Npos (Coq_Pos.succ p)
+  
+  (** val pred : n -> n **)
+  
+  let pred = function
+  | N0 -> N0
+  | Npos p -> Coq_Pos.pred_N p
+  
+  (** val succ_pos : n -> positive **)
+  
+  let succ_pos = function
+  | N0 -> XH
+  | Npos p -> Coq_Pos.succ p
+  
+  (** val add : n -> n -> n **)
+  
+  let add n0 m =
+    match n0 with
+    | N0 -> m
+    | Npos p ->
+      (match m with
+       | N0 -> n0
+       | Npos q0 -> Npos (Coq_Pos.add p q0))
+  
+  (** val sub : n -> n -> n **)
+  
+  let sub n0 m =
+    match n0 with
+    | N0 -> N0
+    | Npos n' ->
+      (match m with
+       | N0 -> n0
+       | Npos m' ->
+         (match Coq_Pos.sub_mask n' m' with
+          | Coq_Pos.IsPos p -> Npos p
+          | _ -> N0))
+  
+  (** val mul : n -> n -> n **)
+  
+  let mul n0 m =
+    match n0 with
+    | N0 -> N0
+    | Npos p ->
+      (match m with
+       | N0 -> N0
+       | Npos q0 -> Npos (Coq_Pos.mul p q0))
+  
+  (** val compare : n -> n -> comparison **)
+  
+  let compare n0 m =
+    match n0 with
+    | N0 ->
+      (match m with
+       | N0 -> Eq
+       | Npos m' -> Lt)
+    | Npos n' ->
+      (match m with
+       | N0 -> Gt
+       | Npos m' -> Coq_Pos.compare n' m')
+  
+  (** val eqb : n -> n -> bool **)
+  
+  let rec eqb n0 m =
+    match n0 with
+    | N0 ->
+      (match m with
+       | N0 -> true
+       | Npos p -> false)
+    | Npos p ->
+      (match m with
+       | N0 -> false
+       | Npos q0 -> Coq_Pos.eqb p q0)
+  
+  (** val leb : n -> n -> bool **)
+  
+  let leb x y =
+    match compare x y with
+    | Gt -> false
+    | _ -> true
+  
+  (** val ltb : n -> n -> bool **)
+  
+  let ltb x y =
+    match compare x y with
+    | Lt -> true
+    | _ -> false
+  
+  (** val min : n -> n -> n **)
+  
+  let min n0 n' =
+    match compare n0 n' with
+    | Gt -> n'
+    | _ -> n0
+  
+  (** val max : n -> n -> n **)
+  
+  let max n0 n' =
+    match compare n0 n' with
+    | Gt -> n0
+    | _ -> n'
+  
+  (** val div2 : n -> n **)
+  
+  let div2 = function
+  | N0 -> N0
+  | Npos p2 ->
+    (match p2 with
+     | XI p -> Npos p
+     | XO p -> Npos p
+     | XH -> N0)
+  
+  (** val even : n -> bool **)
+  
+  let even = function
+  | N0 -> true
+  | Npos p ->
+    (match p with
+     | XO p2 -> true
+     | _ -> false)
+  
+  (** val odd : n -> bool **)
+  
+  let odd n0 =
+    negb (even n0)
+  
+  (** val pow : n -> n -> n **)
+  
+  let pow n0 = function
+  | N0 -> Npos XH
+  | Npos p2 ->
+    (match n0 with
+     | N0 -> N0
+     | Npos q0 -> Npos (Coq_Pos.pow q0 p2))
+  
+  (** val log2 : n -> n **)
+  
+  let log2 = function
+  | N0 -> N0
+  | Npos p2 ->
+    (match p2 with
+     | XI p -> Npos (Coq_Pos.size p)
+     | XO p -> Npos (Coq_Pos.size p)
+     | XH -> N0)
+  
+  (** val size : n -> n **)
+  
+  let size = function
+  | N0 -> N0
+  | Npos p -> Npos (Coq_Pos.size p)
+  
+  (** val size_nat : n -> nat **)
+  
+  let size_nat = function
+  | N0 -> O
+  | Npos p -> Coq_Pos.size_nat p
+  
+  (** val pos_div_eucl : positive -> n -> n * n **)
+  
+  let rec pos_div_eucl a b =
+    match a with
+    | XI a' ->
+      let q0,r = pos_div_eucl a' b in
+      let r' = succ_double r in
+      if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
+    | XO a' ->
+      let q0,r = pos_div_eucl a' b in
+      let r' = double r in
+      if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
+    | XH ->
+      (match b with
+       | N0 -> N0,(Npos XH)
+       | Npos p ->
+         (match p with
+          | XH -> (Npos XH),N0
+          | _ -> N0,(Npos XH)))
+  
+  (** val div_eucl : n -> n -> n * n **)
+  
+  let div_eucl a b =
+    match a with
+    | N0 -> N0,N0
+    | Npos na ->
+      (match b with
+       | N0 -> N0,a
+       | Npos p -> pos_div_eucl na b)
+  
+  (** val div : n -> n -> n **)
+  
+  let div a b =
+    fst (div_eucl a b)
+  
+  (** val modulo : n -> n -> n **)
+  
+  let modulo a b =
+    snd (div_eucl a b)
+  
+  (** val gcd : n -> n -> n **)
+  
+  let gcd a b =
+    match a with
+    | N0 -> b
+    | Npos p ->
+      (match b with
+       | N0 -> a
+       | Npos q0 -> Npos (Coq_Pos.gcd p q0))
+  
+  (** val ggcd : n -> n -> n * (n * n) **)
+  
+  let ggcd a b =
+    match a with
+    | N0 -> b,(N0,(Npos XH))
+    | Npos p ->
+      (match b with
+       | N0 -> a,((Npos XH),N0)
+       | Npos q0 ->
+         let g,p2 = Coq_Pos.ggcd p q0 in
+         let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb)))
+  
+  (** val sqrtrem : n -> n * n **)
+  
+  let sqrtrem = function
+  | N0 -> N0,N0
+  | Npos p ->
+    let s,m = Coq_Pos.sqrtrem p in
+    (match m with
+     | Coq_Pos.IsPos r -> (Npos s),(Npos r)
+     | _ -> (Npos s),N0)
+  
+  (** val sqrt : n -> n **)
+  
+  let sqrt = function
+  | N0 -> N0
+  | Npos p -> Npos (Coq_Pos.sqrt p)
+  
+  (** val coq_lor : n -> n -> n **)
+  
+  let coq_lor n0 m =
+    match n0 with
+    | N0 -> m
+    | Npos p ->
+      (match m with
+       | N0 -> n0
+       | Npos q0 -> Npos (Coq_Pos.coq_lor p q0))
+  
+  (** val coq_land : n -> n -> n **)
+  
+  let coq_land n0 m =
+    match n0 with
+    | N0 -> N0
+    | Npos p ->
+      (match m with
+       | N0 -> N0
+       | Npos q0 -> Coq_Pos.coq_land p q0)
+  
+  (** val ldiff : n -> n -> n **)
+  
+  let rec ldiff n0 m =
+    match n0 with
+    | N0 -> N0
+    | Npos p ->
+      (match m with
+       | N0 -> n0
+       | Npos q0 -> Coq_Pos.ldiff p q0)
+  
+  (** val coq_lxor : n -> n -> n **)
+  
+  let coq_lxor n0 m =
+    match n0 with
+    | N0 -> m
+    | Npos p ->
+      (match m with
+       | N0 -> n0
+       | Npos q0 -> Coq_Pos.coq_lxor p q0)
+  
+  (** val shiftl_nat : n -> nat -> n **)
+  
+  let shiftl_nat a n0 =
+    nat_iter n0 double a
+  
+  (** val shiftr_nat : n -> nat -> n **)
+  
+  let shiftr_nat a n0 =
+    nat_iter n0 div2 a
+  
+  (** val shiftl : n -> n -> n **)
+  
+  let shiftl a n0 =
+    match a with
+    | N0 -> N0
+    | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0)
+  
+  (** val shiftr : n -> n -> n **)
+  
+  let shiftr a = function
+  | N0 -> a
+  | Npos p -> Coq_Pos.iter p div2 a
+  
+  (** val testbit_nat : n -> nat -> bool **)
+  
+  let testbit_nat = function
+  | N0 -> (fun x -> false)
+  | Npos p -> Coq_Pos.testbit_nat p
+  
+  (** val testbit : n -> n -> bool **)
+  
+  let testbit a n0 =
+    match a with
+    | N0 -> false
+    | Npos p -> Coq_Pos.testbit p n0
+  
+  (** val to_nat : n -> nat **)
+  
+  let to_nat = function
+  | N0 -> O
+  | Npos p -> Coq_Pos.to_nat p
+  
+  (** val of_nat : nat -> n **)
+  
+  let of_nat = function
+  | O -> N0
+  | S n' -> Npos (Coq_Pos.of_succ_nat n')
+  
+  (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+  
+  let iter n0 f x =
+    match n0 with
+    | N0 -> x
+    | Npos p -> Coq_Pos.iter p f x
+  
+  (** val eq_dec : n -> n -> bool **)
+  
+  let eq_dec n0 m =
+    match n0 with
+    | N0 ->
+      (match m with
+       | N0 -> true
+       | Npos p -> false)
+    | Npos x ->
+      (match m with
+       | N0 -> false
+       | Npos p2 -> Coq_Pos.eq_dec x p2)
+  
+  (** val discr : n -> positive option **)
+  
+  let discr = function
+  | N0 -> None
+  | Npos p -> Some p
+  
+  (** val binary_rect :
+      'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
+  
+  let binary_rect f0 f2 fS2 n0 =
+    let f2' = fun p -> f2 (Npos p) in
+    let fS2' = fun p -> fS2 (Npos p) in
+    (match n0 with
+     | N0 -> f0
+     | Npos p ->
+       let rec f = function
+       | XI p3 -> fS2' p3 (f p3)
+       | XO p3 -> f2' p3 (f p3)
+       | XH -> fS2 N0 f0
+       in f p)
+  
+  (** val binary_rec :
+      'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
+  
+  let binary_rec =
+    binary_rect
+  
+  (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
+  
+  let peano_rect f0 f n0 =
+    let f' = fun p -> f (Npos p) in
+    (match n0 with
+     | N0 -> f0
+     | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p)
+  
+  (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
+  
+  let peano_rec =
+    peano_rect
+  
+  module BootStrap = 
+   struct 
+    
+   end
+  
+  (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
+  
+  let recursion x =
+    peano_rect x
+  
+  module OrderElts = 
+   struct 
+    type t = n
+   end
+  
+  module OrderTac = MakeOrderTac(OrderElts)
+  
+  module NZPowP = 
+   struct 
+    
+   end
+  
+  module NZSqrtP = 
+   struct 
+    
+   end
+  
+  (** val sqrt_up : n -> n **)
+  
+  let sqrt_up a =
+    match compare N0 a with
+    | Lt -> succ (sqrt (pred a))
+    | _ -> N0
+  
+  (** val log2_up : n -> n **)
+  
+  let log2_up a =
+    match compare (Npos XH) a with
+    | Lt -> succ (log2 (pred a))
+    | _ -> N0
+  
+  module NZDivP = 
+   struct 
+    
+   end
+  
+  (** val lcm : n -> n -> n **)
+  
+  let lcm a b =
+    mul a (div b (gcd a b))
+  
+  (** val b2n : bool -> n **)
+  
+  let b2n = function
+  | true -> Npos XH
+  | false -> N0
+  
+  (** val setbit : n -> n -> n **)
+  
+  let setbit a n0 =
+    coq_lor a (shiftl (Npos XH) n0)
+  
+  (** val clearbit : n -> n -> n **)
+  
+  let clearbit a n0 =
+    ldiff a (shiftl (Npos XH) n0)
+  
+  (** val ones : n -> n **)
+  
+  let ones n0 =
+    pred (shiftl (Npos XH) n0)
+  
+  (** val lnot : n -> n -> n **)
+  
+  let lnot a n0 =
+    coq_lxor a (ones n0)
+  
+  module T = 
+   struct 
+    
+   end
+  
+  module ORev = 
+   struct 
+    type t = n
+   end
+  
+  module MRev = 
+   struct 
+    (** val max : n -> n -> n **)
+    
+    let max x y =
+      min y x
+   end
+  
+  module MPRev = MaxLogicalProperties(ORev)(MRev)
+  
+  module P = 
+   struct 
+    (** val max_case_strong :
+        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let max_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat n0 (max n0 m) __ (hl __)
+       | _ -> compat m (max n0 m) __ (hr __))
+    
+    (** val max_case :
+        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let max_case n0 m x x0 x1 =
+      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val max_dec : n -> n -> bool **)
+    
+    let max_dec n0 m =
+      max_case n0 m (fun x y _ h0 -> h0) true false
+    
+    (** val min_case_strong :
+        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let min_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat m (min n0 m) __ (hr __)
+       | _ -> compat n0 (min n0 m) __ (hl __))
+    
+    (** val min_case :
+        n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let min_case n0 m x x0 x1 =
+      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val min_dec : n -> n -> bool **)
+    
+    let min_dec n0 m =
+      min_case n0 m (fun x y _ h0 -> h0) true false
+   end
+  
+  (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let max_case_strong n0 m x x0 =
+    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let max_case n0 m x x0 =
+    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val max_dec : n -> n -> bool **)
+  
+  let max_dec =
+    P.max_dec
+  
+  (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let min_case_strong n0 m x x0 =
+    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let min_case n0 m x x0 =
+    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val min_dec : n -> n -> bool **)
+  
+  let min_dec =
+    P.min_dec
+ end
 
 (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **)
 
 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
+| 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
-  | Zneg of positive
-
-(** val zdouble_plus_one : z -> z **)
-
-let zdouble_plus_one = function
-  | Z0 -> Zpos XH
-  | Zpos p -> Zpos (XI p)
-  | Zneg p -> Zneg (pdouble_minus_one p)
-
-(** val zdouble_minus_one : z -> z **)
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
 
-let zdouble_minus_one = function
-  | Z0 -> Zneg XH
-  | Zpos p -> Zpos (pdouble_minus_one p)
-  | Zneg p -> Zneg (XI p)
+let rec nth n0 l default =
+  match n0 with
+  | O ->
+    (match l with
+     | [] -> default
+     | x::l' -> x)
+  | S m ->
+    (match l with
+     | [] -> default
+     | x::t1 -> nth m t1 default)
 
-(** val zdouble : z -> z **)
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
 
-let zdouble = function
+let rec map f = function
+| [] -> []
+| a::t1 -> (f a)::(map f t1)
+
+(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **)
+
+let rec fold_right f a0 = function
+| [] -> a0
+| b::t1 -> f b (fold_right f a0 t1)
+
+module Z = 
+ struct 
+  type t = z
+  
+  (** val zero : z **)
+  
+  let zero =
+    Z0
+  
+  (** val one : z **)
+  
+  let one =
+    Zpos XH
+  
+  (** val two : z **)
+  
+  let two =
+    Zpos (XO XH)
+  
+  (** val double : z -> z **)
+  
+  let double = function
   | Z0 -> Z0
   | Zpos p -> Zpos (XO p)
   | Zneg p -> Zneg (XO p)
-
-(** val zPminus : positive -> positive -> z **)
-
-let rec zPminus x y =
-  match x with
+  
+  (** val succ_double : z -> z **)
+  
+  let succ_double = function
+  | Z0 -> Zpos XH
+  | Zpos p -> Zpos (XI p)
+  | Zneg p -> Zneg (Coq_Pos.pred_double p)
+  
+  (** val pred_double : z -> z **)
+  
+  let pred_double = function
+  | Z0 -> Zneg XH
+  | Zpos p -> Zpos (Coq_Pos.pred_double p)
+  | Zneg p -> Zneg (XI p)
+  
+  (** val pos_sub : positive -> positive -> z **)
+  
+  let rec pos_sub x y =
+    match x with
     | XI p ->
-        (match y with
-           | XI q0 -> zdouble (zPminus p q0)
-           | XO q0 -> zdouble_plus_one (zPminus p q0)
-           | XH -> Zpos (XO p))
+      (match y with
+       | XI q0 -> double (pos_sub p q0)
+       | XO q0 -> succ_double (pos_sub p q0)
+       | XH -> Zpos (XO p))
     | XO p ->
-        (match y with
-           | XI q0 -> zdouble_minus_one (zPminus p q0)
-           | XO q0 -> zdouble (zPminus p q0)
-           | XH -> Zpos (pdouble_minus_one p))
+      (match y with
+       | XI q0 -> pred_double (pos_sub p q0)
+       | XO q0 -> double (pos_sub p q0)
+       | XH -> Zpos (Coq_Pos.pred_double p))
     | XH ->
-        (match y with
-           | XI q0 -> Zneg (XO q0)
-           | XO q0 -> Zneg (pdouble_minus_one q0)
-           | XH -> Z0)
-
-(** val zplus : z -> z -> z **)
-
-let zplus x y =
-  match x with
+      (match y with
+       | XI q0 -> Zneg (XO q0)
+       | XO q0 -> Zneg (Coq_Pos.pred_double q0)
+       | XH -> Z0)
+  
+  (** val add : z -> z -> z **)
+  
+  let add x y =
+    match x with
     | Z0 -> y
     | Zpos x' ->
-        (match y with
-           | Z0 -> Zpos x'
-           | Zpos y' -> Zpos (pplus x' y')
-           | Zneg y' ->
-               (match pcompare x' y' Eq with
-                  | Eq -> Z0
-                  | Lt -> Zneg (pminus y' x')
-                  | Gt -> Zpos (pminus x' y')))
+      (match y with
+       | Z0 -> x
+       | Zpos y' -> Zpos (Coq_Pos.add x' y')
+       | Zneg y' -> pos_sub x' y')
     | Zneg x' ->
-        (match y with
-           | Z0 -> Zneg x'
-           | Zpos y' ->
-               (match pcompare x' y' Eq with
-                  | Eq -> Z0
-                  | Lt -> Zpos (pminus y' x')
-                  | Gt -> Zneg (pminus x' y'))
-           | Zneg y' -> Zneg (pplus x' y'))
-
-(** val zopp : z -> z **)
-
-let zopp = function
+      (match y with
+       | Z0 -> x
+       | Zpos y' -> pos_sub y' x'
+       | Zneg y' -> Zneg (Coq_Pos.add x' y'))
+  
+  (** val opp : z -> z **)
+  
+  let opp = function
   | Z0 -> Z0
   | Zpos x0 -> Zneg x0
   | Zneg x0 -> Zpos x0
-
-(** val zminus : z -> z -> z **)
-
-let zminus m n0 =
-  zplus m (zopp n0)
-
-(** val zmult : z -> z -> z **)
-
-let zmult x y =
-  match x with
+  
+  (** val succ : z -> z **)
+  
+  let succ x =
+    add x (Zpos XH)
+  
+  (** val pred : z -> z **)
+  
+  let pred x =
+    add x (Zneg XH)
+  
+  (** val sub : z -> z -> z **)
+  
+  let sub m n0 =
+    add m (opp n0)
+  
+  (** val mul : z -> z -> z **)
+  
+  let mul x y =
+    match x with
     | Z0 -> Z0
     | Zpos x' ->
-        (match y with
-           | Z0 -> Z0
-           | Zpos y' -> Zpos (pmult x' y')
-           | Zneg y' -> Zneg (pmult x' y'))
+      (match y with
+       | Z0 -> Z0
+       | Zpos y' -> Zpos (Coq_Pos.mul x' y')
+       | Zneg y' -> Zneg (Coq_Pos.mul x' y'))
     | Zneg x' ->
-        (match y with
-           | Z0 -> Z0
-           | Zpos y' -> Zneg (pmult x' y')
-           | Zneg y' -> Zpos (pmult x' y'))
-
-(** val zcompare : z -> z -> comparison **)
-
-let zcompare x y =
-  match x with
-    | Z0 -> (match y with
-               | Z0 -> Eq
-               | Zpos y' -> Lt
-               | Zneg y' -> Gt)
-    | Zpos x' -> (match y with
-                    | Zpos y' -> pcompare x' y' Eq
-                    | _ -> Gt)
+      (match y with
+       | Z0 -> Z0
+       | Zpos y' -> Zneg (Coq_Pos.mul x' y')
+       | Zneg y' -> Zpos (Coq_Pos.mul x' y'))
+  
+  (** val pow_pos : z -> positive -> z **)
+  
+  let pow_pos z0 n0 =
+    Coq_Pos.iter n0 (mul z0) (Zpos XH)
+  
+  (** val pow : z -> z -> z **)
+  
+  let pow x = function
+  | Z0 -> Zpos XH
+  | Zpos p -> pow_pos x p
+  | Zneg p -> Z0
+  
+  (** val compare : z -> z -> comparison **)
+  
+  let compare x y =
+    match x with
+    | Z0 ->
+      (match y with
+       | Z0 -> Eq
+       | Zpos y' -> Lt
+       | Zneg y' -> Gt)
+    | Zpos x' ->
+      (match y with
+       | Zpos y' -> Coq_Pos.compare x' y'
+       | _ -> Gt)
     | Zneg x' ->
-        (match y with
-           | Zneg y' -> compOpp (pcompare x' y' Eq)
-           | _ -> Lt)
-
-(** val zabs : z -> z **)
-
-let zabs = function
+      (match y with
+       | Zneg y' -> compOpp (Coq_Pos.compare x' y')
+       | _ -> Lt)
+  
+  (** val sgn : z -> z **)
+  
+  let sgn = function
   | Z0 -> Z0
-  | Zpos p -> Zpos p
-  | Zneg p -> Zpos p
-
-(** val zmax : z -> z -> z **)
-
-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
+  | Zpos p -> Zpos XH
+  | Zneg p -> Zneg XH
+  
+  (** val leb : z -> z -> bool **)
+  
+  let leb x y =
+    match compare x y with
     | Gt -> false
     | _ -> true
-
-(** val zge_bool : z -> z -> bool **)
-
-let zge_bool x y =
-  match zcompare x y with
+  
+  (** val geb : z -> z -> bool **)
+  
+  let geb x y =
+    match compare x y with
     | Lt -> false
     | _ -> true
-
-(** val zgt_bool : z -> z -> bool **)
-
-let zgt_bool x y =
-  match zcompare x y with
-    | Gt -> true
+  
+  (** val ltb : z -> z -> bool **)
+  
+  let ltb x y =
+    match compare x y with
+    | Lt -> true
     | _ -> false
-
-(** val zeq_bool : z -> z -> bool **)
-
-let zeq_bool x y =
-  match zcompare x y with
-    | Eq -> true
+  
+  (** val gtb : z -> z -> bool **)
+  
+  let gtb x y =
+    match compare x y with
+    | Gt -> true
     | _ -> false
-
-(** val n_of_nat : nat -> n **)
-
-let n_of_nat = function
-  | O -> N0
-  | S n' -> Npos (p_of_succ_nat n')
-
-(** val zdiv_eucl_POS : positive -> z -> z  *  z **)
-
-let rec zdiv_eucl_POS a b =
-  match a with
+  
+  (** val eqb : z -> z -> bool **)
+  
+  let rec eqb x y =
+    match x with
+    | Z0 ->
+      (match y with
+       | Z0 -> true
+       | _ -> false)
+    | Zpos p ->
+      (match y with
+       | Zpos q0 -> Coq_Pos.eqb p q0
+       | _ -> false)
+    | Zneg p ->
+      (match y with
+       | Zneg q0 -> Coq_Pos.eqb p q0
+       | _ -> false)
+  
+  (** val max : z -> z -> z **)
+  
+  let max n0 m =
+    match compare n0 m with
+    | Lt -> m
+    | _ -> n0
+  
+  (** val min : z -> z -> z **)
+  
+  let min n0 m =
+    match compare n0 m with
+    | Gt -> m
+    | _ -> n0
+  
+  (** val abs : z -> z **)
+  
+  let abs = function
+  | Zneg p -> Zpos p
+  | x -> x
+  
+  (** val abs_nat : z -> nat **)
+  
+  let abs_nat = function
+  | Z0 -> O
+  | Zpos p -> Coq_Pos.to_nat p
+  | Zneg p -> Coq_Pos.to_nat p
+  
+  (** val abs_N : z -> n **)
+  
+  let abs_N = function
+  | Z0 -> N0
+  | Zpos p -> Npos p
+  | Zneg p -> Npos p
+  
+  (** val to_nat : z -> nat **)
+  
+  let to_nat = function
+  | Zpos p -> Coq_Pos.to_nat p
+  | _ -> O
+  
+  (** val to_N : z -> n **)
+  
+  let to_N = function
+  | Zpos p -> Npos p
+  | _ -> N0
+  
+  (** val of_nat : nat -> z **)
+  
+  let of_nat = function
+  | O -> Z0
+  | S n1 -> Zpos (Coq_Pos.of_succ_nat n1)
+  
+  (** val of_N : n -> z **)
+  
+  let of_N = function
+  | N0 -> Z0
+  | Npos p -> Zpos p
+  
+  (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+  
+  let iter n0 f x =
+    match n0 with
+    | Zpos p -> Coq_Pos.iter p f x
+    | _ -> x
+  
+  (** val pos_div_eucl : positive -> z -> z * z **)
+  
+  let rec pos_div_eucl a b =
+    match a with
     | XI a' ->
-        let q0 , r = zdiv_eucl_POS a' b in
-        let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
-        if zgt_bool b r'
-        then (zmult (Zpos (XO XH)) q0) , r'
-        else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b)
+      let q0,r = pos_div_eucl a' b in
+      let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in
+      if gtb b r'
+      then (mul (Zpos (XO XH)) q0),r'
+      else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
     | XO a' ->
-        let q0 , r = zdiv_eucl_POS a' b in
-        let r' = zmult (Zpos (XO XH)) r in
-        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 ->
-        if zge_bool b (Zpos (XO XH)) then Z0 , (Zpos XH) else (Zpos XH) , Z0
-
-(** val zdiv_eucl : z -> z -> z  *  z **)
-
-let zdiv_eucl a b =
-  match a with
-    | Z0 -> Z0 , Z0
+      let q0,r = pos_div_eucl a' b in
+      let r' = mul (Zpos (XO XH)) r in
+      if gtb b r'
+      then (mul (Zpos (XO XH)) q0),r'
+      else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
+    | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0
+  
+  (** val div_eucl : z -> z -> z * z **)
+  
+  let div_eucl a b =
+    match a with
+    | Z0 -> Z0,Z0
     | Zpos a' ->
-        (match b with
-           | Z0 -> Z0 , Z0
-           | Zpos p -> zdiv_eucl_POS a' b
-           | Zneg b' ->
-               let q0 , r = zdiv_eucl_POS a' (Zpos b') in
-               (match r with
-                  | Z0 -> (zopp q0) , Z0
-                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zplus b r)))
+      (match b with
+       | Z0 -> Z0,Z0
+       | Zpos p -> pos_div_eucl a' b
+       | Zneg b' ->
+         let q0,r = pos_div_eucl a' (Zpos b') in
+         (match r with
+          | Z0 -> (opp q0),Z0
+          | _ -> (opp (add q0 (Zpos XH))),(add b r)))
     | Zneg a' ->
-        (match b with
-           | Z0 -> Z0 , Z0
-           | Zpos p ->
-               let q0 , r = zdiv_eucl_POS a' b in
-               (match r with
-                  | Z0 -> (zopp q0) , Z0
-                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zminus b r))
-           | Zneg b' ->
-               let q0 , r = zdiv_eucl_POS a' (Zpos b') in q0 , (zopp r))
+      (match b with
+       | Z0 -> Z0,Z0
+       | Zpos p ->
+         let q0,r = pos_div_eucl a' b in
+         (match r with
+          | Z0 -> (opp q0),Z0
+          | _ -> (opp (add q0 (Zpos XH))),(sub b r))
+       | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r))
+  
+  (** val div : z -> z -> z **)
+  
+  let div a b =
+    let q0,x = div_eucl a b in q0
+  
+  (** val modulo : z -> z -> z **)
+  
+  let modulo a b =
+    let x,r = div_eucl a b in r
+  
+  (** val quotrem : z -> z -> z * z **)
+  
+  let quotrem a b =
+    match a with
+    | Z0 -> Z0,Z0
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> Z0,a
+       | Zpos b0 ->
+         let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r)
+       | Zneg b0 ->
+         let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> Z0,a
+       | Zpos b0 ->
+         let q0,r = N.pos_div_eucl a0 (Npos b0) in
+         (opp (of_N q0)),(opp (of_N r))
+       | Zneg b0 ->
+         let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r)))
+  
+  (** val quot : z -> z -> z **)
+  
+  let quot a b =
+    fst (quotrem a b)
+  
+  (** val rem : z -> z -> z **)
+  
+  let rem a b =
+    snd (quotrem a b)
+  
+  (** val even : z -> bool **)
+  
+  let even = function
+  | Z0 -> true
+  | Zpos p ->
+    (match p with
+     | XO p2 -> true
+     | _ -> false)
+  | Zneg p ->
+    (match p with
+     | XO p2 -> true
+     | _ -> false)
+  
+  (** val odd : z -> bool **)
+  
+  let odd = function
+  | Z0 -> false
+  | Zpos p ->
+    (match p with
+     | XO p2 -> false
+     | _ -> true)
+  | Zneg p ->
+    (match p with
+     | XO p2 -> false
+     | _ -> true)
+  
+  (** val div2 : z -> z **)
+  
+  let div2 = function
+  | Z0 -> Z0
+  | Zpos p ->
+    (match p with
+     | XH -> Z0
+     | _ -> Zpos (Coq_Pos.div2 p))
+  | Zneg p -> Zneg (Coq_Pos.div2_up p)
+  
+  (** val quot2 : z -> z **)
+  
+  let quot2 = function
+  | Z0 -> Z0
+  | Zpos p ->
+    (match p with
+     | XH -> Z0
+     | _ -> Zpos (Coq_Pos.div2 p))
+  | Zneg p ->
+    (match p with
+     | XH -> Z0
+     | _ -> Zneg (Coq_Pos.div2 p))
+  
+  (** val log2 : z -> z **)
+  
+  let log2 = function
+  | Zpos p2 ->
+    (match p2 with
+     | XI p -> Zpos (Coq_Pos.size p)
+     | XO p -> Zpos (Coq_Pos.size p)
+     | XH -> Z0)
+  | _ -> Z0
+  
+  (** val sqrtrem : z -> z * z **)
+  
+  let sqrtrem = function
+  | Zpos p ->
+    let s,m = Coq_Pos.sqrtrem p in
+    (match m with
+     | Coq_Pos.IsPos r -> (Zpos s),(Zpos r)
+     | _ -> (Zpos s),Z0)
+  | _ -> Z0,Z0
+  
+  (** val sqrt : z -> z **)
+  
+  let sqrt = function
+  | Zpos p -> Zpos (Coq_Pos.sqrt p)
+  | _ -> Z0
+  
+  (** val gcd : z -> z -> z **)
+  
+  let gcd a b =
+    match a with
+    | Z0 -> abs b
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> abs a
+       | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0)
+       | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> abs a
+       | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0)
+       | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0))
+  
+  (** val ggcd : z -> z -> z * (z * z) **)
+  
+  let ggcd a b =
+    match a with
+    | Z0 -> (abs b),(Z0,(sgn b))
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> (abs a),((sgn a),Z0)
+       | Zpos b0 ->
+         let g,p = Coq_Pos.ggcd a0 b0 in
+         let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb))
+       | Zneg b0 ->
+         let g,p = Coq_Pos.ggcd a0 b0 in
+         let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb)))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> (abs a),((sgn a),Z0)
+       | Zpos b0 ->
+         let g,p = Coq_Pos.ggcd a0 b0 in
+         let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb))
+       | Zneg b0 ->
+         let g,p = Coq_Pos.ggcd a0 b0 in
+         let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb)))
+  
+  (** val testbit : z -> z -> bool **)
+  
+  let testbit a = function
+  | Z0 -> odd a
+  | Zpos p ->
+    (match a with
+     | Z0 -> false
+     | Zpos a0 -> Coq_Pos.testbit a0 (Npos p)
+     | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p)))
+  | Zneg p -> false
+  
+  (** val shiftl : z -> z -> z **)
+  
+  let shiftl a = function
+  | Z0 -> a
+  | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a
+  | Zneg p -> Coq_Pos.iter p div2 a
+  
+  (** val shiftr : z -> z -> z **)
+  
+  let shiftr a n0 =
+    shiftl a (opp n0)
+  
+  (** val coq_lor : z -> z -> z **)
+  
+  let coq_lor a b =
+    match a with
+    | Z0 -> b
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0)
+       | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0))))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0)))
+       | Zneg b0 ->
+         Zneg
+           (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
+  
+  (** val coq_land : z -> z -> z **)
+  
+  let coq_land a b =
+    match a with
+    | Z0 -> Z0
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> Z0
+       | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0)
+       | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0)))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> Z0
+       | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0))
+       | Zneg b0 ->
+         Zneg
+           (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
+  
+  (** val ldiff : z -> z -> z **)
+  
+  let ldiff a b =
+    match a with
+    | Z0 -> Z0
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0)
+       | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0)))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 ->
+         Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0)))
+       | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0)))
+  
+  (** val coq_lxor : z -> z -> z **)
+  
+  let coq_lxor a b =
+    match a with
+    | Z0 -> b
+    | Zpos a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0)
+       | Zneg b0 ->
+         Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0))))
+    | Zneg a0 ->
+      (match b with
+       | Z0 -> a
+       | Zpos b0 ->
+         Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0)))
+       | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))
+  
+  (** val eq_dec : z -> z -> bool **)
+  
+  let eq_dec x y =
+    match x with
+    | Z0 ->
+      (match y with
+       | Z0 -> true
+       | _ -> false)
+    | Zpos x0 ->
+      (match y with
+       | Zpos p2 -> Coq_Pos.eq_dec x0 p2
+       | _ -> false)
+    | Zneg x0 ->
+      (match y with
+       | Zneg p2 -> Coq_Pos.eq_dec x0 p2
+       | _ -> false)
+  
+  module BootStrap = 
+   struct 
+    
+   end
+  
+  module OrderElts = 
+   struct 
+    type t = z
+   end
+  
+  module OrderTac = MakeOrderTac(OrderElts)
+  
+  (** val sqrt_up : z -> z **)
+  
+  let sqrt_up a =
+    match compare Z0 a with
+    | Lt -> succ (sqrt (pred a))
+    | _ -> Z0
+  
+  (** val log2_up : z -> z **)
+  
+  let log2_up a =
+    match compare (Zpos XH) a with
+    | Lt -> succ (log2 (pred a))
+    | _ -> Z0
+  
+  module NZDivP = 
+   struct 
+    
+   end
+  
+  module Quot2Div = 
+   struct 
+    (** val div : z -> z -> z **)
+    
+    let div =
+      quot
+    
+    (** val modulo : z -> z -> z **)
+    
+    let modulo =
+      rem
+   end
+  
+  module NZQuot = 
+   struct 
+    
+   end
+  
+  (** val lcm : z -> z -> z **)
+  
+  let lcm a b =
+    abs (mul a (div b (gcd a b)))
+  
+  (** val b2z : bool -> z **)
+  
+  let b2z = function
+  | true -> Zpos XH
+  | false -> Z0
+  
+  (** val setbit : z -> z -> z **)
+  
+  let setbit a n0 =
+    coq_lor a (shiftl (Zpos XH) n0)
+  
+  (** val clearbit : z -> z -> z **)
+  
+  let clearbit a n0 =
+    ldiff a (shiftl (Zpos XH) n0)
+  
+  (** val lnot : z -> z **)
+  
+  let lnot a =
+    pred (opp a)
+  
+  (** val ones : z -> z **)
+  
+  let ones n0 =
+    pred (shiftl (Zpos XH) n0)
+  
+  module T = 
+   struct 
+    
+   end
+  
+  module ORev = 
+   struct 
+    type t = z
+   end
+  
+  module MRev = 
+   struct 
+    (** val max : z -> z -> z **)
+    
+    let max x y =
+      min y x
+   end
+  
+  module MPRev = MaxLogicalProperties(ORev)(MRev)
+  
+  module P = 
+   struct 
+    (** val max_case_strong :
+        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let max_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat n0 (max n0 m) __ (hl __)
+       | _ -> compat m (max n0 m) __ (hr __))
+    
+    (** val max_case :
+        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let max_case n0 m x x0 x1 =
+      max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val max_dec : z -> z -> bool **)
+    
+    let max_dec n0 m =
+      max_case n0 m (fun x y _ h0 -> h0) true false
+    
+    (** val min_case_strong :
+        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
+        -> 'a1 **)
+    
+    let min_case_strong n0 m compat hl hr =
+      let c = compSpec2Type n0 m (compare n0 m) in
+      (match c with
+       | CompGtT -> compat m (min n0 m) __ (hr __)
+       | _ -> compat n0 (min n0 m) __ (hl __))
+    
+    (** val min_case :
+        z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
+    
+    let min_case n0 m x x0 x1 =
+      min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
+    
+    (** val min_dec : z -> z -> bool **)
+    
+    let min_dec n0 m =
+      min_case n0 m (fun x y _ h0 -> h0) true false
+   end
+  
+  (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let max_case_strong n0 m x x0 =
+    P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let max_case n0 m x x0 =
+    max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val max_dec : z -> z -> bool **)
+  
+  let max_dec =
+    P.max_dec
+  
+  (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+  
+  let min_case_strong n0 m x x0 =
+    P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
+  
+  (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
+  
+  let min_case n0 m x x0 =
+    min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
+  
+  (** val min_dec : z -> z -> bool **)
+  
+  let min_dec =
+    P.min_dec
+ end
 
-(** val zdiv : z -> z -> z **)
+(** val zeq_bool : z -> z -> bool **)
 
-let zdiv a b =
-  let q0 , x = zdiv_eucl a b in q0
+let zeq_bool x y =
+  match Z.compare x y with
+  | Eq -> true
+  | _ -> false
 
 type 'c pol =
-  | Pc of 'c
-  | Pinj of positive * 'c pol
-  | PX of 'c pol * positive * 'c pol
+| Pc of 'c
+| Pinj of positive * 'c pol
+| PX of 'c pol * positive * 'c pol
 
 (** val p0 : 'a1 -> 'a1 pol **)
 
@@ -457,49 +2796,51 @@ let p1 cI =
 
 let rec peq ceqb p p' =
   match p with
-    | Pc c -> (match p' with
-                 | Pc c' -> ceqb c c'
-                 | _ -> false)
-    | Pinj (j, q0) ->
-        (match p' with
-           | Pinj (j', q') ->
-               (match pcompare j j' Eq with
-                  | Eq -> peq ceqb q0 q'
-                  | _ -> false)
-           | _ -> false)
-    | PX (p2, i, q0) ->
-        (match p' with
-           | PX (p'0, i', q') ->
-               (match pcompare i i' Eq with
-                  | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false
-                  | _ -> false)
-           | _ -> false)
+  | Pc c ->
+    (match p' with
+     | Pc c' -> ceqb c c'
+     | _ -> false)
+  | Pinj (j, q0) ->
+    (match p' with
+     | Pinj (j', q') ->
+       (match Coq_Pos.compare j j' with
+        | Eq -> peq ceqb q0 q'
+        | _ -> false)
+     | _ -> false)
+  | PX (p2, i, q0) ->
+    (match p' with
+     | PX (p'0, i', q') ->
+       (match Coq_Pos.compare i i' with
+        | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false
+        | _ -> false)
+     | _ -> false)
+
+(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **)
+
+let mkPinj j p = match p with
+| Pc c -> p
+| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0)
+| PX (p2, p3, p4) -> Pinj (j, p)
 
 (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
 
 let mkPinj_pred j p =
   match j with
-    | XI j0 -> Pinj ((XO j0), p)
-    | XO j0 -> Pinj ((pdouble_minus_one j0), p)
-    | XH -> p
+  | XI j0 -> Pinj ((XO j0), p)
+  | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p)
+  | XH -> p
 
 (** val mkPX :
     'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let mkPX cO ceqb p i q0 =
   match p with
-    | Pc c ->
-        if ceqb c cO
-        then (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') ->
-        if peq ceqb q' (p0 cO)
-        then PX (p', (pplus i' i), q0)
-        else PX (p, i, q0)
+  | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0)
+  | Pinj (p2, p3) -> PX (p, i, q0)
+  | PX (p', i', q') ->
+    if peq ceqb q' (p0 cO)
+    then PX (p', (Coq_Pos.add i' i), q0)
+    else PX (p, i, q0)
 
 (** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
 
@@ -514,202 +2855,155 @@ let mkX cO cI =
 (** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **)
 
 let rec popp copp = function
-  | Pc c -> Pc (copp c)
-  | Pinj (j, q0) -> Pinj (j, (popp copp q0))
-  | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0))
+| Pc c -> Pc (copp c)
+| Pinj (j, q0) -> Pinj (j, (popp copp q0))
+| PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0))
 
 (** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
 
 let rec paddC cadd p c =
   match p with
-    | Pc c1 -> Pc (cadd c1 c)
-    | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c))
-    | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c))
+  | Pc c1 -> Pc (cadd c1 c)
+  | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c))
+  | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c))
 
 (** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
 
 let rec psubC csub p c =
   match p with
-    | Pc c1 -> Pc (csub c1 c)
-    | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c))
-    | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c))
+  | Pc c1 -> Pc (csub c1 c)
+  | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c))
+  | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c))
 
 (** val paddI :
     ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
     positive -> 'a1 pol -> 'a1 pol **)
 
 let rec paddI cadd pop q0 j = function
-  | Pc c ->
-      let p2 = paddC cadd q0 c in
-      (match p2 with
-         | Pc c0 -> p2
-         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
-         | PX (p3, p4, p5) -> Pinj (j, p2))
-  | Pinj (j', q') ->
-      (match zPminus j' j with
-         | Z0 ->
-             let p2 = pop q' q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zpos k ->
-             let p2 = pop (Pinj (k, q')) q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zneg k ->
-             let p2 = paddI cadd pop q0 k q' in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j', p2)))
-  | PX (p2, i, q') ->
-      (match j with
-         | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q'))
-         | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q'))
-         | XH -> PX (p2, i, (pop q' q0)))
+| Pc c -> mkPinj j (paddC cadd q0 c)
+| Pinj (j', q') ->
+  (match Z.pos_sub j' j with
+   | Z0 -> mkPinj j (pop q' q0)
+   | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0)
+   | Zneg k -> mkPinj j' (paddI cadd pop q0 k q'))
+| PX (p2, i, q') ->
+  (match j with
+   | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q'))
+   | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q'))
+   | XH -> PX (p2, i, (pop q' q0)))
 
 (** val psubI :
     ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
     'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec psubI cadd copp pop q0 j = function
-  | Pc c ->
-      let p2 = paddC cadd (popp copp q0) c in
-      (match p2 with
-         | Pc c0 -> p2
-         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
-         | PX (p3, p4, p5) -> Pinj (j, p2))
-  | Pinj (j', q') ->
-      (match zPminus j' j with
-         | Z0 ->
-             let p2 = pop q' q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zpos k ->
-             let p2 = pop (Pinj (k, q')) q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zneg k ->
-             let p2 = psubI cadd copp pop q0 k q' in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j', p2)))
-  | PX (p2, i, q') ->
-      (match j with
-         | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q'))
-         | XO j0 -> PX (p2, i,
-             (psubI cadd copp pop q0 (pdouble_minus_one j0) q'))
-         | XH -> PX (p2, i, (pop q' q0)))
+| Pc c -> mkPinj j (paddC cadd (popp copp q0) c)
+| Pinj (j', q') ->
+  (match Z.pos_sub j' j with
+   | Z0 -> mkPinj j (pop q' q0)
+   | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0)
+   | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q'))
+| PX (p2, i, q') ->
+  (match j with
+   | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q'))
+   | XO j0 ->
+     PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q'))
+   | XH -> PX (p2, i, (pop q' q0)))
 
 (** val paddX :
     'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
     -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec paddX cO ceqb pop p' i' p = match p with
-  | Pc c -> PX (p', i', p)
-  | Pinj (j, q') ->
-      (match j with
-         | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
-         | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q')))
-         | XH -> PX (p', i', q'))
-  | PX (p2, i, q') ->
-      (match zPminus i i' with
-         | Z0 -> mkPX cO ceqb (pop p2 p') i q'
-         | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
-         | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
+| Pc c -> PX (p', i', p)
+| Pinj (j, q') ->
+  (match j with
+   | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
+   | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q')))
+   | XH -> PX (p', i', q'))
+| PX (p2, i, q') ->
+  (match Z.pos_sub i i' with
+   | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+   | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+   | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
 
 (** val psubX :
     'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
     pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec psubX cO copp ceqb pop p' i' p = match p with
-  | Pc c -> PX ((popp copp p'), i', p)
-  | Pinj (j, q') ->
-      (match j with
-         | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
-         | XO j0 -> PX ((popp copp p'), i', (Pinj (
-             (pdouble_minus_one j0), q')))
-         | XH -> PX ((popp copp p'), i', q'))
-  | PX (p2, i, q') ->
-      (match zPminus i i' with
-         | Z0 -> mkPX cO ceqb (pop p2 p') i q'
-         | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
-         | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
+| Pc c -> PX ((popp copp p'), i', p)
+| Pinj (j, q') ->
+  (match j with
+   | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
+   | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q')))
+   | XH -> PX ((popp copp p'), i', q'))
+| PX (p2, i, q') ->
+  (match Z.pos_sub i i' with
+   | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+   | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+   | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
 
 (** val padd :
     'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
     -> 'a1 pol **)
 
 let rec padd cO cadd ceqb p = function
-  | Pc c' -> paddC cadd p c'
-  | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p
-  | PX (p'0, i', q') ->
-      (match p with
-         | Pc c -> PX (p'0, i', (paddC cadd q' c))
-         | Pinj (j, q0) ->
-             (match j with
-                | XI j0 -> PX (p'0, i',
-                    (padd cO cadd ceqb (Pinj ((XO j0), q0)) q'))
-                | XO j0 -> PX (p'0, i',
-                    (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0))
-                      q'))
-                | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q')))
-         | PX (p2, i, q0) ->
-             (match zPminus i i' with
-                | Z0 ->
-                    mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i
-                      (padd cO cadd ceqb q0 q')
-                | Zpos k ->
-                    mkPX cO ceqb
-                      (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
-                      (padd cO cadd ceqb q0 q')
-                | Zneg k ->
-                    mkPX cO ceqb
-                      (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0
-                        k p2) i (padd cO cadd ceqb q0 q')))
+| Pc c' -> paddC cadd p c'
+| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p
+| PX (p'0, i', q') ->
+  (match p with
+   | Pc c -> PX (p'0, i', (paddC cadd q' c))
+   | Pinj (j, q0) ->
+     (match j with
+      | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q'))
+      | XO j0 ->
+        PX (p'0, i',
+          (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q'))
+      | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q')))
+   | PX (p2, i, q0) ->
+     (match Z.pos_sub i i' with
+      | Z0 ->
+        mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q')
+      | Zpos k ->
+        mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
+          (padd cO cadd ceqb q0 q')
+      | Zneg k ->
+        mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i
+          (padd cO cadd ceqb q0 q')))
 
 (** val psub :
     'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
     -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
 let rec psub cO cadd csub copp ceqb p = function
-  | Pc c' -> psubC csub p c'
-  | Pinj (j', q') ->
-      psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p
-  | PX (p'0, i', q') ->
-      (match p with
-         | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c))
-         | Pinj (j, q0) ->
-             (match j with
-                | XI j0 -> PX ((popp copp p'0), i',
-                    (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
-                | XO j0 -> PX ((popp copp p'0), i',
-                    (psub cO cadd csub copp ceqb (Pinj
-                      ((pdouble_minus_one j0), q0)) q'))
-                | XH -> PX ((popp copp p'0), i',
-                    (psub cO cadd csub copp ceqb q0 q')))
-         | PX (p2, i, q0) ->
-             (match zPminus i i' with
-                | Z0 ->
-                    mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
-                      (psub cO cadd csub copp ceqb q0 q')
-                | Zpos k ->
-                    mkPX cO ceqb
-                      (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
-                      i' (psub cO cadd csub copp ceqb q0 q')
-                | Zneg k ->
-                    mkPX cO ceqb
-                      (psubX cO copp ceqb (fun x x0 ->
-                        psub cO cadd csub copp ceqb x x0) p'0 k p2) i
-                      (psub cO cadd csub copp ceqb q0 q')))
+| Pc c' -> psubC csub p c'
+| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p
+| PX (p'0, i', q') ->
+  (match p with
+   | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c))
+   | Pinj (j, q0) ->
+     (match j with
+      | XI j0 ->
+        PX ((popp copp p'0), i',
+          (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
+      | XO j0 ->
+        PX ((popp copp p'0), i',
+          (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0))
+            q'))
+      | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q')))
+   | PX (p2, i, q0) ->
+     (match Z.pos_sub i i' with
+      | Z0 ->
+        mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
+          (psub cO cadd csub copp ceqb q0 q')
+      | Zpos k ->
+        mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
+          i' (psub cO cadd csub copp ceqb q0 q')
+      | Zneg k ->
+        mkPX cO ceqb
+          (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i
+          (psub cO cadd csub copp ceqb q0 q')))
 
 (** val pmulC_aux :
     'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
@@ -717,16 +3011,11 @@ let rec psub cO cadd csub copp ceqb p = function
 
 let rec pmulC_aux cO cmul ceqb p c =
   match p with
-    | Pc c' -> Pc (cmul c' c)
-    | Pinj (j, q0) ->
-        let p2 = pmulC_aux cO cmul ceqb q0 c in
-        (match p2 with
-           | Pc c0 -> p2
-           | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
-           | PX (p3, p4, p5) -> Pinj (j, p2))
-    | PX (p2, i, q0) ->
-        mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i
-          (pmulC_aux cO cmul ceqb q0 c)
+  | Pc c' -> Pc (cmul c' c)
+  | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c)
+  | PX (p2, i, q0) ->
+    mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i
+      (pmulC_aux cO cmul ceqb q0 c)
 
 (** val pmulC :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
@@ -742,108 +3031,75 @@ let pmulC cO cI cmul ceqb p c =
     'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
 
 let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
-  | Pc c ->
-      let p2 = pmulC cO cI cmul ceqb q0 c in
-      (match p2 with
-         | Pc c0 -> p2
-         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
-         | PX (p3, p4, p5) -> Pinj (j, p2))
-  | Pinj (j', q') ->
-      (match zPminus j' j with
-         | Z0 ->
-             let p2 = pmul0 q' q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zpos k ->
-             let p2 = pmul0 (Pinj (k, q')) q0 in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j, p2))
-         | Zneg k ->
-             let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in
-             (match p2 with
-                | Pc c -> p2
-                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
-                | PX (p3, p4, p5) -> Pinj (j', p2)))
-  | PX (p', i', q') ->
-      (match j with
-         | XI j' ->
-             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
-               (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q')
-         | XO j' ->
-             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
-               (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q')
-         | XH ->
-             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i'
-               (pmul0 q' q0))
+| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c)
+| Pinj (j', q') ->
+  (match Z.pos_sub j' j with
+   | Z0 -> mkPinj j (pmul0 q' q0)
+   | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0)
+   | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q'))
+| PX (p', i', q') ->
+  (match j with
+   | XI j' ->
+     mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+       (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q')
+   | XO j' ->
+     mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+       (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q')
+   | XH ->
+     mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0))
 
 (** val pmul :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
     -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
 let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
-  | Pc c -> pmulC cO cI cmul ceqb p c
-  | Pinj (j', q') ->
-      pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q'
-        j' p
-  | PX (p', i', q') ->
-      (match p with
-         | Pc c -> pmulC cO cI cmul ceqb p'' c
-         | Pinj (j, q0) ->
-             mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i'
-               (match j with
-                  | XI j0 ->
-                      pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
-                  | XO j0 ->
-                      pmul cO cI cadd cmul ceqb (Pinj
-                        ((pdouble_minus_one j0), q0)) q'
-                  | XH -> pmul cO cI cadd cmul ceqb q0 q')
-         | PX (p2, i, q0) ->
-             padd cO cadd ceqb
-               (mkPX cO ceqb
-                 (padd cO cadd ceqb
-                   (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO))
-                   (pmul cO cI cadd cmul ceqb
-                     (match q0 with
-                        | Pc c -> q0
-                        | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
-                        | 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')))
+| Pc c -> pmulC cO cI cmul ceqb p c
+| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p
+| PX (p', i', q') ->
+  (match p with
+   | Pc c -> pmulC cO cI cmul ceqb p'' c
+   | Pinj (j, q0) ->
+     let qQ' =
+       match j with
+       | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
+       | XO j0 ->
+         pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q'
+       | XH -> pmul cO cI cadd cmul ceqb q0 q'
+     in
+     mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ'
+   | PX (p2, i, q0) ->
+     let qQ' = pmul cO cI cadd cmul ceqb q0 q' in
+     let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in
+     let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in
+     let pP' = pmul cO cI cadd cmul ceqb p2 p' in
+     padd cO cadd ceqb
+       (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i'
+         (p0 cO)) (mkPX cO ceqb pQ' i qQ'))
 
 (** 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)
+| Pc c -> Pc (cmul c c)
+| Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0))
+| PX (p2, i, q0) ->
+  let twoPQ =
+    pmul cO cI cadd cmul ceqb p2
+      (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI)))
+  in
+  let q2 = psquare cO cI cadd cmul ceqb q0 in
+  let p3 = psquare cO cI cadd cmul ceqb p2 in
+  mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2
 
 type 'c pExpr =
-  | PEc of 'c
-  | PEX of positive
-  | PEadd of 'c pExpr * 'c pExpr
-  | PEsub of 'c pExpr * 'c pExpr
-  | PEmul of 'c pExpr * 'c pExpr
-  | PEopp of 'c pExpr
-  | PEpow of 'c pExpr * n
+| PEc of 'c
+| PEX of positive
+| PEadd of 'c pExpr * 'c pExpr
+| PEsub of 'c pExpr * 'c pExpr
+| PEmul of 'c pExpr * 'c pExpr
+| PEopp of 'c pExpr
+| PEpow of 'c pExpr * n
 
 (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **)
 
@@ -856,68 +3112,78 @@ let mk_X cO cI j =
     pol **)
 
 let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
-  | XI p3 ->
-      subst_l
-        (pmul cO cI cadd cmul ceqb
-          (ppow_pos cO cI cadd cmul ceqb subst_l
-            (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p)
-  | XO p3 ->
-      ppow_pos cO cI cadd cmul ceqb subst_l
-        (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3
-  | XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
+| XI p3 ->
+  subst_l
+    (pmul cO cI cadd cmul ceqb
+      (ppow_pos cO cI cadd cmul ceqb subst_l
+        (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p)
+| XO p3 ->
+  ppow_pos cO cI cadd cmul ceqb subst_l
+    (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3
+| XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
 
 (** val ppow_N :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
     -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
 
 let ppow_N cO cI cadd cmul ceqb subst_l p = function
-  | N0 -> p1 cI
-  | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
+| N0 -> p1 cI
+| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
 
 (** val norm_aux :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
     -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
 
 let rec norm_aux cO cI cadd cmul csub copp ceqb = function
-  | PEc c -> Pc c
-  | PEX j -> mk_X cO cI j
-  | PEadd (pe1, pe2) ->
-      (match pe1 with
-         | PEopp pe3 ->
-             psub cO cadd csub copp ceqb
-               (norm_aux cO cI cadd cmul csub copp ceqb pe2)
-               (norm_aux cO cI cadd cmul csub copp ceqb pe3)
-         | _ ->
-             (match pe2 with
-                | PEopp pe3 ->
-                    psub cO cadd csub copp ceqb
-                      (norm_aux cO cI cadd cmul csub copp ceqb pe1)
-                      (norm_aux cO cI cadd cmul csub copp ceqb pe3)
-                | _ ->
-                    padd cO cadd ceqb
-                      (norm_aux cO cI cadd cmul csub copp ceqb pe1)
-                      (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
-  | PEsub (pe1, pe2) ->
-      psub cO cadd csub copp ceqb
-        (norm_aux cO cI cadd cmul csub copp ceqb pe1)
-        (norm_aux cO cI cadd cmul csub copp ceqb pe2)
-  | PEmul (pe1, pe2) ->
-      pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
-        (norm_aux cO cI cadd cmul csub copp ceqb pe2)
-  | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1)
-  | PEpow (pe1, n0) ->
-      ppow_N cO cI cadd cmul ceqb (fun p -> p)
-        (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0
+| PEc c -> Pc c
+| PEX j -> mk_X cO cI j
+| PEadd (pe1, pe2) ->
+  (match pe1 with
+   | PEopp pe3 ->
+     psub cO cadd csub copp ceqb
+       (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+       (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+   | _ ->
+     (match pe2 with
+      | PEopp pe3 ->
+        psub cO cadd csub copp ceqb
+          (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+          (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+      | _ ->
+        padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+          (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
+| PEsub (pe1, pe2) ->
+  psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+    (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+| PEmul (pe1, pe2) ->
+  pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+    (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+| PEpow (pe1, n0) ->
+  ppow_N cO cI cadd cmul ceqb (fun p -> p)
+    (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0
 
 type 'a bFormula =
-  | TT
-  | FF
-  | X
-  | A of 'a
-  | Cj of 'a bFormula * 'a bFormula
-  | D of 'a bFormula * 'a bFormula
-  | N of 'a bFormula
-  | I of 'a bFormula * 'a bFormula
+| TT
+| FF
+| X
+| A of 'a
+| Cj of 'a bFormula * 'a bFormula
+| D of 'a bFormula * 'a bFormula
+| N of 'a bFormula
+| I of 'a bFormula * 'a bFormula
+
+(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **)
+
+let rec map_bformula fct = function
+| TT -> TT
+| FF -> FF
+| X -> X
+| A a -> A (fct a)
+| Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2))
+| D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2))
+| N f0 -> N (map_bformula fct f0)
+| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2))
 
 type 'term' clause = 'term' list
 
@@ -931,19 +3197,61 @@ let tt =
 (** val ff : 'a1 cnf **)
 
 let ff =
-  [] :: []
+  []::[]
+
+(** val add_term :
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1
+    clause option **)
+
+let rec add_term unsat deduce t1 = function
+| [] ->
+  (match deduce t1 t1 with
+   | Some u -> if unsat u then None else Some (t1::[])
+   | None -> Some (t1::[]))
+| t'::cl0 ->
+  (match deduce t1 t' with
+   | Some u ->
+     if unsat u
+     then None
+     else (match add_term unsat deduce t1 cl0 with
+           | Some cl' -> Some (t'::cl')
+           | None -> None)
+   | None ->
+     (match add_term unsat deduce t1 cl0 with
+      | Some cl' -> Some (t'::cl')
+      | None -> None))
+
+(** val or_clause :
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause
+    -> 'a1 clause option **)
+
+let rec or_clause unsat deduce cl1 cl2 =
+  match cl1 with
+  | [] -> Some cl2
+  | t1::cl ->
+    (match add_term unsat deduce t1 cl2 with
+     | Some cl' -> or_clause unsat deduce cl cl'
+     | None -> None)
 
-(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
+(** val or_clause_cnf :
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf ->
+    'a1 cnf **)
 
-let or_clause_cnf t0 f =
-  map (fun x -> app t0 x) f
+let or_clause_cnf unsat deduce t1 f =
+  fold_right (fun e acc ->
+    match or_clause unsat deduce t1 e with
+    | Some cl -> cl::acc
+    | None -> acc) [] f
 
-(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+(** val or_cnf :
+    ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
+    cnf **)
 
-let rec or_cnf f f' =
+let rec or_cnf unsat deduce f f' =
   match f with
-    | [] -> tt
-    | e :: rst -> app (or_cnf rst f') (or_clause_cnf e f')
+  | [] -> tt
+  | e::rst ->
+    app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f')
 
 (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
 
@@ -951,133 +3259,168 @@ let and_cnf f1 f2 =
   app f1 f2
 
 (** val xcnf :
-    ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
-
-let rec xcnf normalise0 negate0 pol0 = function
-  | TT -> if pol0 then tt else ff
-  | FF -> if pol0 then ff else tt
-  | X -> ff
-  | A x -> if pol0 then normalise0 x else negate0 x
-  | Cj (e1, 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) ->
-      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) ->
-      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)
+    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+    -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
+
+let rec xcnf unsat deduce normalise0 negate0 pol0 = function
+| TT -> if pol0 then tt else ff
+| FF -> if pol0 then ff else tt
+| X -> ff
+| A x -> if pol0 then normalise0 x else negate0 x
+| Cj (e1, e2) ->
+  if pol0
+  then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1)
+         (xcnf unsat deduce normalise0 negate0 pol0 e2)
+  else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1)
+         (xcnf unsat deduce normalise0 negate0 pol0 e2)
+| D (e1, e2) ->
+  if pol0
+  then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1)
+         (xcnf unsat deduce normalise0 negate0 pol0 e2)
+  else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1)
+         (xcnf unsat deduce normalise0 negate0 pol0 e2)
+| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e
+| I (e1, e2) ->
+  if pol0
+  then or_cnf unsat deduce
+         (xcnf unsat deduce normalise0 negate0 (negb pol0) e1)
+         (xcnf unsat deduce normalise0 negate0 pol0 e2)
+  else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1)
+         (xcnf unsat deduce 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
-    | [] -> true
-    | e :: f0 ->
-        (match l with
-           | [] -> false
-           | c :: l0 ->
-               if checker e c then cnf_checker checker f0 l0 else false)
+  | [] -> true
+  | e::f0 ->
+    (match l with
+     | [] -> 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 **)
+    ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+    -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list ->
+    bool **)
+
+let tauto_checker unsat deduce normalise0 negate0 checker f w =
+  cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w
+
+(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **)
+
+let cneqb ceqb x y =
+  negb (ceqb x y)
 
-let tauto_checker normalise0 negate0 checker f w =
-  cnf_checker checker (xcnf normalise0 negate0 true f) w
+(** val cltb :
+    ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **)
+
+let cltb ceqb cleb x y =
+  (&&) (cleb x y) (cneqb ceqb x y)
 
 type 'c polC = 'c pol
 
 type op1 =
-  | Equal
-  | NonEqual
-  | Strict
-  | NonStrict
+| Equal
+| NonEqual
+| Strict
+| NonStrict
+
+type 'c nFormula = 'c polC * op1
 
-type 'c nFormula = 'c polC  *  op1
+(** val opMult : op1 -> op1 -> op1 option **)
+
+let opMult o o' =
+  match o with
+  | Equal -> Some Equal
+  | NonEqual ->
+    (match o' with
+     | Strict -> None
+     | NonStrict -> None
+     | x -> Some x)
+  | Strict ->
+    (match o' with
+     | NonEqual -> None
+     | _ -> Some o')
+  | NonStrict ->
+    (match o' with
+     | NonEqual -> None
+     | Strict -> Some NonStrict
+     | x -> Some x)
 
 (** 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)
+  | Equal -> Some o'
+  | NonEqual ->
+    (match o' with
+     | Equal -> Some NonEqual
+     | _ -> None)
+  | Strict ->
+    (match o' with
+     | NonEqual -> None
+     | _ -> Some Strict)
+  | NonStrict ->
+    (match o' with
+     | Equal -> Some NonStrict
+     | NonEqual -> None
+     | x -> Some x)
 
 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
+| 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 map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **)
+
+let map_option f = function
+| Some x -> f x
+| None -> None
+
+(** val map_option2 :
+    ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **)
+
+let map_option2 f o o' =
+  match o with
+  | Some x ->
+    (match o' with
+     | Some x' -> f x x'
+     | None -> None)
+  | None -> None
 
 (** val pexpr_times_nformula :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
     -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
 
 let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
-  | ef , o ->
-      (match o with
-         | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef) , Equal)
-         | _ -> None)
+| ef,o ->
+  (match o with
+   | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal)
+   | _ -> None)
 
 (** 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)))
+  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)
 
 (** 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)
+  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)
 
 (** val eval_Psatz :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
@@ -1085,47 +3428,36 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 =
     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)
+| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal))
+| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict)
+| PsatzMulC (re, e0) ->
+  map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re)
+    (eval_Psatz cO cI cplus ctimes ceqb cleb l e0)
+| PsatzMulE (f1, f2) ->
+  map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb)
+    (eval_Psatz cO cI cplus ctimes ceqb cleb l f1)
+    (eval_Psatz cO cI cplus ctimes ceqb cleb l f2)
+| PsatzAdd (f1, f2) ->
+  map_option2 (nformula_plus_nformula cO cplus ceqb)
+    (eval_Psatz cO cI cplus ctimes ceqb cleb l f1)
+    (eval_Psatz cO cI cplus ctimes ceqb cleb l f2)
+| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None
+| PsatzZ -> Some ((Pc cO),Equal)
 
 (** 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 -> ceqb c cO
-                | Strict -> cleb c cO
-                | NonStrict -> (&&) (cleb c cO) (negb (ceqb c cO)))
-         | _ -> false)
+| e,op ->
+  (match e with
+   | Pc c ->
+     (match op with
+      | Equal -> cneqb ceqb c cO
+      | NonEqual -> ceqb c cO
+      | Strict -> cleb c cO
+      | NonStrict -> cltb ceqb cleb c cO)
+   | _ -> false)
 
 (** val check_normalised_formulas :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
@@ -1134,18 +3466,18 @@ let check_inconsistent cO ceqb cleb = function
 
 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
+  | Some f -> check_inconsistent cO ceqb cleb f
+  | None -> false
 
 type op2 =
-  | OpEq
-  | OpNEq
-  | OpLe
-  | OpGe
-  | OpLt
-  | OpGt
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt
 
-type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
 
 (** val flhs : 'a1 formula -> 'a1 pExpr **)
 
@@ -1163,157 +3495,170 @@ let frhs x = x.frhs
     '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 norm cO cI cplus ctimes cminus copp ceqb =
+  norm_aux cO cI cplus ctimes cminus copp ceqb
 
 (** val psub0 :
     'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
     -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
 
-let psub0 cO cplus cminus copp ceqb p p' =
-  psub cO cplus cminus copp ceqb p p'
+let psub0 cO cplus cminus copp ceqb =
+  psub cO cplus cminus copp ceqb
 
 (** val padd0 :
     'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
     -> 'a1 pol **)
 
-let padd0 cO cplus ceqb p p' =
-  padd cO cplus ceqb p p'
+let padd0 cO cplus ceqb =
+  padd cO cplus ceqb
 
 (** val xnormalise :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
     -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
     nFormula list **)
 
-let xnormalise cO cI cplus ctimes cminus copp ceqb t0 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+let xnormalise cO cI cplus ctimes cminus copp ceqb t1 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
   let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
   let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
   (match o with
-     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
-         (((psub0 cO cplus 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) ::
-         [])
+   | 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 cO cI cplus ctimes cminus copp ceqb t0 =
-  map (fun x -> x :: []) (xnormalise cO cI cplus ctimes cminus copp ceqb t0)
+let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 =
+  map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1)
 
 (** 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 cO cI cplus ctimes cminus copp ceqb t0 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+let xnegate cO cI cplus ctimes cminus copp ceqb t1 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
   let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
   let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
   (match o with
-     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: []
-     | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
-         (((psub0 cO cplus 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) :: [])
+   | 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)
+let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 =
+  map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1)
 
 (** 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))
+| Pc c -> PEc c
+| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2
+| PX (p2, j, q0) ->
+  PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))),
+    (xdenorm (Coq_Pos.succ jmp) q0))
 
 (** val denorm : 'a1 pol -> 'a1 pExpr **)
 
 let denorm p =
   xdenorm XH p
 
+(** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **)
+
+let rec map_PExpr c_of_S = function
+| PEc c -> PEc (c_of_S c)
+| PEX p -> PEX p
+| PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2))
+| PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2))
+| PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2))
+| PEopp e0 -> PEopp (map_PExpr c_of_S e0)
+| PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0)
+
+(** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **)
+
+let map_Formula c_of_S f =
+  let { flhs = l; fop = o; frhs = r } = f in
+  { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) }
+
 (** val simpl_cone :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
     'a1 psatz **)
 
 let simpl_cone cO cI ctimes ceqb e = match e with
-  | 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
-         | PsatzMulE (x, x0) ->
-             (match x with
-                | PsatzC p2 ->
-                    (match t2 with
-                       | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
-                       | PsatzZ -> PsatzZ
-                       | _ -> e)
-                | _ ->
-                    (match x0 with
-                       | PsatzC p2 ->
-                           (match t2 with
-                              | PsatzC c -> PsatzMulE ((PsatzC
-                                  (ctimes c p2)), x)
-                              | PsatzZ -> PsatzZ
-                              | _ -> e)
-                       | _ ->
-                           (match t2 with
-                              | PsatzC c ->
-                                  if ceqb cI c
-                                  then t1
-                                  else PsatzMulE (t1, t2)
-                              | PsatzZ -> PsatzZ
-                              | _ -> e)))
-         | PsatzC c ->
-             (match t2 with
-                | PsatzMulE (x, x0) ->
-                    (match x with
-                       | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
-                       | _ ->
-                           (match x0 with
-                              | PsatzC p2 -> PsatzMulE ((PsatzC
-                                  (ctimes c p2)), x)
-                              | _ ->
-                                  if ceqb cI c
-                                  then t2
-                                  else PsatzMulE (t1, t2)))
-                | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)),
-                    (PsatzMulE ((PsatzC c), z0)))
-                | PsatzC c0 -> PsatzC (ctimes c c0)
-                | PsatzZ -> PsatzZ
-                | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))
+| PsatzSquare t1 ->
+  (match t1 with
+   | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+   | _ -> PsatzSquare t1)
+| PsatzMulE (t1, t2) ->
+  (match t1 with
+   | PsatzMulE (x, x0) ->
+     (match x with
+      | PsatzC p2 ->
+        (match t2 with
+         | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
          | PsatzZ -> PsatzZ
+         | _ -> e)
+      | _ ->
+        (match x0 with
+         | PsatzC p2 ->
+           (match t2 with
+            | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x)
+            | PsatzZ -> PsatzZ
+            | _ -> e)
+         | _ ->
+           (match t2 with
+            | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2)
+            | PsatzZ -> PsatzZ
+            | _ -> e)))
+   | PsatzC c ->
+     (match t2 with
+      | PsatzMulE (x, x0) ->
+        (match x with
+         | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
          | _ ->
-             (match t2 with
-                | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2)
-                | PsatzZ -> PsatzZ
-                | _ -> e))
-  | PsatzAdd (t1, t2) ->
-      (match t1 with
-         | PsatzZ -> t2
-         | _ -> (match t2 with
-                   | PsatzZ -> t1
-                   | _ -> PsatzAdd (t1, t2)))
-  | _ -> e
+           (match x0 with
+            | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x)
+            | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)))
+      | PsatzAdd (y, z0) ->
+        PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0)))
+      | PsatzC c0 -> PsatzC (ctimes c c0)
+      | PsatzZ -> PsatzZ
+      | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))
+   | PsatzZ -> PsatzZ
+   | _ ->
+     (match t2 with
+      | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2)
+      | PsatzZ -> PsatzZ
+      | _ -> e))
+| PsatzAdd (t1, t2) ->
+  (match t1 with
+   | PsatzZ -> t2
+   | _ ->
+     (match t2 with
+      | PsatzZ -> t1
+      | _ -> PsatzAdd (t1, t2)))
+| _ -> e
 
 type q = { qnum : z; qden : positive }
 
@@ -1328,28 +3673,28 @@ 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))
+  zeq_bool (Z.mul x.qnum (Zpos y.qden)) (Z.mul 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))
+  Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))
 
 (** val qplus : q -> q -> q **)
 
 let qplus x y =
-  { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)));
-    qden = (pmult x.qden y.qden) }
+  { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
+    qden = (Coq_Pos.mul x.qden y.qden) }
 
 (** val qmult : q -> q -> q **)
 
 let qmult x y =
-  { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) }
+  { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) }
 
 (** val qopp : q -> q **)
 
 let qopp x =
-  { qnum = (zopp x.qnum); qden = x.qden }
+  { qnum = (Z.opp x.qnum); qden = x.qden }
 
 (** val qminus : q -> q -> q **)
 
@@ -1360,9 +3705,9 @@ let qminus x y =
 
 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 }
+  | 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 **)
 
@@ -1372,332 +3717,330 @@ let qpower_positive 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)
+| 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 **)
+type 'a t0 =
+| Empty
+| Leaf of 'a
+| Node of 'a t0 * 'a * 'a t0
 
-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
-  | Node of 'a t * 'a * 'a t
-
-(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
+(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **)
 
 let rec find default vm p =
   match vm with
-    | Empty -> default
-    | Leaf i -> i
-    | Node (l, e, r) ->
-        (match p with
-           | XI p2 -> find default r p2
-           | XO p2 -> find default l p2
-           | XH -> e)
+  | Empty -> default
+  | Leaf i -> i
+  | Node (l, e, r) ->
+    (match p with
+     | XI p2 -> find default r p2
+     | XO p2 -> find default l p2
+     | XH -> e)
 
 type zWitness = z psatz
 
 (** val zWeakChecker : z nFormula list -> z psatz -> bool **)
 
-let zWeakChecker x x0 =
-  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+let zWeakChecker =
+  check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb
 
 (** val psub1 : z pol -> z pol -> z pol **)
 
-let psub1 p p' =
-  psub0 Z0 zplus zminus zopp zeq_bool p p'
+let psub1 =
+  psub0 Z0 Z.add Z.sub Z.opp zeq_bool
 
 (** val padd1 : z pol -> z pol -> z pol **)
 
-let padd1 p p' =
-  padd0 Z0 zplus zeq_bool p p'
+let padd1 =
+  padd0 Z0 Z.add zeq_bool
 
 (** val norm0 : z pExpr -> z pol **)
 
-let norm0 pe =
-  norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe
+let norm0 =
+  norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool
 
 (** val xnormalise0 : z formula -> z nFormula list **)
 
-let xnormalise0 t0 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+let xnormalise0 t1 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
   let lhs0 = norm0 lhs in
   let rhs0 = norm0 rhs in
   (match o with
-     | 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) :: [])
+   | 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 -> x :: []) (xnormalise0 t0)
+let normalise t1 =
+  map (fun x -> x::[]) (xnormalise0 t1)
 
 (** val xnegate0 : z formula -> z nFormula list **)
 
-let xnegate0 t0 =
-  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+let xnegate0 t1 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t1 in
   let lhs0 = norm0 lhs in
   let rhs0 = norm0 rhs in
   (match o with
-     | 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) :: [])
+   | 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 -> x :: []) (xnegate0 t0)
+let negate t1 =
+  map (fun x -> x::[]) (xnegate0 t1)
+
+(** val zunsat : z nFormula -> bool **)
+
+let zunsat =
+  check_inconsistent Z0 zeq_bool Z.leb
+
+(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **)
+
+let zdeduce =
+  nformula_plus_nformula Z0 Z.add zeq_bool
 
 (** val ceiling : z -> z -> z **)
 
 let ceiling a b =
-  let q0 , r = zdiv_eucl a b in
+  let q0,r = Z.div_eucl a b in
   (match r with
-     | Z0 -> q0
-     | _ -> zplus q0 (Zpos XH))
+   | Z0 -> q0
+   | _ -> Z.add q0 (Zpos XH))
 
 type zArithProof =
-  | DoneProof
-  | RatProof of zWitness * zArithProof
-  | CutProof of zWitness * zArithProof
-  | EnumProof of zWitness * zWitness * zArithProof list
+| DoneProof
+| RatProof of zWitness * zArithProof
+| CutProof of zWitness * zArithProof
+| EnumProof of zWitness * zWitness * zArithProof list
 
 (** val zgcdM : z -> z -> z **)
 
 let zgcdM x y =
-  zmax (zgcd x y) (Zpos XH)
+  Z.max (Z.gcd x y) (Zpos XH)
 
-(** val zgcd_pol : z polC -> z  *  z **)
+(** val zgcd_pol : z polC -> z * z **)
 
 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
+| 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 zdiv_pol : z polC -> z -> z polC **)
 
 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))
+  | Pc c -> Pc (Z.div 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 makeCuttingPlane : z polC -> z polC  *  z **)
+(** val makeCuttingPlane : z polC -> z polC * z **)
 
 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
+  let g,c = zgcd_pol p in
+  if Z.gtb g Z0
+  then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g))
+  else p,Z0
 
-(** val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option **)
+(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **)
 
 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 nformula_of_cutting_plane :
-    ((z polC  *  z)  *  op1) -> z nFormula **)
+| e,op ->
+  (match op with
+   | Equal ->
+     let g,c = zgcd_pol e in
+     if (&&) (Z.gtb g Z0)
+          ((&&) (negb (zeq_bool c Z0)) (negb (zeq_bool (Z.gcd g c) g)))
+     then None
+     else Some ((makeCuttingPlane e),Equal)
+   | NonEqual -> Some ((e,Z0),op)
+   | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict)
+   | NonStrict -> Some ((makeCuttingPlane e),NonStrict))
+
+(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **)
 
 let nformula_of_cutting_plane = function
-  | e_z , o -> let e , z0 = e_z in (padd1 e (Pc z0)) , o
+| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o
 
 (** val is_pol_Z0 : z polC -> bool **)
 
 let is_pol_Z0 = function
-  | Pc z0 -> (match z0 with
-                | Z0 -> true
-                | _ -> false)
-  | _ -> false
+| Pc z0 ->
+  (match z0 with
+   | Z0 -> true
+   | _ -> false)
+| _ -> false
 
 (** 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
+let eval_Psatz0 =
+  eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb
 
-(** val check_inconsistent0 : z nFormula -> bool **)
+(** val valid_cut_sign : op1 -> bool **)
 
-let check_inconsistent0 f =
-  check_inconsistent Z0 zeq_bool zle_bool f
+let valid_cut_sign = function
+| Equal -> true
+| NonStrict -> true
+| _ -> false
 
 (** 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)
+| DoneProof -> false
+| RatProof (w, pf0) ->
+  (match eval_Psatz0 l w with
+   | Some f -> if zunsat 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
+              if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4))
+                   (is_pol_Z0 (padd1 e1 e2))
+              then let rec label pfs lb ub =
+                     match pfs with
+                     | [] -> Z.gtb lb ub
+                     | pf1::rsr ->
+                       (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1)
+                         (label rsr (Z.add lb (Zpos XH)) ub)
+                   in label pf0 (Z.opp z1) z2
+              else false
+            | None -> true)
+         | None -> true)
+      | 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 **)
-
-let n_of_Z = function
-  | Zpos p -> Npos p
-  | _ -> N0
+  tauto_checker zunsat zdeduce normalise negate zChecker f w
 
 type qWitness = q psatz
 
 (** val qWeakChecker : q nFormula list -> q psatz -> bool **)
 
-let qWeakChecker x x0 =
+let qWeakChecker =
   check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
-    qden = XH } qplus qmult qeq_bool qle_bool x x0
+    qden = XH } qplus qmult qeq_bool qle_bool
 
 (** val qnormalise : q formula -> q nFormula cnf **)
 
-let qnormalise t0 =
+let qnormalise =
   cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
-    qplus qmult qminus qopp qeq_bool t0
+    qplus qmult qminus qopp qeq_bool
 
 (** val qnegate : q formula -> q nFormula cnf **)
 
-let qnegate t0 =
+let qnegate =
   cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
-    qmult qminus qopp qeq_bool t0
+    qmult qminus qopp qeq_bool
+
+(** val qunsat : q nFormula -> bool **)
+
+let qunsat =
+  check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool
+
+(** val qdeduce : q nFormula -> q nFormula -> q nFormula option **)
+
+let qdeduce =
+  nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool
 
 (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
 
 let qTautoChecker f w =
-  tauto_checker qnormalise qnegate qWeakChecker f w
+  tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w
+
+type rcst =
+| C0
+| C1
+| CQ of q
+| CZ of z
+| CPlus of rcst * rcst
+| CMinus of rcst * rcst
+| CMult of rcst * rcst
+| CInv of rcst
+| COpp of rcst
+
+(** val q_of_Rcst : rcst -> q **)
+
+let rec q_of_Rcst = function
+| C0 -> { qnum = Z0; qden = XH }
+| C1 -> { qnum = (Zpos XH); qden = XH }
+| CQ q0 -> q0
+| CZ z0 -> { qnum = z0; qden = XH }
+| CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2)
+| CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2)
+| CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2)
+| CInv r0 -> qinv (q_of_Rcst r0)
+| COpp r0 -> qopp (q_of_Rcst r0)
+
+type rWitness = q psatz
+
+(** val rWeakChecker : q nFormula list -> q psatz -> bool **)
+
+let rWeakChecker =
+  check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+    qden = XH } qplus qmult qeq_bool qle_bool
+
+(** val rnormalise : q formula -> q nFormula cnf **)
 
-type rWitness = z psatz
+let rnormalise =
+  cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+    qplus qmult qminus qopp qeq_bool
 
-(** val rWeakChecker : z nFormula list -> z psatz -> bool **)
+(** val rnegate : q formula -> q nFormula cnf **)
 
-let rWeakChecker x x0 =
-  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+let rnegate =
+  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
+    qmult qminus qopp qeq_bool
 
-(** val rnormalise : z formula -> z nFormula cnf **)
+(** val runsat : q nFormula -> bool **)
 
-let rnormalise t0 =
-  cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+let runsat =
+  check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool
 
-(** val rnegate : z formula -> z nFormula cnf **)
+(** val rdeduce : q nFormula -> q nFormula -> q nFormula option **)
 
-let rnegate t0 =
-  cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+let rdeduce =
+  nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool
 
-(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **)
+(** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **)
 
 let rTautoChecker f w =
-  tauto_checker rnormalise rnegate rWeakChecker f w
+  tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker
+    (map_bformula (map_Formula q_of_Rcst) f) w
 
diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli
index 3e3ae2c3..bcd61f39 100644
--- a/plugins/micromega/micromega.mli
+++ b/plugins/micromega/micromega.mli
@@ -1,115 +1,848 @@
+type __ = Obj.t
+
 val negb : bool -> bool
 
 type nat =
-  | O
-  | S of nat
+| O
+| S of nat
 
-type comparison =
-  | Eq
-  | Lt
-  | Gt
+val fst : ('a1 * 'a2) -> 'a1
 
-val compOpp : comparison -> comparison
-
-val plus : nat -> nat -> nat
+val snd : ('a1 * 'a2) -> 'a2
 
 val app : 'a1 list -> 'a1 list -> 'a1 list
 
-val nth : nat -> 'a1 list -> 'a1 -> 'a1
-
-val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
-
-type positive =
-  | XI of positive
-  | XO of positive
-  | XH
-
-val psucc : positive -> positive
-
-val pplus : positive -> positive -> positive
-
-val pplus_carry : positive -> positive -> positive
-
-val p_of_succ_nat : nat -> positive
-
-val pdouble_minus_one : positive -> positive
-
-type positive_mask =
-  | IsNul
-  | IsPos of positive
-  | IsNeg
+type comparison =
+| Eq
+| Lt
+| Gt
 
-val pdouble_plus_one_mask : positive_mask -> positive_mask
+val compOpp : comparison -> comparison
 
-val pdouble_mask : positive_mask -> positive_mask
+type compareSpecT =
+| CompEqT
+| CompLtT
+| CompGtT
 
-val pdouble_minus_two : positive -> positive_mask
+val compareSpec2Type : comparison -> compareSpecT
 
-val pminus_mask : positive -> positive -> positive_mask
+type 'a compSpecT = compareSpecT
 
-val pminus_mask_carry : positive -> positive -> positive_mask
+val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT
 
-val pminus : positive -> positive -> positive
+type 'a sig0 =
+  'a
+  (* singleton inductive, whose constructor was exist *)
 
-val pmult : positive -> positive -> positive
+val plus : nat -> nat -> nat
 
-val pcompare : positive -> positive -> comparison -> comparison
+val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1
 
-val psize : positive -> nat
+type positive =
+| XI of positive
+| XO of positive
+| XH
 
 type n =
-  | N0
-  | Npos of positive
-
-val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
+| N0
+| Npos of positive
 
 type z =
-  | Z0
-  | Zpos of positive
-  | Zneg of positive
-
-val zdouble_plus_one : z -> z
-
-val zdouble_minus_one : z -> z
-
-val zdouble : z -> z
-
-val zPminus : positive -> positive -> z
-
-val zplus : z -> z -> z
-
-val zopp : z -> z
-
-val zminus : z -> z -> z
-
-val zmult : z -> z -> z
-
-val zcompare : z -> z -> comparison
-
-val zabs : z -> z
+| Z0
+| Zpos of positive
+| Zneg of positive
+
+module type TotalOrder' = 
+ sig 
+  type t 
+ end
+
+module MakeOrderTac : 
+ functor (O:TotalOrder') ->
+ sig 
+  
+ end
+
+module MaxLogicalProperties : 
+ functor (O:TotalOrder') ->
+ functor (M:sig 
+  val max : O.t -> O.t -> O.t
+ end) ->
+ sig 
+  module T : 
+   sig 
+    
+   end
+ end
+
+module Pos : 
+ sig 
+  type t = positive
+  
+  val succ : positive -> positive
+  
+  val add : positive -> positive -> positive
+  
+  val add_carry : positive -> positive -> positive
+  
+  val pred_double : positive -> positive
+  
+  val pred : positive -> positive
+  
+  val pred_N : positive -> n
+  
+  type mask =
+  | IsNul
+  | IsPos of positive
+  | IsNeg
+  
+  val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
+  
+  val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
+  
+  val succ_double_mask : mask -> mask
+  
+  val double_mask : mask -> mask
+  
+  val double_pred_mask : positive -> mask
+  
+  val pred_mask : mask -> mask
+  
+  val sub_mask : positive -> positive -> mask
+  
+  val sub_mask_carry : positive -> positive -> mask
+  
+  val sub : positive -> positive -> positive
+  
+  val mul : positive -> positive -> positive
+  
+  val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
+  
+  val pow : positive -> positive -> positive
+  
+  val div2 : positive -> positive
+  
+  val div2_up : positive -> positive
+  
+  val size_nat : positive -> nat
+  
+  val size : positive -> positive
+  
+  val compare_cont : positive -> positive -> comparison -> comparison
+  
+  val compare : positive -> positive -> comparison
+  
+  val min : positive -> positive -> positive
+  
+  val max : positive -> positive -> positive
+  
+  val eqb : positive -> positive -> bool
+  
+  val leb : positive -> positive -> bool
+  
+  val ltb : positive -> positive -> bool
+  
+  val sqrtrem_step :
+    (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
+    positive * mask
+  
+  val sqrtrem : positive -> positive * mask
+  
+  val sqrt : positive -> positive
+  
+  val gcdn : nat -> positive -> positive -> positive
+  
+  val gcd : positive -> positive -> positive
+  
+  val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
+  
+  val ggcd : positive -> positive -> positive * (positive * positive)
+  
+  val coq_Nsucc_double : n -> n
+  
+  val coq_Ndouble : n -> n
+  
+  val coq_lor : positive -> positive -> positive
+  
+  val coq_land : positive -> positive -> n
+  
+  val ldiff : positive -> positive -> n
+  
+  val coq_lxor : positive -> positive -> n
+  
+  val shiftl_nat : positive -> nat -> positive
+  
+  val shiftr_nat : positive -> nat -> positive
+  
+  val shiftl : positive -> n -> positive
+  
+  val shiftr : positive -> n -> positive
+  
+  val testbit_nat : positive -> nat -> bool
+  
+  val testbit : positive -> n -> bool
+  
+  val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
+  
+  val to_nat : positive -> nat
+  
+  val of_nat : nat -> positive
+  
+  val of_succ_nat : nat -> positive
+ end
+
+module Coq_Pos : 
+ sig 
+  module Coq__1 : sig 
+   type t = positive
+  end
+  type t = Coq__1.t
+  
+  val succ : positive -> positive
+  
+  val add : positive -> positive -> positive
+  
+  val add_carry : positive -> positive -> positive
+  
+  val pred_double : positive -> positive
+  
+  val pred : positive -> positive
+  
+  val pred_N : positive -> n
+  
+  type mask = Pos.mask =
+  | IsNul
+  | IsPos of positive
+  | IsNeg
+  
+  val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
+  
+  val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
+  
+  val succ_double_mask : mask -> mask
+  
+  val double_mask : mask -> mask
+  
+  val double_pred_mask : positive -> mask
+  
+  val pred_mask : mask -> mask
+  
+  val sub_mask : positive -> positive -> mask
+  
+  val sub_mask_carry : positive -> positive -> mask
+  
+  val sub : positive -> positive -> positive
+  
+  val mul : positive -> positive -> positive
+  
+  val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
+  
+  val pow : positive -> positive -> positive
+  
+  val div2 : positive -> positive
+  
+  val div2_up : positive -> positive
+  
+  val size_nat : positive -> nat
+  
+  val size : positive -> positive
+  
+  val compare_cont : positive -> positive -> comparison -> comparison
+  
+  val compare : positive -> positive -> comparison
+  
+  val min : positive -> positive -> positive
+  
+  val max : positive -> positive -> positive
+  
+  val eqb : positive -> positive -> bool
+  
+  val leb : positive -> positive -> bool
+  
+  val ltb : positive -> positive -> bool
+  
+  val sqrtrem_step :
+    (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
+    positive * mask
+  
+  val sqrtrem : positive -> positive * mask
+  
+  val sqrt : positive -> positive
+  
+  val gcdn : nat -> positive -> positive -> positive
+  
+  val gcd : positive -> positive -> positive
+  
+  val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
+  
+  val ggcd : positive -> positive -> positive * (positive * positive)
+  
+  val coq_Nsucc_double : n -> n
+  
+  val coq_Ndouble : n -> n
+  
+  val coq_lor : positive -> positive -> positive
+  
+  val coq_land : positive -> positive -> n
+  
+  val ldiff : positive -> positive -> n
+  
+  val coq_lxor : positive -> positive -> n
+  
+  val shiftl_nat : positive -> nat -> positive
+  
+  val shiftr_nat : positive -> nat -> positive
+  
+  val shiftl : positive -> n -> positive
+  
+  val shiftr : positive -> n -> positive
+  
+  val testbit_nat : positive -> nat -> bool
+  
+  val testbit : positive -> n -> bool
+  
+  val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
+  
+  val to_nat : positive -> nat
+  
+  val of_nat : nat -> positive
+  
+  val of_succ_nat : nat -> positive
+  
+  val eq_dec : positive -> positive -> bool
+  
+  val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
+  
+  val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
+  
+  type coq_PeanoView =
+  | PeanoOne
+  | PeanoSucc of positive * coq_PeanoView
+  
+  val coq_PeanoView_rect :
+    'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
+    coq_PeanoView -> 'a1
+  
+  val coq_PeanoView_rec :
+    'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
+    coq_PeanoView -> 'a1
+  
+  val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView
+  
+  val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView
+  
+  val peanoView : positive -> coq_PeanoView
+  
+  val coq_PeanoView_iter :
+    'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1
+  
+  val switch_Eq : comparison -> comparison -> comparison
+  
+  val mask2cmp : mask -> comparison
+  
+  module T : 
+   sig 
+    
+   end
+  
+  module ORev : 
+   sig 
+    type t = Coq__1.t
+   end
+  
+  module MRev : 
+   sig 
+    val max : t -> t -> t
+   end
+  
+  module MPRev : 
+   sig 
+    module T : 
+     sig 
+      
+     end
+   end
+  
+  module P : 
+   sig 
+    val max_case_strong :
+      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val max_case :
+      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val max_dec : t -> t -> bool
+    
+    val min_case_strong :
+      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val min_case :
+      t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val min_dec : t -> t -> bool
+   end
+  
+  val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val max_case : t -> t -> 'a1 -> 'a1 -> 'a1
+  
+  val max_dec : t -> t -> bool
+  
+  val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val min_case : t -> t -> 'a1 -> 'a1 -> 'a1
+  
+  val min_dec : t -> t -> bool
+ end
+
+module N : 
+ sig 
+  type t = n
+  
+  val zero : n
+  
+  val one : n
+  
+  val two : n
+  
+  val succ_double : n -> n
+  
+  val double : n -> n
+  
+  val succ : n -> n
+  
+  val pred : n -> n
+  
+  val succ_pos : n -> positive
+  
+  val add : n -> n -> n
+  
+  val sub : n -> n -> n
+  
+  val mul : n -> n -> n
+  
+  val compare : n -> n -> comparison
+  
+  val eqb : n -> n -> bool
+  
+  val leb : n -> n -> bool
+  
+  val ltb : n -> n -> bool
+  
+  val min : n -> n -> n
+  
+  val max : n -> n -> n
+  
+  val div2 : n -> n
+  
+  val even : n -> bool
+  
+  val odd : n -> bool
+  
+  val pow : n -> n -> n
+  
+  val log2 : n -> n
+  
+  val size : n -> n
+  
+  val size_nat : n -> nat
+  
+  val pos_div_eucl : positive -> n -> n * n
+  
+  val div_eucl : n -> n -> n * n
+  
+  val div : n -> n -> n
+  
+  val modulo : n -> n -> n
+  
+  val gcd : n -> n -> n
+  
+  val ggcd : n -> n -> n * (n * n)
+  
+  val sqrtrem : n -> n * n
+  
+  val sqrt : n -> n
+  
+  val coq_lor : n -> n -> n
+  
+  val coq_land : n -> n -> n
+  
+  val ldiff : n -> n -> n
+  
+  val coq_lxor : n -> n -> n
+  
+  val shiftl_nat : n -> nat -> n
+  
+  val shiftr_nat : n -> nat -> n
+  
+  val shiftl : n -> n -> n
+  
+  val shiftr : n -> n -> n
+  
+  val testbit_nat : n -> nat -> bool
+  
+  val testbit : n -> n -> bool
+  
+  val to_nat : n -> nat
+  
+  val of_nat : nat -> n
+  
+  val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1
+  
+  val eq_dec : n -> n -> bool
+  
+  val discr : n -> positive option
+  
+  val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
+  
+  val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
+  
+  val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
+  
+  val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
+  
+  module BootStrap : 
+   sig 
+    
+   end
+  
+  val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
+  
+  module OrderElts : 
+   sig 
+    type t = n
+   end
+  
+  module OrderTac : 
+   sig 
+    
+   end
+  
+  module NZPowP : 
+   sig 
+    
+   end
+  
+  module NZSqrtP : 
+   sig 
+    
+   end
+  
+  val sqrt_up : n -> n
+  
+  val log2_up : n -> n
+  
+  module NZDivP : 
+   sig 
+    
+   end
+  
+  val lcm : n -> n -> n
+  
+  val b2n : bool -> n
+  
+  val setbit : n -> n -> n
+  
+  val clearbit : n -> n -> n
+  
+  val ones : n -> n
+  
+  val lnot : n -> n -> n
+  
+  module T : 
+   sig 
+    
+   end
+  
+  module ORev : 
+   sig 
+    type t = n
+   end
+  
+  module MRev : 
+   sig 
+    val max : n -> n -> n
+   end
+  
+  module MPRev : 
+   sig 
+    module T : 
+     sig 
+      
+     end
+   end
+  
+  module P : 
+   sig 
+    val max_case_strong :
+      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val max_case :
+      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val max_dec : n -> n -> bool
+    
+    val min_case_strong :
+      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val min_case :
+      n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val min_dec : n -> n -> bool
+   end
+  
+  val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val max_case : n -> n -> 'a1 -> 'a1 -> 'a1
+  
+  val max_dec : n -> n -> bool
+  
+  val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val min_case : n -> n -> 'a1 -> 'a1 -> 'a1
+  
+  val min_dec : n -> n -> bool
+ end
 
-val zmax : z -> z -> z
+val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
 
-val zle_bool : z -> z -> bool
+val nth : nat -> 'a1 list -> 'a1 -> 'a1
 
-val zge_bool : z -> z -> bool
+val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
 
-val zgt_bool : z -> z -> bool
+val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1
+
+module Z : 
+ sig 
+  type t = z
+  
+  val zero : z
+  
+  val one : z
+  
+  val two : z
+  
+  val double : z -> z
+  
+  val succ_double : z -> z
+  
+  val pred_double : z -> z
+  
+  val pos_sub : positive -> positive -> z
+  
+  val add : z -> z -> z
+  
+  val opp : z -> z
+  
+  val succ : z -> z
+  
+  val pred : z -> z
+  
+  val sub : z -> z -> z
+  
+  val mul : z -> z -> z
+  
+  val pow_pos : z -> positive -> z
+  
+  val pow : z -> z -> z
+  
+  val compare : z -> z -> comparison
+  
+  val sgn : z -> z
+  
+  val leb : z -> z -> bool
+  
+  val geb : z -> z -> bool
+  
+  val ltb : z -> z -> bool
+  
+  val gtb : z -> z -> bool
+  
+  val eqb : z -> z -> bool
+  
+  val max : z -> z -> z
+  
+  val min : z -> z -> z
+  
+  val abs : z -> z
+  
+  val abs_nat : z -> nat
+  
+  val abs_N : z -> n
+  
+  val to_nat : z -> nat
+  
+  val to_N : z -> n
+  
+  val of_nat : nat -> z
+  
+  val of_N : n -> z
+  
+  val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1
+  
+  val pos_div_eucl : positive -> z -> z * z
+  
+  val div_eucl : z -> z -> z * z
+  
+  val div : z -> z -> z
+  
+  val modulo : z -> z -> z
+  
+  val quotrem : z -> z -> z * z
+  
+  val quot : z -> z -> z
+  
+  val rem : z -> z -> z
+  
+  val even : z -> bool
+  
+  val odd : z -> bool
+  
+  val div2 : z -> z
+  
+  val quot2 : z -> z
+  
+  val log2 : z -> z
+  
+  val sqrtrem : z -> z * z
+  
+  val sqrt : z -> z
+  
+  val gcd : z -> z -> z
+  
+  val ggcd : z -> z -> z * (z * z)
+  
+  val testbit : z -> z -> bool
+  
+  val shiftl : z -> z -> z
+  
+  val shiftr : z -> z -> z
+  
+  val coq_lor : z -> z -> z
+  
+  val coq_land : z -> z -> z
+  
+  val ldiff : z -> z -> z
+  
+  val coq_lxor : z -> z -> z
+  
+  val eq_dec : z -> z -> bool
+  
+  module BootStrap : 
+   sig 
+    
+   end
+  
+  module OrderElts : 
+   sig 
+    type t = z
+   end
+  
+  module OrderTac : 
+   sig 
+    
+   end
+  
+  val sqrt_up : z -> z
+  
+  val log2_up : z -> z
+  
+  module NZDivP : 
+   sig 
+    
+   end
+  
+  module Quot2Div : 
+   sig 
+    val div : z -> z -> z
+    
+    val modulo : z -> z -> z
+   end
+  
+  module NZQuot : 
+   sig 
+    
+   end
+  
+  val lcm : z -> z -> z
+  
+  val b2z : bool -> z
+  
+  val setbit : z -> z -> z
+  
+  val clearbit : z -> z -> z
+  
+  val lnot : z -> z
+  
+  val ones : z -> z
+  
+  module T : 
+   sig 
+    
+   end
+  
+  module ORev : 
+   sig 
+    type t = z
+   end
+  
+  module MRev : 
+   sig 
+    val max : z -> z -> z
+   end
+  
+  module MPRev : 
+   sig 
+    module T : 
+     sig 
+      
+     end
+   end
+  
+  module P : 
+   sig 
+    val max_case_strong :
+      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val max_case :
+      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val max_dec : z -> z -> bool
+    
+    val min_case_strong :
+      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
+      'a1
+    
+    val min_case :
+      z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
+    
+    val min_dec : z -> z -> bool
+   end
+  
+  val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val max_case : z -> z -> 'a1 -> 'a1 -> 'a1
+  
+  val max_dec : z -> z -> bool
+  
+  val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+  
+  val min_case : z -> z -> 'a1 -> 'a1 -> 'a1
+  
+  val min_dec : z -> z -> bool
+ end
 
 val zeq_bool : z -> z -> bool
 
-val n_of_nat : nat -> n
-
-val zdiv_eucl_POS : positive -> z -> z  *  z
-
-val zdiv_eucl : z -> z -> z  *  z
-
-val zdiv : z -> z -> z
-
 type 'c pol =
-  | Pc of 'c
-  | Pinj of positive * 'c pol
-  | PX of 'c pol * positive * 'c pol
+| Pc of 'c
+| Pinj of positive * 'c pol
+| PX of 'c pol * positive * 'c pol
 
 val p0 : 'a1 -> 'a1 pol
 
@@ -117,6 +850,8 @@ val p1 : 'a1 -> 'a1 pol
 
 val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
 
+val mkPinj : positive -> 'a1 pol -> 'a1 pol
+
 val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
 
 val mkPX :
@@ -177,13 +912,13 @@ val psquare :
   bool) -> 'a1 pol -> 'a1 pol
 
 type 'c pExpr =
-  | PEc of 'c
-  | PEX of positive
-  | PEadd of 'c pExpr * 'c pExpr
-  | PEsub of 'c pExpr * 'c pExpr
-  | PEmul of 'c pExpr * 'c pExpr
-  | PEopp of 'c pExpr
-  | PEpow of 'c pExpr * n
+| PEc of 'c
+| PEX of positive
+| PEadd of 'c pExpr * 'c pExpr
+| PEsub of 'c pExpr * 'c pExpr
+| PEmul of 'c pExpr * 'c pExpr
+| PEopp of 'c pExpr
+| PEpow of 'c pExpr * n
 
 val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
 
@@ -200,14 +935,16 @@ val norm_aux :
   'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
 
 type 'a bFormula =
-  | TT
-  | FF
-  | X
-  | A of 'a
-  | Cj of 'a bFormula * 'a bFormula
-  | D of 'a bFormula * 'a bFormula
-  | N of 'a bFormula
-  | I of 'a bFormula * 'a bFormula
+| TT
+| FF
+| X
+| A of 'a
+| Cj of 'a bFormula * 'a bFormula
+| D of 'a bFormula * 'a bFormula
+| N of 'a bFormula
+| I of 'a bFormula * 'a bFormula
+
+val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula
 
 type 'term' clause = 'term' list
 
@@ -217,41 +954,65 @@ val tt : 'a1 cnf
 
 val ff : 'a1 cnf
 
-val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf
+val add_term :
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1
+  clause option
 
-val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
+val or_clause :
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause ->
+  'a1 clause option
+
+val or_clause_cnf :
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1
+  cnf
+
+val or_cnf :
+  ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
+  cnf
 
 val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
 
 val xcnf :
-  ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
+  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
+  'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
 
 val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
 
 val tauto_checker :
-  ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
-  bFormula -> 'a3 list -> bool
+  ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
+  'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool
+
+val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
+
+val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
 
 type 'c polC = 'c pol
 
 type op1 =
-  | Equal
-  | NonEqual
-  | Strict
-  | NonStrict
+| Equal
+| NonEqual
+| Strict
+| NonStrict
+
+type 'c nFormula = 'c polC * op1
 
-type 'c nFormula = 'c polC  *  op1
+val opMult : op1 -> op1 -> op1 option
 
 val opAdd : op1 -> op1 -> op1 option
 
 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
+| 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 map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option
+
+val map_option2 :
+  ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option
 
 val pexpr_times_nformula :
   'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
@@ -278,14 +1039,14 @@ val check_normalised_formulas :
   bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
 
 type op2 =
-  | OpEq
-  | OpNEq
-  | OpLe
-  | OpGe
-  | OpLt
-  | OpGt
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt
 
-type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
 
 val flhs : 'a1 formula -> 'a1 pExpr
 
@@ -329,6 +1090,10 @@ val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
 
 val denorm : 'a1 pol -> 'a1 pExpr
 
+val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr
+
+val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula
+
 val simpl_cone :
   'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
   'a1 psatz
@@ -357,18 +1122,12 @@ 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
-  | Node of 'a t * 'a * 'a t
+type 'a t0 =
+| Empty
+| Leaf of 'a
+| Node of 'a t0 * 'a * 'a t0
 
-val find : 'a1 -> 'a1 t -> positive -> 'a1
+val find : 'a1 -> 'a1 t0 -> positive -> 'a1
 
 type zWitness = z psatz
 
@@ -388,38 +1147,40 @@ val xnegate0 : z formula -> z nFormula list
 
 val negate : z formula -> z nFormula cnf
 
+val zunsat : z nFormula -> bool
+
+val zdeduce : z nFormula -> z nFormula -> z nFormula option
+
 val ceiling : z -> z -> z
 
 type zArithProof =
-  | DoneProof
-  | RatProof of zWitness * zArithProof
-  | CutProof of zWitness * zArithProof
-  | EnumProof of zWitness * zWitness * zArithProof list
+| DoneProof
+| RatProof of zWitness * zArithProof
+| CutProof of zWitness * zArithProof
+| EnumProof of zWitness * zWitness * zArithProof list
 
 val zgcdM : z -> z -> z
 
-val zgcd_pol : z polC -> z  *  z
+val zgcd_pol : z polC -> z * z
 
 val zdiv_pol : z polC -> z -> z polC
 
-val makeCuttingPlane : z polC -> z polC  *  z
+val makeCuttingPlane : z polC -> z polC * z
 
-val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option
+val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option
 
-val nformula_of_cutting_plane : ((z polC  *  z)  *  op1) -> z nFormula
+val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula
 
 val is_pol_Z0 : z polC -> bool
 
 val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option
 
-val check_inconsistent0 : z nFormula -> bool
+val valid_cut_sign : op1 -> bool
 
 val zChecker : z nFormula list -> zArithProof -> bool
 
 val zTautoChecker : z formula bFormula -> zArithProof list -> bool
 
-val n_of_Z : z -> n
-
 type qWitness = q psatz
 
 val qWeakChecker : q nFormula list -> q psatz -> bool
@@ -428,15 +1189,36 @@ val qnormalise : q formula -> q nFormula cnf
 
 val qnegate : q formula -> q nFormula cnf
 
+val qunsat : q nFormula -> bool
+
+val qdeduce : q nFormula -> q nFormula -> q nFormula option
+
 val qTautoChecker : q formula bFormula -> qWitness list -> bool
 
-type rWitness = z psatz
+type rcst =
+| C0
+| C1
+| CQ of q
+| CZ of z
+| CPlus of rcst * rcst
+| CMinus of rcst * rcst
+| CMult of rcst * rcst
+| CInv of rcst
+| COpp of rcst
+
+val q_of_Rcst : rcst -> q
+
+type rWitness = q psatz
+
+val rWeakChecker : q nFormula list -> q psatz -> bool
+
+val rnormalise : q formula -> q nFormula cnf
 
-val rWeakChecker : z nFormula list -> z psatz -> bool
+val rnegate : q formula -> q nFormula cnf
 
-val rnormalise : z formula -> z nFormula cnf
+val runsat : q nFormula -> bool
 
-val rnegate : z formula -> z nFormula cnf
+val rdeduce : q nFormula -> q nFormula -> q nFormula option
 
-val rTautoChecker : z formula bFormula -> rWitness list -> bool
+val rTautoChecker : rcst formula bFormula -> rWitness list -> bool
 
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib
index debc296e..f53a9e37 100644
--- a/plugins/micromega/micromega_plugin.mllib
+++ b/plugins/micromega/micromega_plugin.mllib
@@ -1,6 +1,7 @@
 Sos_types
 Mutils
 Micromega
+Polynomial
 Mfourier
 Certificate
 Persistent_cache
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index ef23b912..c4dbf6af 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,23 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
+(* ** Utility functions **                                              *)
+(*                                                                      *)
+(* - Modules CoqToCaml, CamlToCoq                                       *)
+(* - Modules Cmp, Tag, TagSet                                           *)
+(*                                                                      *)
 (*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
 (*                                                                      *)
 (************************************************************************)
 
 let debug = false
 
+let rec pp_list f o l =
+  match l with
+    | [] -> ()
+    | e::l -> f o e ; output_string o ";" ; pp_list f o l
+
+
 let finally f rst =
   try
     let res = f () in
@@ -46,12 +57,16 @@ let iteri f l =
    | 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 all_sym_pairs f l = 
+  let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in
+
+  let rec xpairs acc l = 
+    match l with
+      | [] -> acc
+      | e::l -> xpairs (pair_with acc e l) l in
+    xpairs [] l
+
+
 
 let rec map3 f l1 l2 l3 =
   match l1 , l2 ,l3 with
@@ -59,8 +74,6 @@ let rec map3 f l1 l2 l3 =
     | 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
@@ -69,8 +82,6 @@ let rec is_sublist l1 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"
@@ -91,6 +102,18 @@ let interval n m =
   in
   interval_n ([],m)
 
+let extract pred l = 
+  List.fold_left (fun (fd,sys) e -> 
+		    match fd with
+		    | None -> 
+			begin
+			  match pred e with
+			  | None -> fd, e::sys
+			  | Some v -> Some(v,e) , sys
+			end
+		    |  _   -> (fd, e::sys)
+		 ) (None,[]) l
+
 open Num
 open Big_int
 
@@ -100,7 +123,6 @@ let ppcm x y =
  let y' = div_big_int y g in
   mult_big_int g (mult_big_int x' y')
 
-
 let denominator = function
  | Int _ | Big_int _ -> unit_big_int
  | Ratio r -> Ratio.denominator_ratio r
@@ -125,8 +147,6 @@ let rec gcd_list l =
   if compare_big_int res zero_big_int = 0
   then unit_big_int else res
 
-
-
 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)
@@ -140,7 +160,6 @@ let mapi f l =
    | e::l ->  (f e i)::(xmapi (i+1) l) in
   xmapi 0 l
 
-
 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 *)
@@ -178,6 +197,9 @@ let  select_pos lpos l =
 	  else xselect (i+1) lpos l in
   xselect 0 lpos l
 
+(**
+  * MODULE: Coq to Caml data-structure mappings
+  *)
 
 module CoqToCaml =
 struct
@@ -194,20 +216,17 @@ struct
    | XI p -> 1+ 2*(positive p)
    | XO p -> 2*(positive p)
 
-
  let n nt =
   match nt with
    | N0 -> 0
    | Npos p -> positive p
 
-
  let rec index i = (* Swap left-right ? *)
   match i with
    | XH -> 1
    | XI i -> 1+(2*(index i))
    | XO i -> 2*(index i)
 
-
  let z x =
   match x with
    | Z0 -> 0
@@ -222,14 +241,12 @@ struct
    | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
    | XO p -> (mult_int_big_int 2 (positive_big_int p))
 
-
  let z_big_int x =
   match x with
    | Z0 -> zero_big_int
    | Zpos p -> (positive_big_int p)
    | Zneg p -> minus_big_int (positive_big_int p)
 
-
  let num x = Num.Big_int (z_big_int x)
 
  let q_to_num {qnum = x ; qden = y} =
@@ -238,6 +255,10 @@ struct
 end
 
 
+(**
+  * MODULE: Caml to Coq data-structure mappings
+  *)
+
 module CamlToCoq =
 struct
  open Micromega
@@ -252,7 +273,7 @@ struct
   else if n land 1 = 1 then XI (positive (n lsr 1))
   else  XO (positive (n lsr 1))
 
- let  n nt =
+ let n nt =
   if nt < 0
   then assert false
   else if nt = 0 then N0
@@ -266,8 +287,7 @@ struct
 
  let idx n =
   (*a.k.a path_of_int *)
-  (* returns the list of digits of n in reverse order with
-     initial 1 removed *)
+  (* returns the list of digits of n in reverse order with initial 1 removed *)
   let rec digits_of_int n =
    if n=1 then []
    else (n mod 2 = 1)::(digits_of_int (n lsr 1))
@@ -309,6 +329,11 @@ struct
 
 end
 
+(**
+  * MODULE: Comparisons on lists: by evaluating the elements in a single list,
+  * between two lists given an ordering, and using a hash computation
+  *)
+
 module Cmp =
 struct
 
@@ -317,7 +342,7 @@ struct
    | [] -> 0 (* Equal *)
    | f::l ->
       let cmp = f () in
-       if cmp = 0 	then  compare_lexical l else cmp
+       if cmp = 0 then compare_lexical l else cmp
 
  let rec compare_list cmp l1 l2 =
   match l1 , l2 with
@@ -328,36 +353,59 @@ struct
       let c = cmp e1 e2 in
        if c = 0 then compare_list cmp l1 l2 else c
 
+(**
+  * hash_list takes a hash function and a list, and computes an integer which
+  * is the hash value of the list.
+  *)
  let hash_list hash l =
   let rec _hash_list l h =
    match l with
     | []  -> h lxor (Hashtbl.hash [])
-    | e::l -> _hash_list l   ((hash e)  lxor h) in
+    | e::l -> _hash_list l ((hash e) lxor h) 
+  in _hash_list l 0
 
-   _hash_list  l 0
 end
 
+(**
+  * MODULE: Labels for atoms in propositional formulas. 
+  * Tags are used to identify unused atoms in CNFs, and propagate them back to
+  * the original formula. The translation back to Coq then ignores these
+  * superfluous items, which speeds the translation up a bit.
+  *)
+
 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: Ordered sets of tags.
+  *)
+
 module TagSet = Set.Make(Tag)
 
+(**
+  * Forking routine, plumbing the appropriate pipes where needed.
+  *)
 
 let command exe_path args vl =
   (* creating pipes for stdin, stdout, stderr *)
@@ -365,7 +413,6 @@ let command exe_path args vl =
   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
 
@@ -378,24 +425,20 @@ let command exe_path args vl =
     let _pid,status = Unix.waitpid [] pid in
 
       finally
+        (* Recover the result *)
 	(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)
+		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))
+	    | Unix.WSTOPPED i  -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+        (* Cleanup  *)
 	(fun () ->
-	  (* Cleanup  *)
-	  List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write]
-	)
-
-
-
-
-
+	  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 *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index b48fa36b..ed9fdcea 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.ml
@@ -1,14 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 (*                                                                      *)
-(* A persistent hashtable                                               *)
+(*  A persistent hashtable                                              *)
 (*                                                                      *)
-(*  Frédéric Besson (Inria Rennes) 2009                                 *)
+(*  Frédéric Besson (Inria Rennes) 2009-2011                            *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -20,8 +20,7 @@ module type PHashtable =
 
     val create : int -> string -> 'a t
     (** [create i f] creates an empty persistent table
-	with initial size i
-	associated with file [f] *)
+	with initial size i associated with file [f] *)
 
 
     val open_in : string -> 'a t
@@ -40,7 +39,7 @@ module type PHashtable =
     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 *)
+	i.e, 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.
@@ -52,20 +51,17 @@ open Hashtbl
 
 module PHashtable(Key:HashedType) : PHashtable with type key = Key.t  =
 struct
+  open Unix
 
   type key = Key.t
 
   module Table = Hashtbl.Make(Key)
 
-
-
   exception InvalidTableFormat
   exception UnboundTable
 
-
   type mode = Closed | Open
 
-
   type 'a t =
       {
 	outch : out_channel ;
@@ -75,8 +71,9 @@ struct
 
 
 let create i f =
+  let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
   {
-    outch = open_out_bin f ;
+    outch = out_channel_of_descr (openfile f flags 0o666);
     status = Open ;
     htbl = Table.create i
   }
@@ -98,10 +95,20 @@ let read_key_elem inch =
     | End_of_file -> None
     |    _        -> raise InvalidTableFormat
 
+
+let unlock fd = 
+  try 
+    let pos = lseek fd 0 SEEK_CUR in
+    ignore (lseek fd 0 SEEK_SET) ; 
+    lockf fd F_ULOCK 0 ; 
+  ignore (lseek fd pos SEEK_SET)
+  with exc -> failwith (Printexc.to_string exc)
+
 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 flags = [O_RDONLY ; O_CREAT] in
+  let finch = openfile f flags 0o666 in
+  let inch  = in_channel_of_descr finch in
+  let htbl = Table.create 100 in
 
   let rec xload () =
     match read_key_elem inch with
@@ -109,27 +116,38 @@ let open_in f =
       | Some (key,elem) ->
 	  Table.add htbl key elem ;
 	  xload () in
-
     try
-      finally (fun () -> xload () ) (fun () -> close_in inch) ;
+      (* Locking of the (whole) file while reading *)
+      lockf finch F_RLOCK 0 ; 
+      finally 
+	(fun () -> xload () ) 
+	(fun () -> 
+	   unlock finch ;
+	   close_in_noerr inch ; 
+	) ;
       {
-	outch = begin
-	  let flags = [Open_append;Open_binary;Open_creat] in
-	    open_out_gen flags 0o666 f
-	end ;
+	outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
 	status = Open ;
 	htbl = htbl
       }
     with InvalidTableFormat ->
       (* Try to keep as many entries as possible *)
       begin
-	let flags = [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
-	  }
+	let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
+	let out =  (openfile f flags 0o666) in
+	let outch = out_channel_of_descr out in
+	  lockf out F_LOCK 0 ; 
+	  (try 
+	    Table.iter 
+	      (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+	    flush outch ; 
+	  with  _ -> () )
+	    ;
+	    unlock out ; 
+	    { outch = outch ;
+	      status = Open ;
+	      htbl   = htbl
+	    }
       end
 
 
@@ -147,9 +165,14 @@ let add t k e =
     if status = Closed
     then raise UnboundTable
     else
+      let fd = descr_of_out_channel outch in
       begin
 	Table.add tbl k e ;
-	Marshal.to_channel outch (k,e) [Marshal.No_sharing]
+	lockf fd F_LOCK 0 ;
+	ignore (lseek fd 0 SEEK_END) ; 
+	Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
+	flush outch ;
+	unlock fd
       end
 
 let find t k =
diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml
new file mode 100644
index 00000000..14d312a5
--- /dev/null
+++ b/plugins/micromega/polynomial.ml
@@ -0,0 +1,739 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-20011                            *)
+(*                                                                      *)
+(************************************************************************)
+
+open Num
+module Utils = Mutils
+open Utils
+
+type var = int
+
+
+let (<+>) = add_num
+let (<->) = minus_num
+let (<*>) = mult_num
+
+
+module Monomial :
+sig
+ type t
+ val const : t
+ val is_const : t -> bool
+ val var : var -> t
+ val is_var : t -> bool
+ val find : var -> t -> int
+ val mult : var -> t -> t
+ val prod : t -> t -> t
+ val exp  : t -> int -> t
+ val div  : t -> t -> t *  int
+ val compare : t -> t -> int
+ val pp : out_channel -> t -> unit
+ val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
+ val sqrt : t -> t option 
+end
+ =
+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
+
+ let pp o m = Map.iter 
+   (fun k v -> 
+      if v = 1 then Printf.fprintf o "x%i." k
+      else     Printf.fprintf o "x%i^%i." k v) m
+
+
+ (* The monomial that corresponds to a constant *)
+ let const = Map.empty
+
+ let sum_degree m = Map.fold (fun _ n s -> s + n) m 0
+
+ (* Total ordering of monomials *)
+ let compare: t -> t -> int = 
+   fun m1 m2 -> 
+     let s1 = sum_degree m1 
+     and s2 = sum_degree m2 in
+       if s1 = s2 then Map.compare Pervasives.compare m1 m2
+       else Pervasives.compare s1 s2
+
+ let is_const m = (m = Map.empty)
+  
+ (* The monomial 'x' *)
+ let var x = Map.add x 1 Map.empty
+
+ let is_var m = 
+   try
+     not (Map.fold (fun _ i fk -> 
+		 if fk = true (* first key *)
+		 then 
+		   if i = 1 then false
+		   else raise Not_found
+		 else raise Not_found) m true)
+   with Not_found -> false
+
+ let sqrt m = 
+   if is_const m then None
+   else
+     try 
+       Some (Map.fold (fun v i acc ->
+			 let i' = i / 2 in
+			   if i mod 2 = 0
+			   then add v i' m
+			   else raise Not_found) m const)
+     with Not_found -> None
+
+ (* 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
+
+
+ let exp m n =
+   let rec exp acc n = 
+     if n = 0 then acc
+     else  exp (prod acc m) (n - 1) in
+
+     exp const n
+
+
+ (*  [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *)
+ let div m1 m2 =
+   let n = fold (fun x i n -> let i' = find x m1 in 
+		     let nx = i' / i in
+		       min n nx) m2 max_int in
+
+   let mr = fold (fun x i' m -> 
+		    let i = find x m2 in
+		    let ir = i' - i * n in
+		      if ir = 0 then m
+		      else add x ir m) m1 empty in
+     (mr,n)
+
+
+ let fold = fold
+
+end
+
+module Poly :
+ (* A polynomial is a map of monomials *)
+ (* 
+    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.
+ *)
+sig
+ type t
+ val get : Monomial.t -> t -> num
+ val variable : var -> t
+ val add : Monomial.t -> num -> t -> t
+ val constant : num -> t
+ val mult : Monomial.t -> num -> t -> t
+ val product : t -> t -> t
+ val addition : t -> t -> t
+ val uminus : t -> t
+ 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
+ val is_linear : t -> bool
+end =
+struct
+ (*normalisation bug : 0*x ... *)
+ module P = Map.Make(Monomial)
+ open P
+
+ type t = num P.t
+
+ let pp o p = P.iter 
+   (fun k v -> 
+	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  
+
+ (* Get the coefficient of monomial mn *)
+ 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
+
+ (* The addition of a monomial *)
+
+ let add : Monomial.t -> num -> t -> t =
+  fun mn v p -> 
+    if sign_num v = 0 then p
+    else
+      let vl = (get mn p) <+> v in
+	if sign_num vl = 0 then
+	  remove mn p
+	else add mn vl p
+
+
+ (** 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 -> 
+    if sign_num v = 0 
+    then constant (Int 0)
+    else
+      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 -> 
+   fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
+
+
+ let uminus : t -> t =
+  fun p -> map (fun v -> minus_num v) p
+
+ 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
+
+ let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true
+
+(* let is_linear p = 
+   let res = is_linear p in
+     Printf.printf "is_linear %a = %b\n" pp p res ; res
+*)
+end
+
+
+module Vect =
+  struct
+    (** [t] is the type of vectors.
+	A vector [(x1,v1) ; ... ; (xn,vn)] is such that:
+	- variables indexes are ordered (x1 <c ... < 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 rec add v1 v2  =
+      match v1 , v2 with
+	| (x1,n1)::v1' , (x2,n2)::v2' ->
+	    if x1 = x2
+	    then
+	      let n' = n1  +/ n2 in
+		if n' =/ Int 0 then add v1' v2'
+		else
+		  let res = add v1' v2'  in
+		    (x1,n') ::res
+	    else if x1 < x2
+	    then let res = add v1' v2   in
+	      (x1, n1)::res
+	    else let res = add v1 v2'  in
+	      (x2, n2)::res
+	|  [] , [] -> []
+	|  [] ,  _ ->  v2
+	|  _  , [] ->  v1 
+
+
+
+
+    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
+
+type vector = Vect.t
+
+type cstr_compat = {coeffs : vector ; op : op ; cst : num}
+and op = |Eq | Ge
+
+let string_of_op = function Eq -> "=" | Ge -> ">="
+
+let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = 
+  Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst)
+
+let opMult o1 o2 = 
+  match o1, o2 with
+    | Eq , Eq -> Eq
+    | Eq , Ge | Ge , Eq -> Ge
+    | Ge , Ge -> Ge
+
+let opAdd o1 o2 =
+  match o1 , o2 with
+    | Eq , _ | _ , Eq -> Eq
+    | Ge , Ge -> Ge
+
+
+
+
+open Big_int
+
+type index = int
+
+type prf_rule = 
+  | Hyp of int 
+  | Def of int
+  | Cst  of big_int
+  | Zero
+  | Square of (Vect.t * num) 
+  | MulC of (Vect.t * num) * prf_rule 
+  | Gcd of big_int * prf_rule 
+  | MulPrf of prf_rule * prf_rule
+  | AddPrf of prf_rule * prf_rule
+  | CutPrf of prf_rule
+      
+type proof = 
+  | Done
+  | Step of int * prf_rule * proof
+  | Enum of int * prf_rule * Vect.t * prf_rule * proof list 
+      
+
+let rec output_prf_rule o = function
+  | Hyp i -> Printf.fprintf o "Hyp %i" i
+  | Def i -> Printf.fprintf o "Def %i" i
+  | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c)
+  | Zero  -> Printf.fprintf o "Zero"
+  | Square _ -> Printf.fprintf o "( )^2"
+  | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr
+  | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2
+  | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2
+  | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p
+  | Gcd(c,p)  -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c)
+
+let rec output_proof o = function
+  | Done -> Printf.fprintf o "."
+  | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf
+  | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i 
+      output_prf_rule p1 Vect.pp_vect v output_prf_rule p2
+	(pp_list output_proof) pl
+
+let rec pr_rule_max_id = function
+  | Hyp i | Def i -> i
+  | Cst _ | Zero | Square _ -> -1
+  | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p
+  | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2)
+
+let rec proof_max_id = function
+  | Done -> -1
+  | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf))
+  | Enum(i,p1,_,p2,l) -> 
+      let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in
+	List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l
+
+let rec pr_rule_def_cut id = function
+  | MulC(p,prf) -> 
+      let (bds,id',prf') = pr_rule_def_cut id prf  in
+	(bds, id', MulC(p,prf'))
+  | MulPrf(p1,p2) -> 
+      let (bds1,id,p1) = pr_rule_def_cut id p1 in
+      let (bds2,id,p2) = pr_rule_def_cut id p2 in
+	(bds2@bds1,id,MulPrf(p1,p2))
+  | AddPrf(p1,p2) -> 
+      let (bds1,id,p1) = pr_rule_def_cut id p1 in
+      let (bds2,id,p2) = pr_rule_def_cut id p2 in
+	(bds2@bds1,id,AddPrf(p1,p2))
+  | CutPrf p -> 
+      let (bds,id,p) = pr_rule_def_cut id p in
+	((id,p)::bds,id+1,Def id)
+  | Gcd(c,p) ->       
+      let (bds,id,p) = pr_rule_def_cut id p in
+	((id,p)::bds,id+1,Def id)
+  | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x)
+
+
+(* Do not define top-level cuts *)
+let pr_rule_def_cut id = function
+  | CutPrf p -> 
+      let (bds,ids,p') = pr_rule_def_cut id p in
+	bds,ids, CutPrf p'
+  |    p     -> pr_rule_def_cut id p
+
+
+let rec implicit_cut p = 
+  match p with
+    | CutPrf p -> implicit_cut p
+    |   _      -> p
+       
+
+let rec normalise_proof id prf =
+  match prf with
+  | Done -> (id,Done)
+  | Step(i,Gcd(c,p),Done) ->  normalise_proof id (Step(i,p,Done))
+  | Step(i,p,prf) -> 
+      let bds,id,p' = pr_rule_def_cut id p in
+      let (id,prf) = normalise_proof id prf in
+      let prf = List.fold_left (fun  acc (i,p)  -> Step(i, CutPrf p,acc)) 
+	(Step(i,p',prf)) 	  bds in
+
+	(id,prf)
+  | Enum(i,p1,v,p2,pl) -> 
+      (* Why do I have  top-level cuts ? *)
+(*      let p1 = implicit_cut p1 in
+      let p2 = implicit_cut p2 in
+      let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
+	(List.fold_left max  0 ids , 
+	   Enum(i,p1,v,p2,prfs))
+*)
+
+      let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in
+      let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in
+      let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
+	(List.fold_left max  0 ids , 
+	 List.fold_left (fun  acc (i,p)  -> Step(i, CutPrf p,acc))
+	   (Enum(i,p1',v,p2',prfs)) (bds2@bds1))
+
+
+let normalise_proof id prf = 
+  let res = normalise_proof id prf in
+  if debug then Printf.printf "normalise_proof %a -> %a" output_proof  prf output_proof (snd res) ; 
+    res
+
+
+
+let add_proof x y = 
+  match x, y with 
+   | Zero , p | p , Zero -> p
+   | _    -> AddPrf(x,y)
+
+
+let mul_proof c p = 
+  match  sign_big_int c with
+   | 0 -> Zero (* This is likely to be a bug *)
+   | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *)
+   | 1 -> 
+       if eq_big_int c unit_big_int
+       then p
+       else MulPrf(Cst c,p)
+   | _ -> assert false
+
+
+let mul_proof_ext (p,c) prf = 
+  match p with
+   | [] -> mul_proof (numerator c) prf
+   |  _ -> MulC((p,c),prf)
+  
+
+
+(*
+  let rec scale_prf_rule = function
+	    | Hyp i -> (unit_big_int, Hyp i)
+  | Def i -> (unit_big_int, Def i)
+  | Cst c -> (unit_big_int, Cst i)
+  | Zero  -> (unit_big_int, Zero)
+  | Square p -> (unit_big_int,Square p)
+  | Div(c,pr) -> 
+  let (bi,pr') = scale_prf_rule pr in
+  (mult_big_int c bi , pr')
+  | MulC(p,pr) -> 
+  let bi,pr' = scale_prf_rule pr in
+  (bi,MulC p,pr')
+  | MulPrf(p1,p2) -> 
+  let b1,p1 = scale_prf_rule p1 in
+  let b2,p2 = scale_prf_rule p2 in
+	    
+  
+  | AddPrf(p1,p2) -> 
+	    let b1,p1 = scale_prf_rule p1 in
+  let b2,p2 = scale_prf_rule p2 in
+  let g =  gcd_big_int
+*)
+	  
+
+
+
+
+module LinPoly = 
+struct
+  type t = Vect.t * num
+
+  module MonT = 
+  struct
+    module MonoMap = Map.Make(Monomial)
+    module IntMap  = Map.Make(struct type t = int let compare = Pervasives.compare end)
+	  
+    (** A hash table might be preferable but requires a hash function. *)
+    let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty)
+    let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty)
+    let fresh = ref 0
+
+    let clear () = 
+      index_of_monomial := MonoMap.empty;
+      monomial_of_index := IntMap.empty ; 
+      fresh := 0
+
+
+    let register m = 
+      try
+	MonoMap.find m !index_of_monomial
+      with Not_found -> 
+	begin
+	  let res = !fresh in
+	    index_of_monomial := MonoMap.add m res !index_of_monomial ; 
+	    monomial_of_index := IntMap.add res m !monomial_of_index ;
+	    incr fresh ; res
+	end
+
+    let retrieve i = IntMap.find i !monomial_of_index
+
+
+  end 
+
+  let normalise (v,c) = 
+    (List.sort  (fun x y -> Pervasives.compare (fst x) (fst y)) v , c)
+
+
+  let output_mon o (x,v) = 
+    Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x)
+
+
+
+  let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = 
+    Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst)
+
+
+
+  let linpol_of_pol p = 
+    let (v,c) = 
+      Poly.fold 
+	(fun  mon num (vct,cst)  -> 
+	   if Monomial.is_const mon then (vct,num) 
+	   else
+	     let vr = MonT.register mon in
+	       ((vr,num)::vct,cst)) p ([], Int 0) in
+      normalise (v,c)
+
+  let mult v m (vect,c) =
+    if Monomial.is_const m
+    then
+      (Vect.mul v vect, v <*> c)
+    else
+      if sign_num v <> 0
+      then
+	let hd = 
+	  if sign_num c <> 0
+	  then [MonT.register m,v <*> c]
+	  else [] in
+	  
+	let vect = hd @ (List.map (fun (x,n) -> 
+					let x = MonT.retrieve x in
+					let x_m = MonT.register (Monomial.prod m x) in
+					  (x_m, v <*> n)) vect ) in
+	  normalise (vect , Int 0)
+      else ([],Int 0)
+
+  let mult v m (vect,c) = 
+    let (vect',c') = mult v m (vect,c) in
+      if debug then 
+      Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m 
+	(pp_list output_mon) vect (string_of_num c) 
+	(pp_list output_mon) vect' (string_of_num c') ;
+      (vect',c')
+
+
+
+  let make_lin_pol v mon =
+    if Monomial.is_const mon
+    then [] , v
+    else [MonT.register mon, v],Int 0
+
+      
+
+
+
+
+  let xpivot_eq (c,prf) x v (c',prf') = 
+    if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" 
+      output_cstr c 
+      Monomial.pp (MonT.retrieve x)
+      (string_of_num v) output_cstr c' ; 
+
+
+    let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+    let m = MonT.retrieve x in
+
+    let apply_pivot (vqn,q,n) (c',prf') = 
+      (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *)
+
+      let cc' = abs_num v in
+      let cc_num  = Int (- (sign_num v)) <*> vqn in
+      let cc_mon  = Monomial.prod q (Monomial.exp m (n-1)) in
+
+      let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in
+	
+      let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in
+      let prf' = add_proof 
+	(mul_proof_ext (make_lin_pol cc_num cc_mon) prf)
+	(mul_proof (numerator cc') prf') in
+
+	if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; 
+	(c',prf') in
+
+
+    let cmp (q,n) (q',n') = 
+      if n < n' then -1
+      else if n = n' then  Monomial.compare q q'
+      else 1 in
+
+      
+    let find_pivot (c',prf') = 
+      let (v,q,n) = List.fold_left 
+	(fun (v,q,n) (x,v') -> 
+	   let x = MonT.retrieve x in 
+	   let (q',n') = Monomial.div x m in
+	     if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in
+	if n > 0 then Some (v,q,n) else None in
+
+    let rec pivot (q,n) (c',prf') = 
+      match find_pivot (c',prf') with
+       | None -> (c',prf') 
+       | Some(v,q',n') -> 
+	   if cmp (q',n')  (q,n) = -1
+	   then pivot (q',n') (apply_pivot (v,q',n') (c',prf'))
+	   else (c',prf') in
+
+      pivot (Monomial.const,max_int) (c',prf')
+
+
+  let pivot_eq x (c,prf)   = 
+    match Vect.get x c.coeffs with
+     | None -> (fun x -> None)
+     | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp')
+
+
+end
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
index 3029496b..6ddc48e7 100644
--- a/plugins/micromega/sos.ml
+++ b/plugins/micromega/sos.ml
@@ -526,17 +526,17 @@ let sdpa_run_succeeded =
 (* ------------------------------------------------------------------------- *)
 
 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;
-";;
+"100     unsigned int maxIteration;\
+\n1.0E-7  double 0.0 < epsilonStar;\
+\n1.0E2   double 0.0 < lambdaStar;\
+\n2.0     double 1.0 < omegaStar;\
+\n-1.0E5  double lowerBound;\
+\n1.0E5   double upperBound;\
+\n0.1     double 0.0 <= betaStar <  1.0;\
+\n0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;\
+\n0.9     double 0.0 < gammaStar  <  1.0;\
+\n1.0E-7  double 0.0 < epsilonDash;\
+\n";;
 
 (* ------------------------------------------------------------------------- *)
 (* These were suggested by Makoto Yamashita for problems where we are        *)
@@ -544,17 +544,17 @@ let sdpa_default_parameters =
 (* ------------------------------------------------------------------------- *)
 
 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;
-";;
+"1000    unsigned int maxIteration;\
+\n1.0E-7  double 0.0 < epsilonStar;\
+\n1.0E4   double 0.0 < lambdaStar;\
+\n2.0     double 1.0 < omegaStar;\
+\n-1.0E5  double lowerBound;\
+\n1.0E5   double upperBound;\
+\n0.1     double 0.0 <= betaStar <  1.0;\
+\n0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;\
+\n0.9     double 0.0 < gammaStar  <  1.0;\
+\n1.0E-7  double 0.0 < epsilonDash;\
+\n";;
 
 let sdpa_params = sdpa_alt_parameters;;
 
@@ -563,21 +563,21 @@ let sdpa_params = sdpa_alt_parameters;;
 (* ------------------------------------------------------------------------- *)
 
 let csdp_default_parameters =
-"axtol=1.0e-8
-atytol=1.0e-8
-objtol=1.0e-8
-pinftol=1.0e8
-dinftol=1.0e8
-maxiter=100
-minstepfrac=0.9
-maxstepfrac=0.97
-minstepp=1.0e-8
-minstepd=1.0e-8
-usexzgap=1
-tweakgap=0
-affine=0
-printlevel=1
-";;
+"axtol=1.0e-8\
+\natytol=1.0e-8\
+\nobjtol=1.0e-8\
+\npinftol=1.0e8\
+\ndinftol=1.0e8\
+\nmaxiter=100\
+\nminstepfrac=0.9\
+\nmaxstepfrac=0.97\
+\nminstepp=1.0e-8\
+\nminstepd=1.0e-8\
+\nusexzgap=1\
+\ntweakgap=0\
+\naffine=0\
+\nprintlevel=1\
+\n";;
 
 let csdp_params = csdp_default_parameters;;
 
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
index 23219be2..3d907e19 100644
--- a/plugins/micromega/sos.mli
+++ b/plugins/micromega/sos.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
index 6bd463ef..91aa5855 100644
--- a/plugins/micromega/sos_types.ml
+++ b/plugins/micromega/sos_types.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index ac321ba2..9a0c9090 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -1,20 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*
- Tactic nsatz: proofs of polynomials equalities in a domain (ring without zero divisor).
- Reification is done by type classes, following a technique shown by Mathieu
-Sozeau. Verification of certificate is done by a code written by Benjamin
-Gregoire, following an idea of Laurent Théry.
-
+ Tactic nsatz: proofs of polynomials equalities in an integral domain 
+(commutative ring without zero divisor).
+ 
 Examples: see test-suite/success/Nsatz.v
 
-Loïc Pottier, july 2010
+Reification is done using type classes, defined in Ncring_tac.v
+
 *)
 
 Require Import List.
@@ -22,74 +21,27 @@ Require Import Setoid.
 Require Import BinPos.
 Require Import BinList.
 Require Import Znumtheory.
-Require Import Ring_polynom Ring_tac InitialRing.
 Require Export Morphisms Setoid Bool.
+Require Export Algebra_syntax.
+Require Export Ncring.
+Require Export Ncring_initial.
+Require Export Ncring_tac.
+Require Export Integral_domain.
+Require Import DiscrR.
 
 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_eq : R -> R -> Prop;
- ring_ring: 
-   ring_theory ring0 ring1 ring_plus ring_mult ring_sub 
-               ring_opp ring_eq;
- ring_setoid: Equivalence ring_eq;
- ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus;
- ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult;
- ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub;
- ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp
-}.
-
-Class Domain (R : Type) := {
- domain_ring:> Ring R;
- domain_axiom_product:
-   forall x y, ring_eq (ring_mult x y) ring0 -> (ring_eq x ring0) \/ (ring_eq y ring0);
- domain_axiom_one_zero: not (ring_eq ring1 ring0)}.
-
-Section domain.
-
-Variable R: Type.
-Variable Rd: Domain R.
-
-Existing Instance ring_setoid.
-Existing Instance ring_plus_comp.
-Existing Instance ring_mult_comp.
-Existing Instance ring_sub_comp.
-Existing Instance ring_opp_comp.
-
-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}.
-
-Infix "==" := ring_eq (at level 70, no associativity).
+Section nsatz1.
+
+Context {R:Type}`{Rid:Integral_domain R}.
 
 Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y.
 intros x y H; setoid_replace x with ((x - y) + y); simpl;
- [setoid_rewrite H | idtac]; simpl; ring.
+ [setoid_rewrite H | idtac]; simpl. cring. cring.
 Qed.
 
 Lemma psos_r1: forall x y, x == y -> x - y == 0.
-intros x y H; simpl; setoid_rewrite H; simpl; ring.
+intros x y H; simpl; setoid_rewrite H; simpl; cring.
 Qed.
 
 Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0).
@@ -97,23 +49,25 @@ intros.
 intro; apply H.
 simpl; setoid_replace x with ((x - y) + y). simpl.
 setoid_rewrite H0.
-simpl; ring.
-simpl. simpl; ring.
+simpl; cring.
+simpl. simpl; cring.
 Qed.
 
 (* adpatation du code de Benjamin aux setoides *)
 Require Import ZArith.
+Require Export Ring_polynom.
+Require Export InitialRing.
 
 Definition PolZ := Pol Z.
 Definition PEZ := PExpr Z.
 
-Definition P0Z : PolZ := @P0 Z 0%Z.
+Definition P0Z : PolZ := P0 (C:=Z) 0%Z.
 
 Definition PolZadd : PolZ -> PolZ -> PolZ :=
-  @Padd Z 0%Z Zplus Zeq_bool.
+  @Padd  Z 0%Z Zplus Zeq_bool.
 
 Definition PolZmul : PolZ -> PolZ -> PolZ :=
-  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+  @Pmul  Z 0%Z 1%Z Zplus Zmult Zeq_bool.
 
 Definition PolZeq := @Peq Z Zeq_bool.
 
@@ -140,51 +94,65 @@ Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
 
 (* 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).
+  (Pphi ring0 add mul 
+    (InitialRing.gen_phiZ ring0 ring1 add mul opp)).
 
 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.
+   PEeval ring0 add mul sub opp
+    (gen_phiZ ring0 ring1 add mul opp)
+         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 ring_eq.
-apply mk_reqe. intros. setoid_rewrite H; rewrite H0; ring.
- intros. setoid_rewrite H; setoid_rewrite H0; ring. 
-intros. setoid_rewrite H; ring. Qed.
+Lemma Rext: ring_eq_ext add mul opp _==_.
+apply mk_reqe. intros. rewrite H ; rewrite H0; cring.
+ intros. rewrite H; rewrite H0; cring. 
+intros.  rewrite H; cring. Qed.
  
-Lemma Rset : Setoid_Theory R ring_eq.
+Lemma Rset : Setoid_Theory R _==_.
 apply ring_setoid.
 Qed.
 
+Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_.
+apply mk_rt.
+apply ring_add_0_l.
+apply ring_add_comm.   
+apply ring_add_assoc.  
+apply ring_mul_1_l.    
+apply cring_mul_comm.
+apply ring_mul_assoc.
+apply ring_distr_l.    
+apply ring_sub_def.  
+apply ring_opp_def.
+Defined.
+
 Lemma PolZadd_correct : forall P' P l,
   PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')).
 Proof.
-simpl.
- refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
-           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+unfold PolZadd, PhiR. intros. simpl.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory)
+           (gen_phiZ_morph Rset Rext Rtheory) _ _ _).
 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)))).
+unfold PolZmul, PhiR. intros. 
+ refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory)
+           (gen_phiZ_morph Rset Rext Rtheory) _ _ _).
 Qed.
 
 Lemma R_power_theory
-     : power_theory 1 ring_mult ring_eq Nnat.nat_of_N pow.
-apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. ring. Qed. 
+     : Ring_theory.power_theory ring1 mul _==_ nat_of_N pow.
+apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. 
+reflexivity. 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)
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory)
+           (gen_phiZ_morph Rset Rext Rtheory) R_power_theory)
     with (lmp:= List.nil).
  compute;trivial.
 Qed.
@@ -194,7 +162,7 @@ Lemma PolZeq_correct : forall P P' l,
   PhiR l P == PhiR l P'.
 Proof.
  intros;apply
-   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial.
+   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial.
 Qed.
 
 Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
@@ -207,12 +175,12 @@ 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. ring.
- destruct lp;trivial. simpl. ring.
+ induction la;simpl;intros. cring.
+ destruct lp;trivial. simpl. cring.
  simpl in H;destruct H.
- setoid_rewrite  PolZadd_correct.
- simpl. setoid_rewrite PolZmul_correct. simpl. setoid_rewrite  H.
- setoid_rewrite IHla. unfold zero. simpl. ring. trivial.
+ rewrite  PolZadd_correct.
+ simpl. rewrite PolZmul_correct. simpl. rewrite  H.
+ rewrite IHla. cring. trivial.
 Qed.
 
 Lemma compute_list_correct : forall l lla lp,
@@ -242,86 +210,63 @@ Qed.
 
 (* fin *)
 
-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. setoid_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; simpl; try ring. 
- rewrite pow_pos_Psucc. ring. exact Rset.
- intros. setoid_rewrite H; setoid_rewrite H0; ring.
- intros. simpl; ring. intros. simpl; ring. Qed.
-
-Lemma Rdomain_pow: forall c p r, ~c == ring0 -> ring_mult c (pow p r) == ring0 -> p == ring0.
-intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c == ring0); auto. 
-intros. apply pow_not_zero with r. trivial. Qed.   
-
-Definition R2:= ring_plus ring1 ring1.
+Definition R2:= 1 + 1.
 
 Fixpoint IPR p {struct p}: R :=
   match p with
     xH => ring1
-  | xO xH => ring_plus ring1 ring1
-  | xO p1 => ring_mult R2 (IPR p1)
-  | xI xH => ring_plus ring1 (ring_plus ring1 ring1)
-  | xI p1 => ring_plus ring1 (ring_mult R2 (IPR p1))
+  | 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 => ring0
+  match z with Z0 => 0
              | Zpos p => IPR p
-             | Zneg p => ring_opp(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 (ring_plus v1 v2)
+       let v2  := interpret3 t2 fv in (v1 + v2)
   | (PEmul t1 t2) =>
        let v1  := interpret3 t1 fv in
-       let v2  := interpret3 t2 fv in (ring_mult v1 v2)
+       let v2  := interpret3 t2 fv in (v1 * v2)
   | (PEsub t1 t2) =>
        let v1  := interpret3 t1 fv in
-       let v2  := interpret3 t2 fv in (ring_sub v1 v2)
+       let v2  := interpret3 t2 fv in (v1 - v2)
   | (PEopp t1) =>
-       let v1  := interpret3 t1 fv in (ring_opp v1)
+       let v1  := interpret3 t1 fv in (-v1)
   | (PEpow t1 t2) =>
-       let v1  := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2)
+       let v1  := interpret3 t1 fv in pow v1 (nat_of_N t2)
   | (PEc t1) => (IZR1 t1)
   | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
   end.
 
 
-End domain.
+End nsatz1.
+
+Ltac equality_to_goal H x y:=
+  let h := fresh "nH" in
+  (* eliminate trivial  hypotheses, but it takes time!:
+    (assert (h:equality x y);
+    [solve [cring] | clear H; clear h])
+  || *) (try generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H)
+.
 
 Ltac equalities_to_goal :=
   lazymatch goal with
-  |  H: (@ring_eq _ _ ?x ?y) |- _ =>
-          try generalize (@psos_r1 _ _ _ _ H); clear H
+  |  H: (_ ?x ?y) |- _ => equality_to_goal H x y
+  |  H: (_ _ ?x ?y) |- _ => equality_to_goal H x y
+  |  H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y
+  |  H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y
+(* extension possible :-) *)
+  |  H: (?x == ?y) |- _ => equality_to_goal H x y
    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 : (@ring_eq _ _ ?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 :=
@@ -344,13 +289,12 @@ Ltac rev l :=
    | (cons ?x ?l) => let l' := rev l in append1 x l'
   end.
 
-
-
 Ltac nsatz_call_n info nparam p rr lp kont := 
-  (*idtac "Trying power: " rr;*)
+(*  idtac "Trying power: " rr;*)
   let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
+(*  idtac "calcul...";*)
   nsatz_compute ll; 
-  (*idtac "done";*)
+(*  idtac "done";*)
   match goal with
   | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
     intros _;
@@ -371,51 +315,13 @@ Ltac nsatz_call radicalmax info nparam p lp kont :=
   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
-  ring_eq ?b1 ?b2 => constr:(b1::b2::nil)
-  | ring_eq ?b1 ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)     
+    ?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 Rd:=
+Ltac reify_goal l le lb:=
   match le with
      nil => idtac
    | ?e::?le1 => 
@@ -423,241 +329,182 @@ Ltac reify_goal l le lb Rd:=
          ?b::?lb1 => (* idtac "b="; idtac b;*)
            let x := fresh "B" in
            set (x:= b) at 1;
-           change x with (@interpret3 _ Rd e l); 
+           change x with (interpret3 e l); 
            clear x;
-           reify_goal l le1 lb1 Rd
+           reify_goal l le1 lb1
         end
   end.
 
 Ltac get_lpol g :=
   match g with
-  ring_eq (interpret3 _ _ ?p _) _ => constr:(p::nil)
-  | ring_eq (interpret3 _ _ ?p _) _ -> ?g =>
+  (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; idtac le; idtac lb;*)
-              reify_goal fv le lb Rd;
-                match goal with 
+Ltac nsatz_generic radicalmax info lparam lvar :=
+ let nparam := eval compute in (Z_of_nat (List.length lparam)) in
+ match goal with
+  |- ?g => let lb := lterm_goal g in 
+     match (match lvar with
+              |(@nil _) =>
+                 match lparam with
+                   |(@nil _) =>
+                     let r := eval red in (list_reifyl (lterm:=lb)) in r
+                   |_ =>
+                     match eval red in (list_reifyl (lterm:=lb)) with
+                       |(?fv, ?le) =>
+                         let fv := parametres_en_tete fv lparam in
+                           (* we reify a second time, with the good order
+                              for variables *)
+                         let r := eval red in 
+                                  (list_reifyl (lterm:=lb) (lvar:=fv)) in r
+                     end
+                  end
+              |_ => 
+                let fv := parametres_en_tete lvar lparam in
+                let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r
+            end) with
+          |(?fv, ?le) => 
+            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;
- 
+                       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; *)
+(*    idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *)
     nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => 
       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: ring_eq (interpret3 _ Rd q fv) ring0);
-        [ tacsimpl; 
-          apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg);
-          tacsimpl;
+            assert (Hg2: (interpret3 q fv) == 0);
+        [ (*simpl*) idtac; 
+          generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg);
+          let cc := fresh "H" in
+             (*simpl*) idtac; intro cc; apply cc; clear cc;
+          (*simpl*) idtac;
           repeat (split;[assumption|idtac]); exact I
-        | simpl in Hg2; tacsimpl; 
-          apply Rdomain_pow with (interpret3 _ Rd c fv) (Nnat.nat_of_N r); auto with domain;
-          tacsimpl; apply domain_axiom_one_zero 
-          || (simpl) || idtac "could not prove discrimination result"
+        | (*simpl in Hg2;*) (*simpl*) idtac; 
+          apply Rintegral_domain_pow with (interpret3 c fv) (nat_of_N r);
+          (*simpl*) idtac;
+            try apply integral_domain_one_zero;
+            try apply integral_domain_minus_one_zero;
+            try trivial;
+            try exact integral_domain_one_zero;
+            try exact integral_domain_minus_one_zero
+          || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation,
+                     one, one_notation, multiplication, mul_notation, zero, zero_notation;
+                     discrR || omega]) 
+          || ((*simpl*) idtac) || idtac "could not prove discrimination result"
         ]
       ]
 ) 
 )
-end end end end .
+end end end .
+
+Ltac nsatz_default:=
+  intros;
+  try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _);
+  match goal with |- (@equality ?r _ _ _) =>
+    repeat equalities_to_goal;
+    nsatz_generic 6%N 1%Z (@nil r) (@nil r)
+  end.
 
-Ltac nsatz_domainpv pretac radicalmax info lparam lvar tacsimpl rd :=
-  pretac;
-  nsatz_domain_begin tacsimpl; auto with domain;
-  nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd.
+Tactic Notation "nsatz" := nsatz_default.
 
-Ltac nsatz_domain:= 
+Tactic Notation "nsatz" "with"
+ "radicalmax" ":=" constr(radicalmax) 
+ "strategy" ":=" constr(info) 
+ "parameters" ":=" constr(lparam)
+ "variables" ":=" constr(lvar):=
   intros;
-  match goal with
-    |- (@ring_eq _ (@domain_ring ?r ?rd) _ _ ) =>
-          nsatz_domainpv ltac:idtac 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
+  try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _);
+  match goal with |- (@equality ?r _ _ _) =>
+    repeat equalities_to_goal;
+    nsatz_generic radicalmax info lparam lvar
   end.
 
-(* Dans R *)
+(* Real numbers *)
 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_eq := @eq R; 
-  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}.
-
-Hint Resolve ring_setoid ring_plus_comp ring_mult_comp ring_sub_comp ring_opp_comp: domain.
-
-Ltac replaceR:=
-replace 0%R with (@ring0 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace 1%R with (@ring1 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace Rplus with (@ring_plus _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace Rmult with (@ring_mult _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace Rminus with (@ring_sub _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace Ropp with (@ring_opp _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
-replace (@eq R) with (@ring_eq _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity].
-
-Ltac simplR:=
-  simpl; replaceR.
-
-Ltac pretacR:=
-  replaceR;
-  replace Rri with (@domain_ring _ Rdi) in *; [idtac | reflexivity].
-
-Ltac nsatz_domainR:= 
-  nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R)
-    ltac:simplR Rdi;
-  discrR.
-
-
-Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R.
-nsatz_domainR.
+Lemma Rsth : Setoid_Theory R (@eq R).
+constructor;red;intros;subst;trivial.
 Qed.
 
+Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)).
 
-(* 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_eq := (@eq Z); 
-  ring_ring := Zth}.
+Instance Rri : (Ring (Ro:=Rops)).
+constructor;
+try (try apply Rsth;
+   try (unfold respectful, Proper; unfold equality; unfold eq_notation in *;
+  intros; try rewrite H; try rewrite H0; reflexivity)).
+ exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc.
+ exact Rmult_1_l.  exact Rmult_1_r. symmetry. apply Rmult_assoc.
+ exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. 
+exact Rplus_opp_r.
+Defined.
 
-Lemma Zaxiom_one_zero: 1%Z <> 0%Z.
-discriminate.
+Lemma R_one_zero: 1%R <> 0%R.
+discrR.
 Qed.
 
-Instance Zdi : Domain Z := {
-  domain_ring := Zri;
-  domain_axiom_product := Zmult_integral;
-  domain_axiom_one_zero := Zaxiom_one_zero}.
-
-Ltac replaceZ :=
-replace 0%Z with (@ring0 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace 1%Z with (@ring1 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace Zplus with (@ring_plus _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace Zmult with (@ring_mult _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace Zminus with (@ring_sub _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace Zopp with (@ring_opp _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
-replace (@eq Z) with (@ring_eq _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity].
-
-Ltac simplZ:=
-  simpl; replaceZ.
-
-Ltac pretacZ :=
-replaceZ;
-replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity].
+Instance Rcri: (Cring (Rr:=Rri)).
+red. exact Rmult_comm. Defined.
 
-Ltac nsatz_domainZ:= 
-nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi.
+Instance Rdi : (Integral_domain (Rcr:=Rcri)). 
+constructor. 
+exact Rmult_integral. exact R_one_zero. Defined.
 
-
-(* Dans Q *)
+(* Rational numbers *)
 Require Import QArith.
 
-Instance Qri : Ring Q := {
-  ring0 := 0%Q;
-  ring1 := 1%Q;
-  ring_plus := Qplus;
-  ring_mult := Qmult;
-  ring_sub := Qminus;
-  ring_opp := Qopp; 
-  ring_eq := Qeq; 
-  ring_ring := Qsrt}.
-
-Lemma Qaxiom_one_zero: not (Qeq 1%Q 0%Q).
-discriminate.
+Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq).
+
+Instance Qri : (Ring (Ro:=Qops)).
+constructor.
+try apply Q_Setoid. 
+apply Qplus_comp. 
+apply Qmult_comp. 
+apply Qminus_comp. 
+apply Qopp_comp.
+ exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc.
+ exact Qmult_1_l.  exact Qmult_1_r. apply Qmult_assoc.
+ apply Qmult_plus_distr_l.  intros. apply Qmult_plus_distr_r. 
+reflexivity. exact Qplus_opp_r.
+Defined.
+
+Lemma Q_one_zero: not (Qeq 1%Q 0%Q).
+unfold Qeq. simpl. auto with *. Qed.
+
+Instance Qcri: (Cring (Rr:=Qri)).
+red. exact Qmult_comm. Defined.
+
+Instance Qdi : (Integral_domain (Rcr:=Qcri)). 
+constructor. 
+exact Qmult_integral. exact Q_one_zero. Defined.
+
+(* Integers *)
+Lemma Z_one_zero: 1%Z <> 0%Z.
+omega. 
 Qed.
 
-Instance Qdi : Domain Q := {
-  domain_ring := Qri;
-  domain_axiom_product := Qmult_integral;
-  domain_axiom_one_zero := Qaxiom_one_zero}.
-
-Ltac replaceQ :=
-replace 0%Q with (@ring0 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace 1%Q with (@ring1 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace Qplus with (@ring_plus _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace Qmult with (@ring_mult _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace Qminus with (@ring_sub _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace Qopp with (@ring_opp _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
-replace Qeq with (@ring_eq _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity].
-
-Ltac simplQ:=
-  simpl; replaceQ.
-
-Ltac pretacQ := 
-replaceQ;
-replace Qri with (@domain_ring _ Qdi) in *; [idtac | reflexivity].
+Instance Zcri: (Cring (Rr:=Zr)).
+red. exact Zmult_comm. Defined.
 
-Ltac nsatz_domainQ:= 
-nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi.
+Instance Zdi : (Integral_domain (Rcr:=Zcri)). 
+constructor. 
+exact Zmult_integral. exact Z_one_zero. Defined.
 
-(* tactique générique *)
-
-Ltac nsatz :=
-  intros;
-  match goal with
-   | |- (@eq R _ _) => nsatz_domainR
-   | |- (@eq Z _ _) => nsatz_domainZ
-   | |- (@Qeq _ _) => nsatz_domainQ
-   | |- _ => nsatz_domain
-  end.
-(*
-Goal forall x y:Q, Qeq x y -> Qeq (x*x-x+1)%Q ((y*y-y)+1+0)%Q.
-nsatz.
-Qed.
-
-Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z.
-nsatz.
-Qed.
-
-Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R.
-nsatz.
-Qed.
-*)
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
index 5fde2cfc..b635fd1f 100644
--- a/plugins/nsatz/ideal.ml
+++ b/plugins/nsatz/ideal.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -363,7 +363,7 @@ let stringPcut p =
   nsP2:=10;
   let res =
     if (length p)> !nsP2
-    then (stringP [hd p])^" + "^(string_of_int (length p))^" termes"
+    then (stringP [hd p])^" + "^(string_of_int (length p))^" terms"
     else  stringP p in
   (*Polynomesrec.nsP1:= max_int;*)
   nsP2:= max_int;
@@ -992,7 +992,7 @@ let pbuchf pq p lp0=
 		    coefpoldep_remove a q;
 		    coefpoldep_set a q c) lca !poldep;
 		  let a0 = a in
-		  info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n");
+		  info ("\nnew polynomial: "^(stringPcut (ppol a0))^"\n");
 		  let ct = coef1 (* contentP a0 *) in
 		  (*info ("content: "^(string_of_coef ct)^"\n");*)
 		  poldep:=addS a0 lp;
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
index da0ee898..e48643b4 100644
--- a/plugins/nsatz/nsatz.ml4
+++ b/plugins/nsatz/nsatz.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,7 +16,7 @@ open Closure
 open Environ
 open Libnames
 open Tactics
-open Rawterm
+open Glob_term
 open Tacticals
 open Tacexpr
 open Pcoq
@@ -180,21 +180,24 @@ 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 datatypes = ["Init";"Datatypes"]
+let binnums = ["Numbers";"BinNums"]
 
-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 tlist = lazy (gen_constant "CC" datatypes "list")
+let lnil = lazy (gen_constant "CC" datatypes "nil")
+let lcons = lazy (gen_constant "CC" datatypes "cons")
 
-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 tz = lazy (gen_constant "CC" binnums "Z")
+let z0 = lazy (gen_constant "CC" binnums "Z0")
+let zpos = lazy (gen_constant "CC" binnums "Zpos")
+let zneg = lazy(gen_constant "CC" binnums "Zneg")
 
-let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0")
-let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos")
+let pxI = lazy(gen_constant "CC" binnums "xI")
+let pxO = lazy(gen_constant "CC" binnums "xO")
+let pxH = lazy(gen_constant "CC" binnums "xH")
+
+let nN0 = lazy (gen_constant "CC" binnums "N0")
+let nNpos = lazy(gen_constant "CC" binnums "Npos")
 
 let mkt_app name l =  mkApp (Lazy.force name, Array.of_list l)
 
@@ -237,14 +240,14 @@ else
 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)
+    if eq_constr 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))
+    if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2))
 | _ -> num_0
 
 let parse_n z =
@@ -256,15 +259,15 @@ let parse_n z =
 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)
+    if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2))
+    else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2)
+    else if eq_constr 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
+    if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3)
+    else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3)
+    else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3)
+    else if eq_constr a (Lazy.force ttpow) then
       Pow (parse_term p2, int_of_num (parse_n p3))
     else Zero
 | _ -> Zero
@@ -323,6 +326,8 @@ open PIdeal
 let term_pol_sparse np t=
   let d = !nvars in
   let rec aux t =
+(*    info ("conversion de: "^(string_of_term t)^"\n");*)
+    let res =
     match t with
     | Zero -> zeroP
     | Const r ->
@@ -339,9 +344,11 @@ let term_pol_sparse np t=
     | 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");*)
+    in 
+(*       info ("donne: "^(stringP res)^"\n");*)
+       res 
+  in
   let res= aux t in
-  (*info ("donne: "^(stringP res)^"\n");*)
   res
 
 (* sparse polynomial to term *)
@@ -364,7 +371,7 @@ let polrec_to_term p =
 (* approximation of the Horner form used in the tactic ring *)
 
 let pol_sparse_to_term n2 p =
-  info "pol_sparse_to_term ->\n";
+ (* info "pol_sparse_to_term ->\n";*)
   let p = PIdeal.repr p in
   let rec aux p =
     match p with
@@ -408,7 +415,7 @@ let pol_sparse_to_term n2 p =
 	  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";
+  in   (*info "-> pol_sparse_to_term\n";*)
   aux p
 
 
@@ -467,7 +474,7 @@ let remove_zeros zero lci =
 	done;
 	!lcr)
       lr in
-  info ("useless spolynomials: "
+  info ("unuseful spolynomials: "
 	^string_of_int (m-List.length lr)^"\n");
   info ("useful spolynomials: "
 	^string_of_int (List.length lr)^"\n");
@@ -489,35 +496,35 @@ let theoremedeszeros_termes lp =
   match lp with
   | Const (Int sugarparam)::Const (Int nparam)::lp ->
       ((match sugarparam with
-      |0 -> info "calcul sans sugar\n";
+      |0 -> info "computation without sugar\n";
 	  lexico:=false;
 	  sugar_flag := false;
 	  divide_rem_with_critical_pair := false
-      |1 -> info "calcul avec sugar\n";
+      |1 -> info "computation with sugar\n";
 	  lexico:=false;
 	  sugar_flag := true;
 	  divide_rem_with_critical_pair := false
-      |2 -> info "ordre lexico calcul sans sugar\n";
+      |2 -> info "ordre lexico computation without sugar\n";
 	  lexico:=true;
 	  sugar_flag := false;
 	  divide_rem_with_critical_pair := false
-      |3 -> info "ordre lexico calcul avec sugar\n";
+      |3 -> info "ordre lexico computation with sugar\n";
 	  lexico:=true;
 	  sugar_flag := true;
 	  divide_rem_with_critical_pair := false
-      |4 -> info "calcul sans sugar, division par les paires\n";
+      |4 -> info "computation without sugar, division by pairs\n";
 	  lexico:=false;
 	  sugar_flag := false;
 	  divide_rem_with_critical_pair := true
-      |5 -> info "calcul avec sugar, division par les paires\n";
+      |5 -> info "computation with sugar, division by pairs\n";
 	  lexico:=false;
 	  sugar_flag := true;
 	  divide_rem_with_critical_pair := true
-      |6 -> info "ordre lexico calcul sans sugar, division par les paires\n";
+      |6 -> info "ordre lexico computation without sugar, division by pairs\n";
 	  lexico:=true;
 	  sugar_flag := false;
 	  divide_rem_with_critical_pair := true
-      |7 -> info "ordre lexico calcul avec sugar, division par les paires\n";
+      |7 -> info "ordre lexico computation with sugar, division by pairs\n";
 	  lexico:=true;
 	  sugar_flag := true;
 	  divide_rem_with_critical_pair := true
@@ -534,6 +541,7 @@ let theoremedeszeros_termes lp =
       | p::lp1 ->
 	  let lpol = List.rev lp1 in
 	  let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
+          info "cert ok\n";
 	  let lc = cert.last_comb::List.rev cert.gb_comb in
 	  match remove_zeros (fun x -> x=zeroP) lc with
 	  | [] -> assert false
@@ -545,8 +553,8 @@ let theoremedeszeros_termes lp =
 	      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";
+	      info ("number of parametres: "^string_of_int nparam^"\n");
+	      info "term computed\n";
 	      (c,r,lci,lq)
       )
   |_ -> assert false
@@ -565,7 +573,7 @@ let nsatz lpol =
   let certif = hash_certif certif in
   let certif = certif_term certif in
   let c = mkt_term c in
-  info "constr calcule\n";
+  info "constr computed\n";
   (c, certif)
 *)
 
@@ -586,7 +594,7 @@ let nsatz lpol =
 	 mkt_app lcons [tlp ();ltterm;r])
       res
       (mkt_app lnil [tlp ()]) in
-  info "terme calcule\n";
+  info "term computed\n";
   res
 
 let return_term t =
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
index ee7b9f33..45fcb2d2 100644
--- a/plugins/nsatz/polynom.ml
+++ b/plugins/nsatz/polynom.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -282,12 +282,11 @@ let rec multx n v p =
           p2.(i+n)<-p1.(i);
         done;
         Prec (x,p2)
-    |_ -> if p = (Pint coef0) then (Pint coef0)
+    |_ -> if equal 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
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
index 980a8306..b82b43b1 100644
--- a/plugins/nsatz/polynom.mli
+++ b/plugins/nsatz/polynom.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index c8a06265..3f9d0f44 100644
--- a/plugins/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,8 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: Omega.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* We do not require [ZArith] anymore, but only what's necessary for Omega *)
 Require Export ZArith_base.
 Require Export OmegaLemmas.
diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
index ec9faedd..5b6f4670 100644
--- a/plugins/omega/OmegaLemmas.v
+++ b/plugins/omega/OmegaLemmas.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: OmegaLemmas.v 12337 2009-09-17 15:58:14Z glondu $ i*)
-
 Require Import ZArith_base.
 Open Local Scope Z_scope.
 
@@ -300,3 +298,10 @@ Definition fast_Zred_factor5 (x y : 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).
+
+Theorem intro_Z :
+  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+Proof.
+  intros n; exists (Z_of_nat n); split; trivial.
+  rewrite Zmult_1_r, Zplus_0_r. apply Zle_0_nat.
+Qed.
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
index 69a6ea72..a3ab34a9 100644
--- a/plugins/omega/OmegaPlugin.v
+++ b/plugins/omega/OmegaPlugin.v
@@ -1,11 +1,9 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: OmegaPlugin.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Declare ML Module "omega_plugin".
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
index a5a085a9..46fd5682 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -28,7 +28,7 @@ Open Local Scope Z_scope.
 
 Ltac zify_unop_core t thm a :=
  (* Let's introduce the specification theorem for t *)
- let H:= fresh "H" in assert (H:=thm a);
+ pose proof (thm a);
  (* Then we replace (t a) everywhere with a fresh variable *)
  let z := fresh "z" in set (z:=t a) in *; clearbody z.
 
@@ -159,11 +159,9 @@ Ltac zify_nat_op :=
 
   (* mult -> Zmult and a positivity hypothesis *)
   | 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 *
+        pose proof (Zle_0_nat (mult a b)); rewrite (inj_mult a b) 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 *
+        pose proof (Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
 
   (* O -> Z0 *)
   | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
@@ -184,20 +182,9 @@ Ltac zify_nat_op :=
      end
 
   (* 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
-          | 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
+  | _ : 0 <= Z_of_nat ?a |- _ => hide_Z_of_nat a
+  | _ : context [ Z_of_nat ?a ] |- _ => pose proof (Zle_0_nat a); hide_Z_of_nat a
+  | |- context [ Z_of_nat ?a ] => pose proof (Zle_0_nat a); hide_Z_of_nat a
  end.
 
 Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
@@ -223,17 +210,17 @@ Ltac zify_positive_rel :=
   | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
   | |- context [ @eq positive ?a ?b ] =>       rewrite (Zpos_eq_iff a b)
   (* II: less than *)
-  | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
-  | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
+  | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
+  | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
   (* III: less or equal *)
-  | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
-  | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
+  | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
+  | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
   (* IV: greater than *)
-  | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
-  | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
+  | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
+  | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
   (* V: greater or equal *)
-  | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
-  | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
+  | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
+  | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
  end.
 
 Ltac zify_positive_op :=
@@ -282,11 +269,9 @@ Ltac zify_positive_op :=
 
   (* Pmult -> Zmult and a positivity hypothesis *)
   | 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 *
+        pose proof (Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) 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 *
+        pose proof (Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
 
   (* xO *)
   | H : context [ Zpos (xO ?a) ] |- _ =>
@@ -320,18 +305,9 @@ 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' : 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
-         | 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
+  | _ : Zpos ?a > 0 |- _ => hide_Zpos a
+  | _ : context [ Zpos ?a ] |- _ => pose proof (Zgt_pos_0 a); hide_Zpos a
+  | |- context [ Zpos ?a ] => pose proof (Zgt_pos_0 a); hide_Zpos a
  end.
 
 Ltac zify_positive :=
@@ -358,25 +334,25 @@ Ltac zify_N_rel :=
   | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
   | |- context [ @eq N ?a ?b ] =>       rewrite (Z_of_N_eq_iff a b)
   (* II: less than *)
-  | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
-  | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
-  | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
-  | |- context [ (?a<?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
+  | H : (?a < ?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
+  | |- (?a < ?b)%N => apply (Z_of_N_lt_rev a b)
+  | H : context [ (?a < ?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
+  | |- context [ (?a < ?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
   (* III: less or equal *)
-  | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
-  | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b)
-  | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
-  | |- context [ (?a<=?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
+  | H : (?a <= ?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
+  | |- (?a <= ?b)%N => apply (Z_of_N_le_rev a b)
+  | H : context [ (?a <= ?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
+  | |- context [ (?a <= ?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
   (* IV: greater than *)
-  | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
-  | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b)
-  | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
-  | |- context [ (?a>?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
+  | H : (?a > ?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
+  | |- (?a > ?b)%N => apply (Z_of_N_gt_rev a b)
+  | H : context [ (?a > ?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
+  | |- context [ (?a > ?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
   (* V: greater or equal *)
-  | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
-  | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b)
-  | 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)
+  | H : (?a >= ?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
+  | |- (?a >= ?b)%N => apply (Z_of_N_ge_rev a b)
+  | 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 :=
@@ -413,25 +389,14 @@ Ltac zify_N_op :=
 
   (* Nmult -> Zmult and a positivity hypothesis *)
   | 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 *
+        pose proof (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
-        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+        pose proof (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
-         | 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
-         | 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
+  | _ : 0 <= Z_of_N ?a |- _ => hide_Z_of_N a
+  | _ : context [ Z_of_N ?a ] |- _ => pose proof (Z_of_N_le_0 a); hide_Z_of_N a
+  | |- context [ Z_of_N ?a ] => pose proof (Z_of_N_le_0 a); hide_Z_of_N a
  end.
 
 Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 20565d06..d7dfe149 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,8 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: coq_omega.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Reduction
@@ -22,7 +20,6 @@ open Proof_type
 open Names
 open Nameops
 open Term
-open Termops
 open Declarations
 open Environ
 open Sign
@@ -60,6 +57,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Omega system time displaying flag";
       optkey   = ["Omega";"System"];
       optread  = read display_system_flag;
@@ -68,6 +66,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Omega action display flag";
       optkey   = ["Omega";"Action"];
       optread  = read display_action_flag;
@@ -76,6 +75,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Omega old style flag";
       optkey   = ["Omega";"OldStyle"];
       optread  = read old_style_flag;
@@ -128,12 +128,12 @@ let intern_id,unintern_id =
 
 let mk_then = tclTHENLIST
 
-let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c])
+let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c])
 
 let generalize_tac t = generalize_time (generalize t)
 let elim t = elim_time (simplest_elim t)
 let exact t = exact_time (Tactics.refine t)
-let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
+let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s]
 
 let rev_assoc k =
   let rec loop = function
@@ -150,7 +150,7 @@ let tag_hypothesis,tag_of_hyp, hyp_of_tag =
 let hide_constr,find_constr,clear_tables,dump_tables =
   let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
   (fun h id eg b -> l := (h,(id,eg,b)):: !l),
-  (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"),
+  (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"),
   (fun () -> l := []),
   (fun () -> !l)
 
@@ -169,6 +169,8 @@ let coq_modules =
 let init_constant = gen_constant_in_modules "Omega" init_modules
 let constant = gen_constant_in_modules "Omega" coq_modules
 
+let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]]
+
 (* Zarith *)
 let coq_xH = lazy (constant "xH")
 let coq_xO = lazy (constant "xO")
@@ -184,6 +186,7 @@ let coq_Zmult = lazy (constant "Zmult")
 let coq_Zopp = lazy (constant "Zopp")
 let coq_Zminus = lazy (constant "Zminus")
 let coq_Zsucc = lazy (constant "Zsucc")
+let coq_Zpred = lazy (constant "Zpred")
 let coq_Zgt = lazy (constant "Zgt")
 let coq_Zle = lazy (constant "Zle")
 let coq_Z_of_nat = lazy (constant "Z_of_nat")
@@ -191,13 +194,13 @@ let coq_inj_plus = lazy (constant "inj_plus")
 let coq_inj_mult = lazy (constant "inj_mult")
 let coq_inj_minus1 = lazy (constant "inj_minus1")
 let coq_inj_minus2 = lazy (constant "inj_minus2")
-let coq_inj_S = lazy (constant "inj_S")
-let coq_inj_le = lazy (constant "inj_le")
-let coq_inj_lt = lazy (constant "inj_lt")
-let coq_inj_ge = lazy (constant "inj_ge")
-let coq_inj_gt = lazy (constant "inj_gt")
-let coq_inj_neq = lazy (constant "inj_neq")
-let coq_inj_eq = lazy (constant "inj_eq")
+let coq_inj_S = lazy (z_constant "inj_S")
+let coq_inj_le = lazy (z_constant "Znat.inj_le")
+let coq_inj_lt = lazy (z_constant "Znat.inj_lt")
+let coq_inj_ge = lazy (z_constant "Znat.inj_ge")
+let coq_inj_gt = lazy (z_constant "Znat.inj_gt")
+let coq_inj_neq = lazy (z_constant "inj_neq")
+let coq_inj_eq = lazy (z_constant "inj_eq")
 let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse")
 let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc")
 let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse")
@@ -255,6 +258,7 @@ let coq_dec_Zgt = lazy (constant "dec_Zgt")
 let coq_dec_Zge = lazy (constant "dec_Zge")
 
 let coq_not_Zeq = lazy (constant "not_Zeq")
+let coq_not_Zne = lazy (constant "not_Zne")
 let coq_Znot_le_gt = lazy (constant "Znot_le_gt")
 let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge")
 let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt")
@@ -323,6 +327,7 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
   | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
 
 let sp_Zsucc =     lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc)
+let sp_Zpred =     lazy (evaluable_ref_of_constr "Zpred" coq_Zpred)
 let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus)
 let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle)
 let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt)
@@ -356,7 +361,7 @@ let mk_integer n =
 		 [| loop (abs n) |])
 
 type omega_constant =
-  | Zplus | Zmult | Zminus | Zsucc | Zopp
+  | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred
   | Plus | Mult | Minus | Pred | S | O
   | Zpos | Zneg | Z0 | Z_of_nat
   | Eq | Neq
@@ -376,32 +381,39 @@ type result =
   | Kimp of constr * constr
   | Kufo
 
+(* Nota: Kimp correspond to a binder (Prod), but hopefully we won't
+   have to bother with term lifting: Kimp will correspond to anonymous
+   product, for which (Rel 1) doesn't occur in the right term.
+   Moreover, we'll work on fully introduced goals, hence no Rel's in
+   the term parts that we manipulate, but rather Var's.
+   Said otherwise: all constr manipulated here are closed *)
+
 let destructurate_prop t =
   let c, args = decompose_app t in
   match kind_of_term c, args with
-    | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args)
-    | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args)
-    | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args)
-    | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args)
-    | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args)
-    | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args)
-    | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args)
-    | _, [_;_] when c = build_coq_and () -> Kapp (And,args)
-    | _, [_;_] when c = build_coq_or () -> Kapp (Or,args)
-    | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args)
-    | _, [_] when c = build_coq_not () -> Kapp (Not,args)
-    | _, [] when c = build_coq_False () -> Kapp (False,args)
-    | _, [] when c = build_coq_True () -> Kapp (True,args)
-    | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args)
-    | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args)
-    | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args)
-    | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args)
+    | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args)
+    | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args)
+    | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args)
+    | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args)
+    | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args)
+    | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args)
     | Const sp, args ->
-	Kapp (Other (string_of_id (basename_of_global (ConstRef sp))),args)
+	Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args)
     | Construct csp , args ->
-	Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args)
+	Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args)
     | Ind isp, args ->
-	Kapp (Other (string_of_id (basename_of_global (IndRef isp))),args)
+	Kapp (Other (string_of_path (path_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"
@@ -410,43 +422,44 @@ let destructurate_prop t =
 let destructurate_type t =
   let c, args = decompose_app t in
   match kind_of_term c, args with
-    | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args)
-    | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args)
+    | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args)
+    | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args)
     | _ -> Kufo
 
 let destructurate_term t =
   let c, args = decompose_app t in
   match kind_of_term c, args with
-    | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args)
-    | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args)
-    | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args)
-    | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args)
-    | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args)
-    | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args)
-    | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args)
-    | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args)
-    | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args)
-    | _, [_] when c = Lazy.force coq_S -> Kapp (S,args)
-    | _, [] when c = Lazy.force coq_O -> Kapp (O,args)
-    | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args)
-    | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args)
-    | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args)
-    | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args)
+    | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args)
+    | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args)
+    | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args)
+    | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args)
+    | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args)
+    | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args)
     | Var id,[] -> Kvar id
     | _ -> Kufo
 
 let recognize_number t =
   let rec loop t =
     match decompose_app t with
-      | 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
+      | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t
+      | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t
+      | f, [] when eq_constr f (Lazy.force coq_xH) -> one
       | _ -> failwith "not a number"
   in
   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
+    | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t
+    | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t)
+    | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero
     | _ -> failwith "not a number"
 
 type constr_path =
@@ -891,6 +904,10 @@ let rec transform p t =
 	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
 					 [| t1; mk_integer one |])) in
 	unfold sp_Zsucc :: tac,t
+    | Kapp(Zpred,[t1]) ->
+	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
+					 [| t1; mk_integer negone |])) in
+	unfold sp_Zpred :: tac,t
    | Kapp(Zmult,[t1;t2]) ->
        let tac1,t1' = transform (P_APP 1 :: p) t1
        and tac2,t2' = transform (P_APP 2 :: p) t2 in
@@ -1548,6 +1565,38 @@ let nat_inject gl =
   in
   loop (List.rev (pf_hyps_types gl)) gl
 
+let dec_binop = function
+  | Zne -> coq_dec_Zne
+  | Zle -> coq_dec_Zle
+  | Zlt -> coq_dec_Zlt
+  | Zge -> coq_dec_Zge
+  | Zgt -> coq_dec_Zgt
+  | Le -> coq_dec_le
+  | Lt -> coq_dec_lt
+  | Ge -> coq_dec_ge
+  | Gt -> coq_dec_gt
+  | _ -> raise Not_found
+
+let not_binop = function
+  | Zne -> coq_not_Zne
+  | Zle -> coq_Znot_le_gt
+  | Zlt -> coq_Znot_lt_ge
+  | Zge -> coq_Znot_ge_lt
+  | Zgt -> coq_Znot_gt_le
+  | Le -> coq_not_le
+  | Lt -> coq_not_lt
+  | Ge -> coq_not_ge
+  | Gt -> coq_not_gt
+  | _ -> raise Not_found
+
+(** A decidability check : for some [t], could we build a term
+    of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise
+    [Undecidable]. Note that a successful check implies that
+    [t] has type Prop.
+*)
+
+exception Undecidable
+
 let rec decidability gl t =
   match destructurate_prop t with
     | Kapp(Or,[t1;t2]) ->
@@ -1560,34 +1609,24 @@ let rec decidability gl t =
 	mkApp (Lazy.force coq_dec_iff, [| t1; t2;
 		  decidability gl t1; decidability gl 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;
-				    decidability gl t1 |])
+        (* This is the only situation where it's not obvious that [t]
+	   is in Prop. The recursive call on [t2] will ensure that. *)
+        mkApp (Lazy.force coq_dec_imp,
+		 [| t1; t2; decidability gl t1; decidability gl t2 |])
+    | Kapp(Not,[t1]) ->
+        mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |])
     | 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 " ++
-		   Printer.pr_lconstr typ)
+          | _ -> raise Undecidable
 	end
-    | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |])
-    | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |])
-    | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |])
-    | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |])
-    | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |])
-    | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |])
-    | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |])
-    | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |])
-    | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |])
+    | Kapp(op,[t1;t2]) ->
+        (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |])
+	 with Not_found -> raise Undecidable)
     | Kapp(False,[]) -> Lazy.force coq_dec_False
     | Kapp(True,[]) -> Lazy.force coq_dec_True
-    | 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"
-    | _ -> error "Omega: Unrecognized proposition"
+    | _ -> raise Undecidable
 
 let onClearedName id tac =
   (* We cannot ensure that hyps can be cleared (because of dependencies), *)
@@ -1598,6 +1637,14 @@ let onClearedName id tac =
       let id = fresh_id [] id gl in
       tclTHEN (introduction id) (tac id) gl)
 
+let onClearedName2 id tac =
+  tclTHEN
+    (tclTRY (clear [id]))
+    (fun gl ->
+      let id1 = fresh_id [] (add_suffix id "_left") gl in
+      let id2 = fresh_id [] (add_suffix id "_right") gl in
+      tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] gl)
+
 let destructure_hyps gl =
   let rec loop = function
     | [] -> (tclTHEN nat_inject coq_omega)
@@ -1611,50 +1658,24 @@ let destructure_hyps gl =
                 [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
                   onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
           | Kapp(And,[t1;t2]) ->
-              tclTHENLIST [
-                (elim_id i);
-		(tclTRY (clear [i]));
-		(fun gl ->
-		  let i1 = fresh_id [] (add_suffix i "_left") gl in
-		  let i2 = fresh_id [] (add_suffix i "_right") gl in
-		  tclTHENLIST [
-		    (introduction i1);
-		    (introduction i2);
-		    (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl)
-	      ]
+              tclTHEN
+		(elim_id i)
+		(onClearedName2 i (fun i1 i2 ->
+		  loop ((i1,None,t1)::(i2,None,t2)::lit)))
           | Kapp(Iff,[t1;t2]) ->
-              tclTHENLIST [
-                (elim_id i);
-		(tclTRY (clear [i]));
-		(fun gl ->
-		  let i1 = fresh_id [] (add_suffix i "_left") gl in
-		  let i2 = fresh_id [] (add_suffix i "_right") gl in
-		  tclTHENLIST [
-		    introduction i1;
-		    generalize_tac
-		      [mkApp (Lazy.force coq_imp_simp,
-                        [| t1; t2; decidability gl t1; mkVar i1|])];
-		    onClearedName i1 (fun i1 ->
-		      tclTHENLIST [
-			introduction i2;
-			generalize_tac
-			  [mkApp (Lazy.force coq_imp_simp,
-                            [| t2; t1; decidability gl t2; mkVar i2|])];
-			onClearedName i2 (fun i2 ->
-			  loop
-			  ((i1,None,mk_or (mk_not t1) t2)::
-			   (i2,None,mk_or (mk_not t2) t1)::lit))
-		      ])] gl)
-	      ]
+	      tclTHEN
+		(elim_id i)
+		(onClearedName2 i (fun i1 i2 ->
+		  loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit)))
           | Kimp(t1,t2) ->
-              if
-                is_Prop (pf_type_of gl t1) &
-                is_Prop (pf_type_of gl t2) &
-                closed0 t2
+	      (* t1 and t2 might be in Type rather than Prop.
+		 For t1, the decidability check will ensure being Prop. *)
+              if is_Prop (pf_type_of gl t2)
               then
+		let d1 = decidability gl t1 in
 		tclTHENLIST [
 		  (generalize_tac [mkApp (Lazy.force coq_imp_simp,
-                    [| t1; t2; decidability gl t1; mkVar i|])]);
+                    [| t1; t2; d1; mkVar i|])]);
 		  (onClearedName i (fun i ->
 		    (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
                 ]
@@ -1670,86 +1691,53 @@ let destructure_hyps gl =
                         (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
                     ]
 		| Kapp(And,[t1;t2]) ->
+		    let d1 = decidability gl t1 in
                     tclTHENLIST [
 		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_and, [| t1; t2;
-			  decidability gl t1; mkVar i|])]);
+		        [mkApp (Lazy.force coq_not_and,
+				[| t1; t2; d1; mkVar i |])]);
 		      (onClearedName i (fun i ->
                         (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
                     ]
 		| Kapp(Iff,[t1;t2]) ->
+		    let d1 = decidability gl t1 in
+		    let d2 = decidability gl t2 in
                     tclTHENLIST [
 		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_iff, [| t1; t2;
-			  decidability gl t1; decidability gl t2; mkVar i|])]);
+		        [mkApp (Lazy.force coq_not_iff,
+				[| t1; t2; d1; d2; mkVar i |])]);
 		      (onClearedName i (fun i ->
                         (loop ((i,None,
 			        mk_or (mk_and t1 (mk_not t2))
 				      (mk_and (mk_not t1) t2))::lit))))
                     ]
 		| Kimp(t1,t2) ->
+		    (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok.
+		       For t1, being decidable implies being Prop. *)
+		    let d1 = decidability gl t1 in
                     tclTHENLIST [
 		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_imp, [| t1; t2;
-		          decidability gl t1;mkVar i |])]);
+		        [mkApp (Lazy.force coq_not_imp,
+				[| t1; t2; d1; mkVar i |])]);
 		      (onClearedName i (fun i ->
                         (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
                     ]
 		| Kapp(Not,[t]) ->
+		    let d = decidability gl t in
                     tclTHENLIST [
 		      (generalize_tac
-			[mkApp (Lazy.force coq_not_not, [| t;
-			  decidability gl t; mkVar i |])]);
+			[mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
 		      (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
                     ]
-		| Kapp(Zle, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zge, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zlt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zgt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Le, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Ge, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Lt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Gt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
+		| Kapp(op,[t1;t2]) ->
+		    (try
+		      let thm = not_binop op in
+                      tclTHENLIST [
+			(generalize_tac
+			   [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
+			(onClearedName i (fun _ -> loop lit))
+                      ]
+		     with Not_found -> loop lit)
 		| Kapp(Eq,[typ;t1;t2]) ->
                     if !old_style_flag then begin
 		      match destructurate_type (pf_nf gl typ) with
@@ -1787,7 +1775,9 @@ let destructure_hyps gl =
 		| _ -> loop lit
               end
           | _ -> loop lit
-	with e when catchable_exception e -> loop lit
+	with
+	  | Undecidable -> loop lit
+	  | e when catchable_exception e -> loop lit
 	end
   in
   loop (pf_hyps gl) gl
@@ -1803,13 +1793,16 @@ let destructure_goal gl =
       | Kimp(a,b) -> (tclTHEN intro (loop b))
       | Kapp(False,[]) -> destructure_hyps
       | _ ->
-          (tclTHEN
-	     (tclTHEN
-		(Tactics.refine
-		   (mkApp (Lazy.force coq_dec_not_not, [| t;
-			      decidability gl t; mkNewMeta () |])))
-		intro)
-	     (destructure_hyps))
+	let goal_tac =
+	  try
+	    let dec = decidability gl t in
+	    tclTHEN
+	      (Tactics.refine
+		 (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))
+	      intro
+	  with Undecidable -> Tactics.elim_type (build_coq_False ())
+	in
+	tclTHEN goal_tac destructure_hyps
   in
   (loop concl) gl
 
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index cd6472c3..84cc8464 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -15,8 +15,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_omega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Coq_omega
 open Refiner
 
diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml
index 8bb10194..3a5aece7 100644
--- a/plugins/omega/omega.ml
+++ b/plugins/omega/omega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -214,7 +214,7 @@ let rec display_action print_var = function
             constant factors.\n" e1.id e2.id
       | NEGATE_CONTRADICT(e1,e2,b) ->
           Printf.printf
-            "Equations E%d and E%d state that their body is at the same time
+            "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) ->
           Printf.printf "Equation E%d states %s = 0.\n" e (sbi k)
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
index 1485c147..04cbdccb 100644
--- a/plugins/pluginsbyte.itarget
+++ b/plugins/pluginsbyte.itarget
@@ -1,6 +1,7 @@
 field/field_plugin.cma
 setoid_ring/newring_plugin.cma
 extraction/extraction_plugin.cma
+decl_mode/decl_mode_plugin.cma
 firstorder/ground_plugin.cma
 rtauto/rtauto_plugin.cma
 fourier/fourier_plugin.cma
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
index 5d502411..bbadfe69 100644
--- a/plugins/pluginsdyn.itarget
+++ b/plugins/pluginsdyn.itarget
@@ -1,6 +1,7 @@
 field/field_plugin.cmxs
 setoid_ring/newring_plugin.cmxs
 extraction/extraction_plugin.cmxs
+decl_mode/decl_mode_plugin.cmxs
 firstorder/ground_plugin.cmxs
 rtauto/rtauto_plugin.cmxs
 fourier/fourier_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
index 2f72dab8..74b3f527 100644
--- a/plugins/pluginsopt.itarget
+++ b/plugins/pluginsopt.itarget
@@ -1,6 +1,7 @@
 field/field_plugin.cmxa
 setoid_ring/newring_plugin.cmxa
 extraction/extraction_plugin.cmxa
+decl_mode/decl_mode_plugin.cmxa
 firstorder/ground_plugin.cmxa
 rtauto/rtauto_plugin.cmxa
 fourier/fourier_plugin.cmxa
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
index 55bb8bae..e2d8e67e 100644
--- a/plugins/quote/Quote.v
+++ b/plugins/quote/Quote.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Quote.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Declare ML Module "quote_plugin".
 
 (***********************************************************************
@@ -28,7 +26,6 @@ Declare ML Module "quote_plugin".
 ***********************************************************************)
 
 Set Implicit Arguments.
-Unset Boxed Definitions.
 
 Section variables_map.
 
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index 3c51223a..1f4ea97f 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,14 +8,12 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_quote.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Tacexpr
 open Quote
 
 let make_cont k x =
-  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst k)) in
+  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> k)) in
   let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
   let tac = <:tactic<let cont := $k in cont $x>> in
   Tacinterp.interp tac
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index baba7e1b..fbb75420 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: quote.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* The `Quote' tactic *)
 
 (* The basic idea is to automatize the inversion of interpetation functions
@@ -111,7 +109,6 @@ open Pattern
 open Matching
 open Tacmach
 open Tactics
-open Proof_trees
 open Tacexpr
 (*i*)
 
@@ -169,7 +166,7 @@ exchange ?1 and ?2 in the example above)
 module ConstrSet = Set.Make(
   struct
     type t = constr
-    let compare = (Pervasives.compare : t->t->int)
+    let compare = constr_ord
   end)
 
 type inversion_scheme = {
@@ -211,7 +208,7 @@ let compute_lhs typ i nargsi =
 let compute_rhs bodyi index_of_f =
   let rec aux c =
     match kind_of_term c with
-      | App (j, args) when j = mkRel (index_of_f) (* recursive call *) ->
+      | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) ->
           let i = destRel (array_last args) in
 	  PMeta (Some (coerce_meta_in i))
       | App (f,args) ->
@@ -243,7 +240,7 @@ let compute_ivs gl f cs =
            (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
            (* REL 1 to REL nargsi are argsi (reverse order) *)
            (* First we test if the RHS is the RHS for constants *)
-                   if bodyi = mkRel 1 then
+                   if isRel bodyi && destRel bodyi = 1 then
                      c_lhs := Some (compute_lhs (snd (List.hd args3))
                                       i nargsi)
            (* Then we test if the RHS is the RHS for variables *)
@@ -373,13 +370,19 @@ let rec subterm gl (t : constr) (t' : constr) =
 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 as l) when eq_constr 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 -> insert h (sort_subterm gl t)
 
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+
 (*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.
@@ -387,10 +390,9 @@ let rec sort_subterm gl l =
   [ivs : inversion_scheme]\\
   [lc: constr list]\\
   [gl: goal sigma]\\ *)
-
 let quote_terms ivs lc gl =
   Coqlib.check_required_library ["Coq";"quote";"Quote"];
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   let rec aux c =
@@ -417,7 +419,7 @@ let quote_terms ivs lc gl =
 			 Termops.subst_meta [1, c] c_lhs
                      | _ ->
 			 begin
-                           try Hashtbl.find varhash c
+                           try Constrhash.find varhash c
                            with Not_found ->
                              let newvar =
                                Termops.subst_meta [1, (path_of_int !counter)]
@@ -425,7 +427,7 @@ let quote_terms ivs lc gl =
                              begin
                                incr counter;
                                varlist := c :: !varlist;
-                               Hashtbl.add varhash c newvar;
+                               Constrhash.add varhash c newvar;
                                newvar
                              end
 			 end
@@ -473,7 +475,7 @@ Just testing ...
 #use "include.ml";;
 open Quote;;
 
-let r = raw_constr_of_string;;
+let r = glob_constr_of_string;;
 
 let ivs = {
   normal_lhs_rhs =
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
index 2de16bc1..fd5bcd93 100644
--- a/plugins/ring/LegacyArithRing.v
+++ b/plugins/ring/LegacyArithRing.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Instantiation of the Ring tactic for the naturals of Arith $*)
 
 Require Import Bool.
@@ -17,7 +15,7 @@ Require Import Eqdep_dec.
 
 Open Local Scope nat_scope.
 
-Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
+Fixpoint nateq (n m:nat) {struct m} : bool :=
   match n, m with
   | O, O => true
   | S n', S m' => nateq n' m'
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
index ae7e62e0..5dcd6d84 100644
--- a/plugins/ring/LegacyNArithRing.v
+++ b/plugins/ring/LegacyNArithRing.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyNArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Instantiation of the Ring tactic for the binary natural numbers *)
 
 Require Import Bool.
@@ -16,7 +14,7 @@ Require Export ZArith_base.
 Require Import NArith.
 Require Import Eqdep_dec.
 
-Unboxed Definition Neq (n m:N) :=
+Definition Neq (n m:N) :=
   match (n ?= m)%N with
   | Datatypes.Eq => true
   | _ => false
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
index e53e60d3..d19e9f58 100644
--- a/plugins/ring/LegacyRing.v
+++ b/plugins/ring/LegacyRing.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Bool.
 Require Export LegacyRing_theory.
 Require Export Quote.
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
index bf61aee1..ca3355a6 100644
--- a/plugins/ring/LegacyRing_theory.v
+++ b/plugins/ring/LegacyRing_theory.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyRing_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Bool.
 
 Set Implicit Arguments.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
index d1412104..5845062d 100644
--- a/plugins/ring/LegacyZArithRing.v
+++ b/plugins/ring/LegacyZArithRing.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyZArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Instantiation of the Ring tactic for the binary integers of ZArith *)
 
 Require Export LegacyArithRing.
@@ -15,7 +13,7 @@ Require Export ZArith_base.
 Require Import Eqdep_dec.
 Require Import LegacyRing.
 
-Unboxed Definition Zeq (x y:Z) :=
+Definition Zeq (x y:Z) :=
   match (x ?= y)%Z with
   | Datatypes.Eq => true
   | _ => false
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
index e6e2dda9..1763d70a 100644
--- a/plugins/ring/Ring_abstract.v
+++ b/plugins/ring/Ring_abstract.v
@@ -1,19 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_abstract.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import LegacyRing_theory.
 Require Import Quote.
 Require Import Ring_normalize.
 
-Unset Boxed Definitions.
-
 Section abstract_semi_rings.
 
 Inductive aspolynomial : Type :=
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
index dd4e7314..c6dff3e0 100644
--- a/plugins/ring/Ring_normalize.v
+++ b/plugins/ring/Ring_normalize.v
@@ -1,18 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import LegacyRing_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.
@@ -749,11 +746,11 @@ Qed.
 (* End properties. *)
 End semi_rings.
 
-Implicit Arguments Cons_varlist.
-Implicit Arguments Cons_monom.
-Implicit Arguments SPconst.
-Implicit Arguments SPplus.
-Implicit Arguments SPmult.
+Arguments Cons_varlist : default implicits.
+Arguments Cons_monom : default implicits.
+Arguments SPconst : default implicits.
+Arguments SPplus : default implicits.
+Arguments SPmult : default implicits.
 
 Section rings.
 
diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
index da4e3756..106a946d 100644
--- a/plugins/ring/Setoid_ring.v
+++ b/plugins/ring/Setoid_ring.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Setoid_ring_theory.
 Require Export Quote.
 Require Export Setoid_ring_normalize.
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
index c4527cfb..ad75a8a4 100644
--- a/plugins/ring/Setoid_ring_normalize.v
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -1,18 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 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.
@@ -1014,11 +1011,11 @@ Qed.
 
 End semi_setoid_rings.
 
-Implicit Arguments Cons_varlist.
-Implicit Arguments Cons_monom.
-Implicit Arguments SetSPconst.
-Implicit Arguments SetSPplus.
-Implicit Arguments SetSPmult.
+Arguments Cons_varlist : default implicits.
+Arguments Cons_monom : default implicits.
+Arguments SetSPconst : default implicits.
+Arguments SetSPplus : default implicits.
+Arguments SetSPmult : default implicits.
 
 
 
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
index f07cbaf6..dd722f80 100644
--- a/plugins/ring/Setoid_ring_theory.v
+++ b/plugins/ring/Setoid_ring_theory.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Bool.
 Require Export Setoid.
 
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
index c5a33f39..e306a531 100644
--- a/plugins/ring/g_ring.ml4
+++ b/plugins/ring/g_ring.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_ring.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Quote
 open Ring
 open Tacticals
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
index 6e67272c..98d6361c 100644
--- a/plugins/ring/ring.ml
+++ b/plugins/ring/ring.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ring.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* ML part of the Ring tactic *)
 
 open Pp
@@ -21,7 +19,6 @@ open Reductionops
 open Tacticals
 open Tacexpr
 open Tacmach
-open Proof_trees
 open Printer
 open Equality
 open Vernacinterp
@@ -138,7 +135,7 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
 module OperSet =
   Set.Make (struct
 	      type t = global_reference
-	      let compare = (Pervasives.compare : t->t->int)
+	      let compare = (RefOrdered.compare : t->t->int)
 	    end)
 
 type morph =
@@ -169,7 +166,7 @@ type theory =
 (* 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)
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
 
 let theories_map = ref Cmap.empty
 
@@ -265,7 +262,7 @@ let subst_th (subst,(c,th as obj)) =
       (c',th')
 
 
-let (theory_to_obj, obj_to_theory) =
+let theory_to_obj : constr * theory -> obj =
   let cache_th (_,(c, th)) = theories_map_add (c,th) in
   declare_object {(default_object "tactic-ring-theory") with
 		    open_function = (fun i o -> if i=1 then cache_th o);
@@ -380,8 +377,14 @@ Builds
 
 *)
 
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+
 let build_spolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   (* aux creates the spolynom p by a recursive destructuration of c
@@ -395,14 +398,14 @@ let build_spolynom gl th lc =
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SPconst, [|th.th_a; c |])
       | _ ->
-	  try Hashtbl.find varhash c
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -437,7 +440,7 @@ Builds
 *)
 
 let build_polynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   let rec aux c =
@@ -458,14 +461,14 @@ let build_polynom gl th lc =
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_Pconst, [|th.th_a; c |])
       | _ ->
-	  try Hashtbl.find varhash c
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -501,7 +504,7 @@ Builds
 *)
 
 let build_aspolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   (* aux creates the aspolynom p by a recursive destructuration of c
@@ -515,13 +518,13 @@ let build_aspolynom gl th lc =
       | _ 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
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -555,7 +558,7 @@ Builds
 *)
 
 let build_apolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   let rec aux c =
@@ -575,14 +578,14 @@ let build_apolynom gl th lc =
       | _ 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
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_APvar, [| path_of_int !counter |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -616,7 +619,7 @@ Builds
 *)
 
 let build_setpolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   let rec aux c =
@@ -637,14 +640,14 @@ let build_setpolynom gl th lc =
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SetPconst, [| th.th_a; c |])
       | _ ->
-	  try Hashtbl.find varhash c
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -683,7 +686,7 @@ Builds
 *)
 
 let build_setspolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
   let rec aux c =
@@ -695,14 +698,14 @@ let build_setspolynom gl th lc =
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
       | _ ->
-	  try Hashtbl.find varhash c
+	  try Constrhash.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
 	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
+	      Constrhash.add varhash c newvar;
 	      newvar
 	    end
   in
@@ -823,9 +826,9 @@ let raw_polynom th op lc gl =
 	      (tclTHENS
 		 (tclORELSE
                    (Equality.general_rewrite true
-		     Termops.all_occurrences false c'i_eq_c''i)
+		     Termops.all_occurrences true false c'i_eq_c''i)
                    (Equality.general_rewrite false
-		     Termops.all_occurrences false c'i_eq_c''i))
+		     Termops.all_occurrences true false c'i_eq_c''i))
                  [tac]))
 	 else
            (tclORELSE
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index c82abfc8..56ae921e 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -868,11 +868,11 @@ Inductive term : Set :=
   | Tvar : nat -> term.
 
 Delimit Scope romega_scope with term.
-Arguments Scope Tint [Int_scope].
-Arguments Scope Tplus [romega_scope romega_scope].
-Arguments Scope Tmult [romega_scope romega_scope].
-Arguments Scope Tminus [romega_scope romega_scope].
-Arguments Scope Topp [romega_scope romega_scope].
+Arguments Tint _%I.
+Arguments Tplus (_ _)%term.
+Arguments Tmult (_ _)%term.
+Arguments Tminus (_ _)%term.
+Arguments Topp _%term.
 
 Infix "+" := Tplus : romega_scope.
 Infix "*" := Tmult : romega_scope.
@@ -1014,7 +1014,7 @@ Inductive h_step : Set :=
 (* 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. *)
+   conjunction with possibly the right level of negations. *)
 
 Inductive direction : Set :=
   | D_left : direction
@@ -2038,12 +2038,12 @@ Qed.
 (* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
 
 
-Fixpoint rewrite (s : step) : term -> term :=
+Fixpoint t_rewrite (s : step) : term -> term :=
   match s with
-  | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2)
-  | C_LEFT s => apply_left (rewrite s)
-  | C_RIGHT s => apply_right (rewrite s)
-  | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t)
+  | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2)
+  | C_LEFT s => apply_left (t_rewrite s)
+  | C_RIGHT s => apply_right (t_rewrite s)
+  | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t)
   | C_NOP => fun t : term => t
   | C_OPP_PLUS => Topp_plus
   | C_OPP_OPP => Topp_opp
@@ -2069,7 +2069,7 @@ Fixpoint rewrite (s : step) : term -> term :=
   | C_MULT_COMM => Tmult_comm
   end.
 
-Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
+Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s).
 Proof.
  simple induction s; simpl in |- *;
  [ intros; apply apply_both_stable; auto
@@ -2453,7 +2453,7 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
       match prop2 with
       | EqTerm b2 b3 =>
           if beq Null 0
-          then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
+          then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term)
           else TrueTerm
       | _ => TrueTerm
       end
@@ -2463,7 +2463,7 @@ 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 (t_rewrite_stable s e); simpl in |- *;
  intros H1 H2; elim H1.
  now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
 Qed.
@@ -2585,19 +2585,19 @@ Qed.
 
 Definition move_right (s : step) (p : proposition) :=
   match p with
-  | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
-  | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term)
-  | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
-  | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term)
-  | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term)
-  | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
+  | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term)
+  | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term)
+  | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term)
+  | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term)
+  | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term)
+  | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term)
   | p => p
   end.
 
 Theorem move_right_valid : forall s : step, valid1 (move_right s).
 Proof.
  unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
- elim (rewrite_stable s e); simpl in |- *;
+ elim (t_rewrite_stable s e); simpl in |- *;
  [ symmetry  in |- *; apply egal_left; assumption
  | intro; apply le_left; assumption
  | intro; apply le_left; rewrite <- ge_le_iff; assumption
@@ -2950,14 +2950,14 @@ Qed.
 Theorem move_right_stable : forall s : step, prop_stable (move_right s).
 Proof.
  unfold move_right, prop_stable in |- *; intros s ep e p; split;
- [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *;
+ [ Simplify; simpl in |- *; elim (t_rewrite_stable s e); simpl in |- *;
     [ symmetry  in |- *; apply egal_left; assumption
     | intro; apply le_left; assumption
     | intro; apply le_left; rewrite <- ge_le_iff; assumption
     | intro; apply lt_left; rewrite <- gt_lt_iff; assumption
     | intro; apply lt_left; assumption
     | intro; apply ne_left_2; assumption ]
- | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s);
+ | case p; simpl in |- *; intros; auto; generalize H; elim (t_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;
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index f4368a1b..e810e15c 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -15,21 +15,27 @@ type result =
  | Kimp of Term.constr * Term.constr
  | Kufo;;
 
+let meaningful_submodule = [ "Z"; "N"; "Pos" ]
+
+let string_of_global r =
+  let dp = Nametab.dirpath_of_global r in
+  let prefix = match Names.repr_dirpath dp with
+    | [] -> ""
+    | m::_ ->
+      let s = Names.string_of_id m in
+      if List.mem s meaningful_submodule then s^"." else ""
+  in
+  prefix^(Names.string_of_id (Nametab.basename_of_global r))
+
 let destructurate t =
   let c, args = Term.decompose_app t in
   match Term.kind_of_term c, args with
     | Term.Const sp, args ->
-	Kapp (Names.string_of_id
-		(Nametab.basename_of_global (Libnames.ConstRef sp)),
-	      args)
+	Kapp (string_of_global (Libnames.ConstRef sp), args)
     | Term.Construct csp , args ->
-	Kapp (Names.string_of_id
-		(Nametab.basename_of_global (Libnames.ConstructRef csp)),
-	      args)
+	Kapp (string_of_global (Libnames.ConstructRef csp), args)
     | Term.Ind isp, args ->
-	Kapp (Names.string_of_id
-		(Nametab.basename_of_global (Libnames.IndRef isp)),
-	      args)
+	Kapp (string_of_global (Libnames.IndRef isp), args)
     | Term.Var id,[] -> Kvar(Names.string_of_id id)
     | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
     | Term.Prod (Names.Name _,_,_),[] ->
@@ -56,9 +62,13 @@ let coq_modules =
     @ [module_refl_path]
     @ [module_refl_path@["ZOmega"]]
 
+let bin_module = [["Coq";"Numbers";"BinNums"]]
+let z_module = [["Coq";"ZArith";"BinInt"]]
 
 let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules
 let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
+let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module
+let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module
 
 (* Logic *)
 let coq_eq = lazy(init_constant  "eq")
@@ -168,21 +178,21 @@ let coq_do_omega = lazy (constant  "do_omega")
 (* \subsection{Construction d'expressions} *)
 
 let do_left t =
-  if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
+  if Term.eq_constr 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 =
-  if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
+  if Term.eq_constr 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 =
-  if t1 = Lazy.force coq_c_nop then do_right t2
-  else if t2 = Lazy.force coq_c_nop then do_left t1
+  if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2
+  else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1
   else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |])
 
 let do_seq t1 t2 =
-  if t1 = Lazy.force coq_c_nop then t2
-  else if t2 = Lazy.force coq_c_nop then t1
+  if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2
+  else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1
   else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |])
 
 let rec do_list = function
@@ -271,18 +281,18 @@ end
 
 module Z : Int = struct
 
-let typ = lazy (constant "Z")
-let plus = lazy (constant "Zplus")
-let mult = lazy (constant  "Zmult")
-let opp = lazy (constant "Zopp")
-let minus = lazy (constant "Zminus")
+let typ = lazy (bin_constant "Z")
+let plus = lazy (z_constant "Z.add")
+let mult = lazy (z_constant  "Z.mul")
+let opp = lazy (z_constant "Z.opp")
+let minus = lazy (z_constant "Z.sub")
 
-let coq_xH = lazy (constant "xH")
-let coq_xO = lazy (constant "xO")
-let coq_xI = lazy (constant "xI")
-let coq_Z0 = lazy (constant "Z0")
-let coq_Zpos = lazy (constant "Zpos")
-let coq_Zneg = lazy (constant "Zneg")
+let coq_xH = lazy (bin_constant "xH")
+let coq_xO = lazy (bin_constant "xO")
+let coq_xI = lazy (bin_constant "xI")
+let coq_Z0 = lazy (bin_constant "Z0")
+let coq_Zpos = lazy (bin_constant "Zpos")
+let coq_Zneg = lazy (bin_constant "Zneg")
 
 let recognize t =
   let rec loop t =
@@ -318,12 +328,12 @@ let mk = mk_Z
 
 let parse_term t =
   try match destructurate t with
-    | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2)
-    | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2)
-    | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2)
-    | Kapp("Zopp",[t]) -> Topp t
-    | Kapp("Zsucc",[t]) -> Tsucc t
-    | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
+    | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2)
+    | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2)
+    | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2)
+    | Kapp("Z.opp",[t]) -> Topp t
+    | Kapp("Z.succ",[t]) -> Tsucc t
+    | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
 	(try Tnum (recognize t) with _ -> Tother)
     | _ -> Tother
@@ -334,17 +344,17 @@ let parse_rel gl t =
     | 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)
+    | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2)
+    | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2)
+    | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2)
+    | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2)
     | _ -> parse_logic_rel t
   with e when Logic.catchable_exception e -> Rother
 
 let is_scalar t =
   let rec aux t = match destructurate t with
-    | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2
-    | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t
+    | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2
+    | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
     | _ -> false in
   try aux t with _ -> false
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 570bb187..4a6d462e 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -219,7 +219,7 @@ let unintern_omega env id =
    calcul des variables utiles. *)
 
 let add_reified_atom t env =
-  try list_index0 t env.terms
+  try list_index0_f Term.eq_constr t env.terms
   with Not_found ->
     let i = List.length env.terms in
     env.terms <- env.terms @ [t]; i
@@ -230,7 +230,7 @@ let get_reified_atom env =
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
 (* ajout d'une proposition *)
 let add_prop env t =
-  try list_index0 t env.props
+  try list_index0_f Term.eq_constr t env.props
   with Not_found ->
     let i = List.length env.props in  env.props <- env.props @ [t]; i
 
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 39c29a3d..77f8f834 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -1,154 +1,32 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bintree.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export List.
 Require Export BinPos.
-
-Unset Boxed Definitions.
+Require Arith.EqNat.
 
 Open Scope positive_scope.
 
 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.
-
-Lemma Gt_Eq_Gt : forall p q cmp,
-       (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt.
-apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Lt_Gt : forall p q cmp,
-       (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt.
-apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Psucc_Eq: forall p q,
-  (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro;apply Gt_Eq_Gt;auto.
-apply Gt_Lt_Gt.
-Qed.
-
-Lemma Eq_Psucc_Gt: forall p q,
-  (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro H;elim (Pcompare_not_Eq p (Psucc q));tauto.
-intro H;apply Gt_Eq_Gt;auto.
-intro H;rewrite Pcompare_Eq_eq with p q;auto.
-generalize q;clear q IHq p H;induction q;simpl;auto.
-intro H;elim (Pcompare_not_Eq p q);tauto.
-Qed.
-
-Lemma Gt_Psucc_Gt : forall n p cmp cmp0,
- (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt.
-induction n;intros [ | p | p];simpl;try congruence.
-intros; apply IHn with cmp;trivial.
-intros; apply IHn with Gt;trivial.
-intros;apply Gt_Lt_Gt;trivial.
-intros [ | | ] _ H.
-apply Gt_Eq_Gt;trivial.
-apply Gt_Lt_Gt;trivial.
-trivial.
-Qed.
 
 Lemma Gt_Psucc: forall p q,
-       (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-apply Gt_Psucc_Eq.
-intro;apply Gt_Eq_Gt;apply IHq;auto.
-apply Gt_Eq_Gt.
-apply Gt_Lt_Gt.
+       (p ?= Psucc q) = Gt -> (p ?= q) = Gt.
+Proof.
+intros. rewrite <- Pos.compare_succ_succ.
+now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt.
 Qed.
 
 Lemma Psucc_Gt : forall p,
-       (Psucc p ?= p) Eq = Gt.
-induction p;simpl.
-apply Gt_Eq_Gt;auto.
-generalize p;clear p IHp.
-induction p;simpl;auto.
-reflexivity.
+       (Psucc p ?= p) = Gt.
+Proof.
+intros. apply Pos.lt_gt, Pos.lt_succ_diag_r.
 Qed.
 
-Fixpoint pos_eq (m n:positive) {struct m} :bool :=
-match m, n with
-  xI mm, xI nn => pos_eq mm nn
-| xO mm, xO nn => pos_eq mm nn
-| xH, xH => true
-| _, _ => false
-end.
-
-Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
-induction m;simpl;intro n;destruct n;congruence ||
-(intro e;apply f_equal with positive;auto).
-Defined.
-
-Theorem refl_pos_eq : forall m, pos_eq m m = true.
-induction m;simpl;auto.
-Qed.
-
-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).
-intro ne;right;congruence.
-case (pos_eq_dec mm nn).
-intro e;left;apply (f_equal xO e).
-intro ne;right;congruence.
-left;reflexivity.
-Defined.
-
-Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m).
-fix 1;intros [mm|mm|].
-simpl; rewrite  pos_eq_dec_refl; reflexivity.
-simpl; rewrite  pos_eq_dec_refl; reflexivity.
-reflexivity.
-Qed.
-
-Theorem pos_eq_dec_ex : forall m n,
- pos_eq m n =true -> exists h:m=n,
- pos_eq_dec m n = left _ h.
-fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
-simpl;intro e.
-elim (pos_eq_dec_ex _ _ e).
-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.
-exists (f_equal xO x).
-reflexivity.
-simpl.
-exists (refl_equal xH).
-reflexivity.
-Qed.
-
-Fixpoint nat_eq (m n:nat) {struct m}: bool:=
-match m, n with
-O,O => true
-| S mm,S nn => nat_eq mm nn
-| _,_ => false
-end.
-
-Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n.
-induction m;simpl;intro n;destruct n;congruence ||
-(intro e;apply f_equal with nat;auto).
-Defined.
-
-Theorem refl_nat_eq : forall n, nat_eq n n = true.
-induction n;simpl;trivial.
-Defined.
-
 Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A :=
 match l with nil => None
 | x::q =>
@@ -156,21 +34,21 @@ match n with O => Some x
 | S m => Lget A m q
 end end .
 
-Implicit Arguments Lget [A].
+Arguments Lget [A] n l.
 
 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.
 simpl.
-intro m ; apply f_equal with (list B);apply IHl.
+intro m ; apply f_equal;apply IHl.
 Qed.
 
 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.
+simpl; apply f_equal;apply IHl.
 Qed.
 
 Lemma Lget_map : forall (A B:Set) (f:A -> B) i l,
@@ -182,7 +60,8 @@ simpl;auto.
 Qed.
 
 Lemma Lget_app : forall (A:Set) (a:A) l i,
-Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l.
+Lget i (l ++ a :: nil) = if Arith.EqNat.beq_nat i (length l) then Some a else Lget i l.
+Proof.
 induction l;simpl Lget;simpl length.
 intros [ | i];simpl;reflexivity.
 intros [ | i];simpl.
@@ -278,17 +157,20 @@ Qed.
 
 Theorem Tget_Tadd: forall i j a T,
        Tget i (Tadd j a T) =
-       match (i ?= j) Eq with
+       match (i ?= j) with
          Eq => PSome a
        | Lt => Tget i T
        | Gt => Tget i T
        end.
+Proof.
 intros i j.
-caseq ((i ?= j) Eq).
-intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
+case_eq (i ?= j).
+intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H.
 induction j;destruct T;simpl;try (apply IHj);congruence.
+unfold Pos.compare.
 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.
+unfold Pos.compare.
 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.
@@ -312,7 +194,8 @@ Inductive Full : Store -> Type:=
   | F_push : forall a S, Full S -> Full (push a S).
 
 Theorem get_Full_Gt : forall S, Full S ->
-       forall i, (i ?= index S) Eq = Gt -> get i S = PNone.
+       forall i, (i ?= index S) = Gt -> get i S = PNone.
+Proof.
 intros S W;induction W.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
 unfold index,get,push;simpl contents.
@@ -339,16 +222,17 @@ Qed.
 Theorem get_push_Full :
   forall i a S, Full S ->
   get i (push a S) =
-  match (i ?= index S) Eq with
+  match (i ?= index S) with
     Eq => PSome a
   | Lt => get i S
   | Gt => PNone
 end.
+Proof.
 intros i a S F.
-caseq ((i ?= index S) Eq).
-intro e;rewrite (Pcompare_Eq_eq _ _ e).
+case_eq (i ?= index S).
+intro e;rewrite (Pos.compare_eq _ _ e).
 destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
-rewrite Pcompare_refl;reflexivity.
+rewrite Pos.compare_refl;reflexivity.
 intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
 simpl index in H;rewrite H;reflexivity.
 intro H;generalize H;clear H.
@@ -361,8 +245,9 @@ Qed.
 Lemma Full_push_compat : forall i a S, Full S ->
 forall x, get i S = PSome x ->
  get i (push a S) = PSome x.
+Proof.
 intros i a S F x H.
-caseq ((i ?= index S) Eq);intro test.
+case_eq (i ?= index S);intro test.
 rewrite (Pcompare_Eq_eq _ _ test) in H.
 rewrite (get_Full_Eq _ F) in H;congruence.
 rewrite <- H.
@@ -395,7 +280,7 @@ get i S = PSome x -> In x S F.
 induction F.
 intro i;rewrite get_empty; congruence.
 intro i;rewrite get_push_Full;trivial.
-caseq ((i ?= index S) Eq);simpl.
+case_eq (i ?= index S);simpl.
 left;congruence.
 right;eauto.
 congruence.
@@ -403,34 +288,34 @@ Qed.
 
 End Store.
 
-Implicit Arguments PNone [A].
-Implicit Arguments PSome [A].
+Arguments PNone [A].
+Arguments PSome [A] _.
 
-Implicit Arguments Tempty [A].
-Implicit Arguments Branch0 [A].
-Implicit Arguments Branch1 [A].
+Arguments Tempty [A].
+Arguments Branch0 [A] _ _.
+Arguments Branch1 [A] _ _ _.
 
-Implicit Arguments Tget [A].
-Implicit Arguments Tadd [A].
+Arguments Tget [A] p T.
+Arguments Tadd [A] p a T.
 
-Implicit Arguments Tget_Tempty [A].
-Implicit Arguments Tget_Tadd [A].
+Arguments Tget_Tempty [A] p.
+Arguments Tget_Tadd [A] i j a T.
 
-Implicit Arguments mkStore [A].
-Implicit Arguments index [A].
-Implicit Arguments contents [A].
+Arguments mkStore [A] index contents.
+Arguments index [A] s.
+Arguments contents [A] s.
 
-Implicit Arguments empty [A].
-Implicit Arguments get [A].
-Implicit Arguments push [A].
+Arguments empty [A].
+Arguments get [A] i S.
+Arguments push [A] a S.
 
-Implicit Arguments get_empty [A].
-Implicit Arguments get_push_Full [A].
+Arguments get_empty [A] i.
+Arguments get_push_Full [A] i a S _.
 
-Implicit Arguments Full [A].
-Implicit Arguments F_empty [A].
-Implicit Arguments F_push [A].
-Implicit Arguments In [A].
+Arguments Full [A] _.
+Arguments F_empty [A].
+Arguments F_push [A] a S _.
+Arguments In [A] x S F.
 
 Section Map.
 
@@ -482,8 +367,8 @@ Defined.
 
 End Map.
 
-Implicit Arguments Tmap [A B].
-Implicit Arguments map [A B].
-Implicit Arguments Full_map [A B f].
+Arguments Tmap [A B] f T.
+Arguments map [A B] f S.
+Arguments Full_map [A B f] S _.
 
 Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index 3817f98c..9cae7a44 100644
--- a/plugins/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Rtauto.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 
 Require Export List.
 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).
 
 Inductive form:Set:=
@@ -43,7 +39,7 @@ end.
 
 Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
 induction m;simpl;destruct n;congruence ||
-(intro e;apply f_equal with positive;auto).
+(intro e;apply f_equal;auto).
 Qed.
 
 Fixpoint form_eq (p q:form) {struct p} :bool :=
@@ -69,15 +65,15 @@ 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.
+case_eq (form_eq p1 q1);clean.
 intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
-caseq (form_eq p1 q1);clean.
+case_eq (form_eq p1 q1);clean.
 intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
-caseq (form_eq p1 q1);clean.
+case_eq (form_eq p1 q1);clean.
 intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
 Qed.
 
-Implicit Arguments form_eq_refl [p q].
+Arguments form_eq_refl [p q] _.
 
 Section with_env.
 
@@ -165,7 +161,7 @@ intros hyps F p g e; apply project_In.
 apply get_In with p;assumption.
 Qed.
 
-Implicit Arguments project [hyps p g].
+Arguments project [hyps] F [p g] _.
 
 Inductive proof:Set :=
   Ax : positive -> proof
@@ -263,7 +259,7 @@ induction p;intros hyps F gl.
 
 (* cas Axiom *)
 Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
 intros f nth_f e;rewrite <- (form_eq_refl e).
 apply project with p;trivial.
 
@@ -276,10 +272,10 @@ apply IHp;try constructor;trivial.
 
 (* Cas Arrow_Elim *)
 Focus 1.
-simpl check_proof;caseq (get p hyps);clean.
-intros f ef;caseq (get p0 hyps);clean.
+simpl check_proof;case_eq (get p hyps);clean.
+intros f ef;case_eq (get p0 hyps);clean.
 intros f0 ef0;destruct f0;clean.
-caseq (form_eq f f0_1);clean.
+case_eq (form_eq f f0_1);clean.
 simpl;intros e check_p1.
 generalize  (project  F ef) (project  F ef0)
 (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
@@ -291,10 +287,10 @@ auto.
 
 (* cas Arrow_Destruct *)
 Focus 1.
-simpl;caseq (get p1 hyps);clean.
+simpl;case_eq (get p1 hyps);clean.
 intros f ef;destruct f;clean.
 destruct f1;clean.
-caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
+case_eq (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)
@@ -305,7 +301,7 @@ simpl;apply compose3;auto.
 
 (* Cas False_Elim *)
 Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
 intros f ef;destruct f;clean.
 intros _; generalize (project F ef).
 apply compose1;apply False_ind.
@@ -313,13 +309,13 @@ apply compose1;apply False_ind.
 (* Cas And_Intro *)
 Focus 1.
 simpl;destruct gl;clean.
-caseq (check_proof hyps gl1 p1);clean.
+case_eq (check_proof hyps gl1 p1);clean.
 intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
 apply compose2 ;simpl;auto.
 
 (* cas And_Elim *)
 Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
 intros f ef;destruct f;clean.
 intro check_p;generalize  (project F ef)
 (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
@@ -327,7 +323,7 @@ simpl;apply compose2;intros [h1 h2];auto.
 
 (* cas And_Destruct *)
 Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
 intros f ef;destruct f;clean.
 destruct f1;clean.
 intro H;generalize  (project F ef)
@@ -349,9 +345,9 @@ apply compose1;simpl;auto.
 
 (* cas Or_elim *)
 Focus 1.
-simpl;caseq (get p1 hyps);clean.
+simpl;case_eq (get p1 hyps);clean.
 intros f ef;destruct f;clean.
-caseq (check_proof (hyps \ f1) gl p2);clean.
+case_eq (check_proof (hyps \ f1) gl p2);clean.
 intros check_p1 check_p2;generalize (project F ef)
 (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
 (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
@@ -359,7 +355,7 @@ simpl;apply compose3;simpl;intro h;destruct h;auto.
 
 (* cas Or_Destruct *)
 Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
 intros f ef;destruct f;clean.
 destruct f1;clean.
 intro check_p0;generalize (project F ef)
@@ -370,7 +366,7 @@ apply compose2;auto.
 
 (* cas Cut *)
 Focus 1.
-simpl;caseq (check_proof hyps f p1);clean.
+simpl;case_eq (check_proof hyps f p1);clean.
 intros check_p1 check_p2;
 generalize (IHp1 hyps F f check_p1)
 (IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
@@ -378,7 +374,7 @@ simpl; apply compose2;auto.
 Qed.
 
 Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
-intros gl prf;caseq (check_proof empty gl prf);intro check_prf.
+intros gl prf;case_eq (check_proof empty gl prf);intro check_prf.
 change (interp_ctx empty F_empty [[gl]]) ;
 apply interp_proof with prf;assumption.
 trivial.
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index 552f23f6..8d103d1b 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_rtauto.ml4 14641 2011-11-06 11:59:10Z herbelin $*)
-
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
 TACTIC EXTEND rtauto
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 500138cf..d773b153 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_search.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Util
 open Goptions
@@ -49,6 +47,7 @@ let pruning = ref true
 
 let opt_pruning=
   {optsync=true;
+   optdepr=false;
    optname="Rtauto Pruning";
    optkey=["Rtauto";"Pruning"];
    optread=(fun () -> !pruning);
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index 4d77a057..b236aa72 100644
--- a/plugins/rtauto/proof_search.mli
+++ b/plugins/rtauto/proof_search.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_search.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 type form=
     Atom of int
   | Arrow of form * form
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 20b4c8f6..4a9a0e47 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -1,18 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refl_tauto.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 module Search = Explore.Make(Proof_search)
 
 open Util
 open Term
-open Termops
 open Names
 open Evd
 open Tacmach
@@ -39,7 +36,7 @@ let l_true_equals_true =
         [|data_constant "bool";data_constant "true"|]))
 
 let pos_constant =
-  Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"]
+  Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"]
 
 let l_xI = lazy (pos_constant "xI")
 let l_xO = lazy (pos_constant "xO")
@@ -104,7 +101,7 @@ let rec make_form atom_env gls term =
   let cciterm=special_whd gls term  in
     match kind_of_term cciterm with
 	Prod(_,a,b) ->
-	  if not (dependent (mkRel 1) b) &&
+	  if not (Termops.dependent (mkRel 1) b) &&
 	    Retyping.get_sort_family_of
 	    (pf_env gls) (Tacmach.project gls) a = InProp
 	  then
@@ -144,7 +141,7 @@ let rec make_hyps atom_env gls lenv = function
   | (id,None,typ)::rest ->
       let hrec=
 	make_hyps atom_env gls (typ::lenv) rest in
-	if List.exists (dependent (mkVar id)) lenv ||
+	if List.exists (Termops.dependent (mkVar id)) lenv ||
 	  (Retyping.get_sort_family_of
 	     (pf_env gls) (Tacmach.project gls) typ <> InProp)
 	then
@@ -244,6 +241,7 @@ let verbose = ref false
 
 let opt_verbose=
   {optsync=true;
+   optdepr=false;
    optname="Rtauto Verbose";
    optkey=["Rtauto";"Verbose"];
    optread=(fun () -> !verbose);
@@ -255,6 +253,7 @@ let check = ref false
 
 let opt_check=
   {optsync=true;
+   optdepr=false;
    optname="Rtauto Check";
    optkey=["Rtauto";"Check"];
    optread=(fun () -> !check);
@@ -267,14 +266,13 @@ open Pp
 let rtauto_tac gls=
   Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"];
   let gamma={next=1;env=[]} in
-  let gl=gls.it.evar_concl in
+  let gl=pf_concl gls in
   let _=
     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]
-      (Environ.named_context_of_val gls.it.evar_hyps) in
+  let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in
   let formula=
     List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
   let search_fun =
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index 085a45a5..643433b0 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: refl_tauto.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* raises Not_found if no proof is found *)
 
 type atom_env=
diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v
new file mode 100644
index 00000000..e896554e
--- /dev/null
+++ b/plugins/setoid_ring/Algebra_syntax.v
@@ -0,0 +1,25 @@
+
+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 "_+_" := addition.
+Notation "x + y" := (addition x y).
+Class Multiplication {A B : Type} := multiplication : A -> B -> B.
+Notation "_*_" := multiplication.
+Notation "x * y" := (multiplication x y).
+Class Subtraction (A : Type) := subtraction : A -> A -> A.
+Notation "_-_" := subtraction.
+Notation "x - y" := (subtraction x y).
+Class Opposite (A : Type) := opposite : A -> A.
+Notation "-_" := opposite.
+Notation "- x" := (opposite(x)).
+Class Equality {A : Type}:= equality : A -> A -> Prop.
+Notation "_==_" := equality.
+Notation "x == y" := (equality x y) (at level 70, no associativity).
+Class Bracket (A B: Type):= bracket : A -> B.
+Notation "[ x ]" := (bracket(x)).
+Class Power {A B: Type} := power : A -> B -> A.
+Notation "x ^ y" := (power x y).
+
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 6998b656..06822ae1 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -21,12 +21,12 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq 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.
+          0%N 1%N N.add N.mul N.eqb nat_of_N.
 Proof.
   constructor;trivial.
   exact nat_of_Nplus.
   exact nat_of_Nmult.
-  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+  intros x y H. apply N.eqb_eq in H. now subst.
 Qed.
 
 Ltac natcst t :=
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 905625cc..7128280a 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
new file mode 100644
index 00000000..3d6e53fc
--- /dev/null
+++ b/plugins/setoid_ring/Cring.v
@@ -0,0 +1,272 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Export Morphisms Setoid Bool.
+Require Import ZArith_base.
+Require Export Algebra_syntax.
+Require Export Ncring.
+Require Export Ncring_initial.
+Require Export Ncring_tac.
+
+Class Cring {R:Type}`{Rr:Ring R} := 
+ cring_mul_comm: forall x y:R, x * y == y * x.
+
+Ltac reify_goal lvar lexpr lterm:=
+  (*idtac lvar; idtac lexpr; idtac lterm;*)
+  match lexpr with
+     nil => idtac
+   | ?e1::?e2::_ =>  
+        match goal with
+          |- (?op ?u1 ?u2) =>
+           change (op 
+             (@Ring_polynom.PEeval
+               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               (@Ring_theory.pow_N _ 1 multiplication) lvar e1)
+             (@Ring_polynom.PEeval
+               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               (@Ring_theory.pow_N _ 1 multiplication) lvar e2))
+        end
+  end.
+
+Section cring.
+Context {R:Type}`{Rr:Cring R}.
+
+Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_.
+intros. apply mk_reqe;intros. 
+rewrite H. rewrite H0. reflexivity.
+rewrite H. rewrite H0. reflexivity.
+ rewrite H. reflexivity. Defined.
+
+Lemma cring_almost_ring_theory:
+   almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_.
+intros. apply mk_art ;intros. 
+rewrite ring_add_0_l; reflexivity. 
+rewrite ring_add_comm; reflexivity. 
+rewrite ring_add_assoc; reflexivity. 
+rewrite ring_mul_1_l; reflexivity. 
+apply ring_mul_0_l.
+rewrite cring_mul_comm; reflexivity. 
+rewrite ring_mul_assoc; reflexivity. 
+rewrite ring_distr_l; reflexivity. 
+rewrite ring_opp_mul_l; reflexivity. 
+apply ring_opp_add.
+rewrite ring_sub_def ; reflexivity. Defined.
+
+Lemma cring_morph:
+  ring_morph  zero one _+_ _*_ _-_ -_ _==_
+             0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
+             Ncring_initial.gen_phiZ.
+intros. apply mkmorph ; intros; simpl; try reflexivity.
+rewrite Ncring_initial.gen_phiZ_add; reflexivity.
+rewrite ring_sub_def. unfold Zminus. rewrite Ncring_initial.gen_phiZ_add.
+rewrite Ncring_initial.gen_phiZ_opp; reflexivity.
+rewrite Ncring_initial.gen_phiZ_mul; reflexivity.
+rewrite Ncring_initial.gen_phiZ_opp; reflexivity.
+rewrite (Zeqb_ok x y H). reflexivity. Defined.
+
+Lemma cring_power_theory : 
+  @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n)
+  (@Ring_theory.pow_N _  1 multiplication).
+intros; apply Ring_theory.mkpow_th. reflexivity. Defined.
+
+Lemma cring_div_theory: 
+  div_theory _==_ Zplus Zmult Ncring_initial.gen_phiZ Z.quotrem.
+intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory.
+simpl.   apply ring_setoid. Defined.
+
+End cring.
+
+Ltac cring_gen :=
+  match goal with
+    |- ?g => let lterm := lterm_goal g in
+        match eval red in (list_reifyl (lterm:=lterm)) with
+          | (?fv, ?lexpr) => 
+           (*idtac "variables:";idtac fv;
+           idtac "terms:"; idtac lterm;
+           idtac "reifications:"; idtac lexpr; *)
+           reify_goal fv lexpr lterm;
+           match goal with 
+             |- ?g => 
+               generalize
+                 (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_
+                        ring_setoid
+                        cring_eq_ext
+                        cring_almost_ring_theory
+                        Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
+                        Ncring_initial.gen_phiZ
+                        cring_morph
+                        N
+                        (fun n:N => n)
+                        (@Ring_theory.pow_N _  1 multiplication)
+                        cring_power_theory
+                        Z.quotrem
+                        cring_div_theory
+                        O fv nil);
+                 let rc := fresh "rc"in
+                   intro rc; apply rc
+           end
+        end
+  end.
+
+Ltac cring_compute:= vm_compute; reflexivity.
+
+Ltac cring:= 
+  intros;
+  cring_gen;
+  cring_compute.
+
+Instance Zcri: (Cring (Rr:=Zr)).
+red. exact Zmult_comm. Defined.
+
+(* Cring_simplify *)
+
+Ltac cring_simplify_aux lterm fv lexpr hyp :=
+    match lterm with
+      | ?t0::?lterm =>
+    match lexpr with
+      | ?e::?le =>
+        let t := constr:(@Ring_polynom.norm_subst
+          Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Z.quotrem O nil e) in
+        let te := 
+          constr:(@Ring_polynom.Pphi_dev
+            _ 0 1 _+_ _*_ _-_ -_ 
+            
+            Z 0%Z 1%Z Zeq_bool
+            Ncring_initial.gen_phiZ
+            get_signZ fv t) in
+        let eq1 := fresh "ring" in
+        let nft := eval vm_compute in t in
+        let t':= fresh "t" in
+        pose (t' := nft);
+        assert (eq1 : t = t');
+        [vm_cast_no_check (refl_equal t')|
+        let eq2 := fresh "ring" in
+        assert (eq2:(@Ring_polynom.PEeval
+          _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+          (@Ring_theory.pow_N _ 1 multiplication) fv e) == te);
+        [let eq3 := fresh "ring" in
+          generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_
+            ring_setoid
+            cring_eq_ext
+            cring_almost_ring_theory
+            Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
+            Ncring_initial.gen_phiZ
+            cring_morph
+            N
+            (fun n:N => n)
+            (@Ring_theory.pow_N _ 1 multiplication)
+            cring_power_theory
+            Z.quotrem
+            cring_div_theory
+            get_signZ get_signZ_th
+            O nil fv I nil (refl_equal nil) );
+          intro eq3; apply eq3; reflexivity|
+              match hyp with
+                | 1%nat => rewrite eq2
+                | ?H => try rewrite eq2 in H
+              end];
+        let P:= fresh "P" in
+        match hyp with
+          | 1%nat => 
+            rewrite eq1;
+            pattern (@Ring_polynom.Pphi_dev
+            _ 0 1 _+_ _*_ _-_ -_ 
+            
+            Z 0%Z 1%Z Zeq_bool
+            Ncring_initial.gen_phiZ
+            get_signZ fv t');
+            match goal with
+              |- (?p ?t) => set (P:=p)
+            end;
+              unfold t' in *; clear t' eq1 eq2;
+              unfold Pphi_dev, Pphi_avoid; simpl;
+                repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c,
+                  mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult,
+                  mkpow;simpl)
+          | ?H =>
+               rewrite eq1 in H;
+               pattern (@Ring_polynom.Pphi_dev
+            _ 0 1 _+_ _*_ _-_ -_ 
+            
+            Z 0%Z 1%Z Zeq_bool
+            Ncring_initial.gen_phiZ
+            get_signZ fv t') in H; 
+               match type of H with
+                  | (?p ?t)  => set (P:=p) in H
+               end;
+               unfold t' in *; clear t' eq1 eq2;
+               unfold Pphi_dev, Pphi_avoid in H; simpl in H;
+                repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c,
+                  mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult,
+                  mkpow in H;simpl in H)
+        end; unfold P in *; clear P
+        ]; cring_simplify_aux lterm fv le hyp
+      | nil => idtac
+    end
+    | nil => idtac
+    end.
+
+Ltac set_variables fv :=
+  match fv with
+    | nil => idtac
+    | ?t::?fv =>
+        let v := fresh "X" in
+        set (v:=t) in *; set_variables fv
+  end.
+
+Ltac deset n:=
+   match n with
+    | 0%nat => idtac
+    | S ?n1 =>
+      match goal with
+        | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1
+      end
+   end.
+
+(* a est soit un terme de l'anneau, soit une liste de termes.
+J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list
+ dans Tactic Notation *)
+
+Ltac cring_simplify_gen a hyp :=
+  let lterm :=
+    match a with
+      | _::_ => a
+      | _ => constr:(a::nil)
+    end in
+    match eval red in (list_reifyl (lterm:=lterm)) with
+      | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr;
+      let n := eval compute in (length fv) in
+      idtac n;
+      let lt:=fresh "lt" in
+      set (lt:= lterm);
+      let lv:=fresh "fv" in
+      set (lv:= fv);
+      (* les termes de fv sont remplacés par des variables 
+         pour pouvoir utiliser simpl ensuite sans risquer
+         des simplifications indésirables *)
+      set_variables fv;
+      let lterm1 := eval unfold lt in lt in
+      let lv1 := eval unfold lv in lv in
+        idtac lterm1; idtac lv1;
+      cring_simplify_aux lterm1 lv1 lexpr hyp;
+      clear lt lv;
+      (* on remet les termes de fv *)
+      deset n
+    end.
+
+Tactic Notation "cring_simplify" constr(lterm):=
+ cring_simplify_gen lterm 1%nat.
+
+Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):=
+ cring_simplify_gen lterm H.
+
diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
index 6a755af2..90f2f497 100644
--- a/plugins/setoid_ring/Field.v
+++ b/plugins/setoid_ring/Field.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
index eee89e61..da42bbd9 100644
--- a/plugins/setoid_ring/Field_tac.v
+++ b/plugins/setoid_ring/Field_tac.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index ccdec656..40138526 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -96,7 +96,7 @@ Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
              (ARsub_def  ARth) .
 
  (* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -390,52 +390,16 @@ Qed.
 
   ***************************************************************************)
 
-Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
- match p1, p2 with
-   xH, xH => true
-  | xO p3, xO p4 => positive_eq p3 p4
-  | 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;
- (try (intros p2; case p2; simpl; auto; intros; discriminate)).
-intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
-generalize (rec p4); case (positive_eq p3 p4); auto.
-intros H1; apply f_equal with ( f := xI ); auto.
-intros H1 H2; case H1; injection H2; auto.
-intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
-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 :=
-  match n1, n2 with
-  | N0, N0 => true
-  | Npos p1, Npos p2 => positive_eq p1 p2
-  | _, _ => false
-  end.
-
-Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2.
-Proof.
-  intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail).
-  assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2);
-     [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial].
-Qed.
-
 (* equality test *)
 Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
  match e1, e2 with
    PEc c1, PEc c2 => ceqb c1 c2
-  | PEX p1, PEX p2 => positive_eq p1 p2
+  | PEX p1, PEX p2 => Pos.eqb p1 p2
   | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
   | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
   | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
   | PEopp e3, PEopp e4 => PExpr_eq e3 e4
-  | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false
+  | PEpow e3 n3, PEpow e4 n4 => if N.eqb n3 n4 then PExpr_eq e3 e4 else false
   | _, _ => false
  end.
 
@@ -460,8 +424,7 @@ intros l e1; elim e1.
 intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
 intros c2; apply (morph_eq CRmorph).
 intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2);
- (try (intros; discriminate)); intros H; rewrite H; auto.
+intros p2; case Pos.eqb_spec; intros; now subst.
 intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
 intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
  (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
@@ -478,9 +441,8 @@ intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
 intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
  (try (intros; discriminate)); auto.
 intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
-intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4);
-intros;try discriminate.
-repeat rewrite  pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto.
+intros e4 n4; case N.eqb_spec; try discriminate; intros EQ H; subst.
+repeat rewrite  pow_th.(rpow_pow_N). rewrite (rec _ H);auto.
 Qed.
 
 (* add *)
@@ -507,7 +469,7 @@ Definition NPEpow x n :=
   match n with
   | N0 => PEc cI
   | Npos p =>
-    if positive_eq p xH then x else
+    if Pos.eqb p xH then x else
     match x with
     | PEc c =>
       if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)
@@ -520,10 +482,10 @@ Theorem NPEpow_correct : forall l e n,
 Proof.
  destruct n;simpl.
  rewrite pow_th.(rpow_pow_N);simpl;auto.
- generalize (positive_eq_correct p xH).
- destruct (positive_eq p 1);intros.
- rewrite H;rewrite  pow_th.(rpow_pow_N). trivial.
- clear H;destruct e;simpl;auto.
+ fold (p =? 1)%positive.
+ case Pos.eqb_spec; intros H; (rewrite H || clear H).
+ now rewrite  pow_th.(rpow_pow_N).
+ destruct e;simpl;auto.
  repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
  symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
  symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
@@ -539,7 +501,7 @@ Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
   |  _, PEc c =>
       if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
   | PEpow e1 n1, PEpow e2 n2 =>
-      if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
+      if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
   | _, _ => PEmul x y
   end.
 
@@ -554,10 +516,10 @@ induction e1;destruct e2; simpl in |- *;try reflexivity;
  try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity;
  try ring [(morph0 CRmorph) (morph1 CRmorph)].
  apply (morph_mul CRmorph).
-assert (H:=N_eq_correct n n0);destruct (N_eq n n0).
+case N.eqb_spec; intros H; try rewrite <- H; clear H.
 rewrite NPEpow_correct. simpl.
 repeat rewrite pow_th.(rpow_pow_N).
-rewrite IHe1;rewrite <- H;destruct n;simpl;try ring.
+rewrite IHe1; destruct n;simpl;try ring.
 apply pow_pos_mul.
 simpl;auto.
 Qed.
@@ -760,6 +722,14 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
  Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext)
                         ARth.(ARmul_comm) ARth.(ARmul_assoc)).
 
+ Lemma Z_pos_sub_gt : forall p q, (p > q)%positive ->
+  Z.pos_sub p q = Zpos (p - q).
+ Proof.
+  intros. apply Z.pos_sub_gt. now apply Pos.gt_lt.
+ Qed.
+
+ Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption.
+
  Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
   match
       (if  PExpr_eq e1 e2 then
@@ -779,10 +749,12 @@ 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.
+  rewrite Z.pos_sub_spec.
+  case_eq ((p1 ?= p2)%positive);intros;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
   rewrite (Pcompare_Eq_eq _ _ H0).
   rewrite H by trivial. ring [ (morph1 CRmorph)].
+  fold (p2 - p1 =? 1)%positive.
   fold (NPEpow e2 (Npos (p2 - p1))).
   rewrite NPEpow_correct;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
@@ -790,22 +762,17 @@ Proof.
   rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
   rewrite H;trivial.
-   change (ZtoN
-     match (p1 ?= p1 - p2)%positive Eq with
-     | Eq => 0
-     | Lt => Zneg (p1 - p2 - p1)
-     | Gt => Zpos (p1 - (p1 - p2))
-     end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))).
+   change (Z.pos_sub p1 (p1-p2)) with (Zpos p1 - Zpos (p1 -p2))%Z.
   replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z.
   split.
   repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
-  rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
+  rewrite Zplus_assoc, Z.add_opp_diag_r. simpl.
   ring [ (morph1 CRmorph)].
  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 _).
- simpl;rewrite H0;trivial.
+ simpl. now simpl_pos_sub.
 Qed.
 
 Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
@@ -835,7 +802,7 @@ destruct n.
   destruct n;simpl.
     rewrite NPEmul_correct;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.
+    simpl_pos_sub. simpl in H3.
     rewrite pow_pos_mul. rewrite H1;rewrite H3.
     assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
         (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) ==
@@ -845,11 +812,10 @@ destruct n.
    split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
    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.
+   simpl_pos_sub. simpl in H1, H3.
    assert (Zpos p1 > Zpos p6)%Z.
      apply Zgt_trans with (Zpos p4). exact H4. exact H2.
-  unfold Zgt in H;simpl in H;rewrite H.
+  simpl_pos_sub.
   split. 2:exact H.
   rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
   assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
@@ -863,11 +829,11 @@ destruct n.
      (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.
+ simpl. rewrite Z.pos_sub_diag. 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_pos_sub. inversion H0; trivial.
  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.
+ intros H1 (H2,H3). simpl_pos_sub.
  rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
  simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
  rewrite pow_pos_mul. split. ring [H2]. exact H3.
@@ -878,8 +844,7 @@ destruct n.
  rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
  repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
  intros (H1, H2);rewrite H1;split.
-   unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1.
-   simpl in H1;ring [H1]. trivial.
+   simpl_pos_sub. simpl in H1;ring [H1]. trivial.
  trivial.
  destruct n. trivial.
  generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
@@ -937,8 +902,7 @@ Proof.
      repeat rewrite NPEpow_correct;simpl;
      repeat rewrite pow_th.(rpow_pow_N);simpl).
   intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
-  intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H.
-  simpl in H;split;try ring [H].
+  intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H].
   rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
   simpl;intros. repeat rewrite NPEmul_correct;simpl.
   rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
@@ -1805,25 +1769,24 @@ Lemma gen_phiPOS_inj : forall x y,
   x = y.
 intros x y.
 repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
-ElimPcompare x y; intro.
+case (Pos.compare_spec x y).
+ intros.
+   trivial.
  intros.
-   apply Pcompare_Eq_eq; trivial.
- intro.
    elim gen_phiPOS_not_0 with (y - x)%positive.
    apply add_inj_r with x.
    symmetry  in |- *.
    rewrite (ARadd_0_r Rsth ARth) in |- *.
    rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
    rewrite Pplus_minus in |- *; trivial.
-   change Eq with (CompOpp Eq) in |- *.
-   rewrite <- Pcompare_antisym in |- *; trivial.
-   rewrite H in |- *; trivial.
- intro.
+   now apply Pos.lt_gt.
+ intros.
    elim gen_phiPOS_not_0 with (x - y)%positive.
    apply add_inj_r with y.
    rewrite (ARadd_0_r Rsth ARth) in |- *.
    rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
    rewrite Pplus_minus in |- *; trivial.
+   now apply Pos.lt_gt.
 Qed.
 
 
@@ -1841,12 +1804,9 @@ Qed.
 
 Lemma gen_phiN_complete : forall x y,
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
-  Neq_bool x y = true.
-intros.
- replace y with x.
- unfold Neq_bool in |- *.
-   rewrite Ncompare_refl in |- *; trivial.
- apply gen_phiN_inj; trivial.
+  N.eqb x y = true.
+Proof.
+intros. now apply N.eqb_eq, gen_phiN_inj.
 Qed.
 
 End AlmostField.
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index 026e70c8..763dbe7b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,7 +13,6 @@ Require Import BinNat.
 Require Import Setoid.
 Require Import Ring_theory.
 Require Import Ring_polynom.
-Require Import ZOdiv_def.
 Import List.
 
 Set Implicit Arguments.
@@ -170,48 +169,28 @@ Section ZMORPHISM.
   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
- == gen_phiPOS1 x + -gen_phiPOS1 y.
+ Lemma gen_phiZ1_pos_sub : forall x y,
+ gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y.
  Proof.
   intros x y.
-  assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y).
-  generalize (Pminus_mask_Gt y x).
-  replace Eq with (CompOpp Eq);[intro H1;simpl|trivial].
-  rewrite <- Pcompare_antisym in H1.
-  destruct ((x ?= y)%positive Eq).
-  rewrite H;trivial. rewrite (Ropp_def Rth);rrefl.
-  destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial.
-  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+  rewrite Z.pos_sub_spec.
+  case Pos.compare_spec; intros H; simpl.
+  rewrite H. rewrite (Ropp_def Rth);rrefl.
+  rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm.
   rewrite (ARgen_phiPOS_add ARth);simpl;norm.
   rewrite (Ropp_def Rth);norm.
-  destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial.
-  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+  rewrite <- (Pos.sub_add x y H) at 2.
   rewrite (ARgen_phiPOS_add ARth);simpl;norm.
-  add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm.
+  add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm.
  Qed.
 
- Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
-  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.
-
  Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
  Proof.
   intros x y; repeat rewrite same_genZ; generalize x y;clear x y.
-  induction x;destruct y;simpl;norm.
+  destruct x, y; simpl; norm.
   apply (ARgen_phiPOS_add ARth).
-  apply gen_phiZ1_add_pos_neg.
-  replace Eq with (CompOpp Eq);trivial.
-  rewrite <- Pcompare_antisym;simpl.
-  rewrite match_compOpp.
-  rewrite (Radd_comm Rth).
-  apply gen_phiZ1_add_pos_neg.
+  apply gen_phiZ1_pos_sub.
+  rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth).
   rewrite (ARgen_phiPOS_add ARth); norm.
  Qed.
 
@@ -244,47 +223,28 @@ End ZMORPHISM.
 Lemma Nsth : Setoid_Theory N (@eq N).
 Proof (Eqsth N).
 
-Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N).
-Proof (Eq_s_ext Nplus Nmult).
+Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N).
+Proof (Eq_s_ext N.add N.mul).
 
-Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N).
+Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@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.
+ constructor. exact N.add_0_l. exact N.add_comm. exact N.add_assoc.
+ exact N.mul_1_l. exact N.mul_0_l. exact N.mul_comm. exact N.mul_assoc.
+ exact N.mul_add_distr_r.
 Qed.
 
-Definition Nsub := SRsub Nplus.
+Definition Nsub := SRsub N.add.
 Definition Nopp := (@SRopp N).
 
-Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N).
+Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N).
 Proof (SReqe_Reqe Nseqe).
 
 Lemma Nath :
- almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N).
+ almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N).
 Proof (SRth_ARth Nsth Nth).
 
-Definition Neq_bool (x y:N) :=
-  match Ncompare x y with
-  | Eq => true
-  | _ => false
-  end.
-
-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);
-   destruct (Ncompare x y);intros;try discriminate.
-  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);
-   destruct (Ncompare x y);intros;try discriminate.
-  rewrite H;trivial.
- Qed.
+Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y.
+Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed.
 
 (**Same as above : definition of two,extensionaly equal, generic morphisms *)
 (**from N to any semi-ring*)
@@ -307,9 +267,7 @@ Section NMORPHISM.
   Notation "x == y" := (req x y).
    Add Morphism radd : radd_ext4.  exact (Radd_ext Reqe). Qed.
    Add Morphism rmul : rmul_ext4.  exact (Rmul_ext Reqe). Qed.
-   Add Morphism ropp : ropp_ext4.  exact (Ropp_ext Reqe). Qed.
-   Add Morphism rsub : rsub_ext5.  exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite Rsth Reqe ARth.
+   Ltac norm := gen_srewrite_sr Rsth Reqe ARth.
 
  Definition gen_phiN1 x :=
   match x with
@@ -326,8 +284,8 @@ Section NMORPHISM.
 
  Lemma same_genN : forall x, [x] == gen_phiN1 x.
  Proof.
-  destruct x;simpl. rrefl.
-  rewrite (same_gen Rsth Reqe ARth);rrefl.
+  destruct x;simpl. reflexivity.
+  now rewrite (same_gen Rsth Reqe ARth).
  Qed.
 
  Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y].
@@ -349,11 +307,11 @@ Section NMORPHISM.
 
 (*gen_phiN satisfies morphism specifications*)
  Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req
-                           N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN.
+                           0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN.
  Proof.
-  constructor;intros;simpl; try rrefl.
-  apply gen_phiN_add. apply gen_phiN_sub.  apply gen_phiN_mult.
-  rewrite (Neq_bool_ok x y);trivial. rrefl.
+  constructor; simpl; try reflexivity.
+  apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult.
+  intros x y EQ. apply N.eqb_eq in EQ. now subst.
  Qed.
 
 End NMORPHISM.
@@ -402,7 +360,7 @@ Fixpoint Nw_is0 (w : Nword) : bool :=
 Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool :=
   match w1, w2 with
   | n1::w1', n2::w2' =>
-     if Neq_bool n1 n2 then Nweq_bool w1' w2' else false
+     if N.eqb n1 n2 then Nweq_bool w1' w2' else false
   | nil, _ => Nw_is0 w2
   | _, nil => Nw_is0 w1
   end.
@@ -486,10 +444,10 @@ induction w1; intros.
 
   simpl in H.
   rewrite gen_phiNword_cons in |- *.
-  case_eq (Neq_bool a n); intros.
+  case_eq (N.eqb a n); intros H0.
    rewrite H0 in H.
-   rewrite <- (Neq_bool_ok _ _ H0) in |- *.
-   rewrite (IHw1 _ H) in |- *.
+   apply N.eqb_eq in H0. rewrite <- H0.
+   rewrite (IHw1 _ H).
    reflexivity.
 
    rewrite H0 in H;  discriminate H.
@@ -632,19 +590,19 @@ Qed.
 
  Variable zphi : Z -> R.
 
- Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl.
+ Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem.
  Proof.
   constructor.
-  intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst.
-  rewrite Zmult_comm; rsimpl.
+  intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst.
+  rewrite Z.mul_comm; rsimpl.
  Qed.
 
  Variable nphi : N -> R.
 
- Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl.
+ Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl.
   constructor.
-  intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst.
-  rewrite Nmult_comm; rsimpl.
+  intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst.
+  rewrite N.mul_comm; rsimpl.
  Qed.
 
 End GEN_DIV.
diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v
new file mode 100644
index 00000000..5a224e38
--- /dev/null
+++ b/plugins/setoid_ring/Integral_domain.v
@@ -0,0 +1,44 @@
+Require Export Cring.
+
+
+(* Definition of integral domains: commutative ring without zero divisor *)
+
+Class Integral_domain {R : Type}`{Rcr:Cring R} := {
+ integral_domain_product:
+   forall x y, x * y == 0 -> x == 0 \/ y == 0;
+ integral_domain_one_zero: not (1 == 0)}.
+
+Section integral_domain.
+
+Context {R:Type}`{Rid:Integral_domain R}.
+
+Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0.
+red;intro. apply integral_domain_one_zero. 
+assert (0 == - (0:R)). cring.
+rewrite H0. rewrite <- H. cring.
+Qed.
+
+
+Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N_of_nat n).
+
+Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0.
+induction n. unfold pow; simpl. intros. absurd (1 == 0). 
+simpl. apply integral_domain_one_zero.
+ trivial. setoid_replace (pow p (S n)) with (p * (pow p n)).
+intros. 
+case (integral_domain_product p (pow p n) H). trivial. trivial. 
+unfold pow; simpl. 
+clear IHn. induction n; simpl; try cring. 
+ rewrite Ring_theory.pow_pos_Psucc. cring. apply ring_setoid.
+apply ring_mult_comp.
+apply cring_mul_comm.
+apply ring_mul_assoc.
+Qed.
+
+Lemma Rintegral_domain_pow:
+  forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0.
+intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto. 
+intros. apply pow_not_zero with r. trivial. Qed.   
+
+End integral_domain.
+
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index 8d7cb0ea..fafd16ab 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -18,4 +18,4 @@ Ltac Ncst t :=
   | _ => constr:NotConstant
   end.
 
-Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
+Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v
new file mode 100644
index 00000000..9a30fa47
--- /dev/null
+++ b/plugins/setoid_ring/Ncring.v
@@ -0,0 +1,305 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* non commutative rings *)
+
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinNat.
+Require Export Morphisms Setoid Bool.
+Require Export ZArith_base.
+Require Export Algebra_syntax.
+
+Set Implicit Arguments.
+
+Class Ring_ops(T:Type)
+   {ring0:T}
+   {ring1:T}
+   {add:T->T->T}
+   {mul:T->T->T}
+   {sub:T->T->T}
+   {opp:T->T}
+   {ring_eq:T->T->Prop}.
+
+Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. 
+Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1.
+Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add.
+Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul.
+Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub.
+Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp.
+Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq.
+
+Class Ring `{Ro:Ring_ops}:={
+ ring_setoid: Equivalence _==_;
+ ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_;
+ ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_;
+ ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_;
+ ring_opp_comp: Proper (_==_==>_==_) -_;
+ ring_add_0_l    : forall x, 0 + x == x;
+ ring_add_comm   : forall x y, x + y == y + x;
+ ring_add_assoc  : forall x y z, x + (y + z) == (x + y) + z;
+ ring_mul_1_l    : forall x, 1 * x == x;
+ ring_mul_1_r    : forall x, x * 1 == x;
+ ring_mul_assoc  : forall x y z, x * (y * z) == (x * y) * z;
+ ring_distr_l    : forall x y z, (x + y) * z == x * z + y * z;
+ ring_distr_r    : forall x y z, z * ( x + y) == z * x + z * y;
+ ring_sub_def    : forall x y, x - y == x + -y;
+ ring_opp_def    : forall x, x + -x == 0
+}.
+(* inutile! je sais plus pourquoi j'ai mis ca...
+Instance ring_Ring_ops(R:Type)`{Ring R}
+  :@Ring_ops R 0 1 addition multiplication subtraction opposite equality.
+*)
+Existing Instance ring_setoid.
+Existing Instance ring_plus_comp.
+Existing Instance ring_mult_comp.
+Existing Instance ring_sub_comp.
+Existing Instance ring_opp_comp.
+
+Section Ring_power.
+
+Context {R:Type}`{Ring R}.
+
+ Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+  match i with
+  | xH => x
+  | xO i => let p := pow_pos x i in p * p
+  | xI i => let p := pow_pos x i in x * (p * p)
+  end.
+
+ Definition pow_N (x:R) (p:N) :=
+  match p with
+  | N0 => 1
+  | Npos p => pow_pos x p
+  end.
+
+End Ring_power.
+
+Definition ZN(x:Z):=
+  match x with
+    Z0 => N0
+    |Zpos p | Zneg p => Npos p
+end.
+
+Instance power_ring {R:Type}`{Ring R} : Power:=
+  {power x y := pow_N x (ZN y)}.
+
+(** Interpretation morphisms definition*)
+
+Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= {
+    ring_morphism0    : [0] == 0;
+    ring_morphism1    : [1] == 1;
+    ring_morphism_add : forall x y, [x + y] == [x] + [y];
+    ring_morphism_sub : forall x y, [x - y] == [x] - [y];
+    ring_morphism_mul : forall x y, [x * y] == [x] * [y];
+    ring_morphism_opp : forall  x, [-x] == -[x];
+    ring_morphism_eq  : forall x y, x == y -> [x] == [y]}.
+
+Section Ring.
+
+Context {R:Type}`{Rr:Ring R}.
+
+(* Powers *)
+
+ Lemma pow_pos_comm : forall  x j,  x * pow_pos x j == pow_pos x j * x.
+induction j; simpl. rewrite <- ring_mul_assoc.
+rewrite <- ring_mul_assoc. 
+rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)).
+rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity.
+rewrite <- ring_mul_assoc. rewrite <- IHj.
+rewrite ring_mul_assoc. rewrite IHj.
+rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. reflexivity.
+Qed.
+
+ Lemma pow_pos_Psucc : forall  x j, pow_pos x (Psucc j) == x * pow_pos x j.
+ Proof.
+  induction j; simpl. 
+  rewrite IHj. 
+rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)).
+rewrite (ring_mul_assoc (pow_pos x j) x  (pow_pos x j)).
+  rewrite <- pow_pos_comm.
+rewrite <- ring_mul_assoc. reflexivity.
+reflexivity. reflexivity.
+Qed.
+
+ Lemma pow_pos_Pplus : forall  x i j,
+   pow_pos x (i + j) == pow_pos x i * pow_pos x j.
+ Proof.
+  intro x;induction i;intros.
+  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;
+  rewrite pow_pos_Psucc.
+  simpl;repeat rewrite ring_mul_assoc. reflexivity.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc.
+   simpl. reflexivity. 
+ Qed.
+
+ Definition id_phi_N (x:N) : N := x.
+
+ Lemma pow_N_pow_N : forall  x n, pow_N x (id_phi_N n) == pow_N x n.
+ Proof.
+  intros; reflexivity.
+ Qed.
+
+ (** Identity is a morphism *)
+ (*
+ Instance IDmorph : Ring_morphism _ _ _  (fun x => x).
+ Proof.
+  apply (Build_Ring_morphism H6 H6 (fun x => x));intros;
+  try reflexivity. trivial.
+ Qed.
+*)
+ (** rings are almost rings*)
+ Lemma ring_mul_0_l : forall  x, 0 * x == 0.
+ Proof.
+  intro x. setoid_replace (0*x) with ((0+1)*x + -x). 
+  rewrite ring_add_0_l. rewrite ring_mul_1_l .
+  rewrite ring_opp_def . fold zero. reflexivity.
+  rewrite ring_distr_l . rewrite ring_mul_1_l .
+  rewrite <- ring_add_assoc ; rewrite ring_opp_def .
+  rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity.
+ Qed.
+
+ Lemma ring_mul_0_r : forall  x, x * 0 == 0.
+ Proof.
+  intro x; setoid_replace (x*0)  with (x*(0+1) + -x).
+  rewrite ring_add_0_l ; rewrite ring_mul_1_r .
+  rewrite ring_opp_def ; fold zero; reflexivity.
+
+  rewrite ring_distr_r ;rewrite ring_mul_1_r .
+  rewrite <- ring_add_assoc ; rewrite ring_opp_def .
+  rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity.
+ Qed.
+
+ Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y.
+ Proof.
+  intros x y;rewrite <- (ring_add_0_l (- x * y)).
+  rewrite ring_add_comm .
+  rewrite <- (ring_opp_def (x*y)).
+  rewrite ring_add_assoc .
+  rewrite <- ring_distr_l.
+  rewrite (ring_add_comm (-x));rewrite ring_opp_def .
+  rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity.
+ Qed.
+
+Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y.
+ Proof.
+  intros x y;rewrite <- (ring_add_0_l (x * - y)).
+  rewrite ring_add_comm .
+  rewrite <- (ring_opp_def (x*y)).
+  rewrite ring_add_assoc .
+  rewrite <- ring_distr_r .
+  rewrite (ring_add_comm (-y));rewrite ring_opp_def .
+  rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity.
+ Qed.
+
+ Lemma ring_opp_add : forall x y, -(x + y) == -x + -y.
+ Proof.
+  intros x y;rewrite <- (ring_add_0_l  (-(x+y))).
+  rewrite <- (ring_opp_def  x).
+  rewrite <- (ring_add_0_l  (x + - x + - (x + y))).
+  rewrite <- (ring_opp_def  y).
+  rewrite (ring_add_comm  x).
+  rewrite (ring_add_comm  y).
+  rewrite <- (ring_add_assoc  (-y)).
+  rewrite <- (ring_add_assoc  (- x)).
+  rewrite (ring_add_assoc   y).
+  rewrite (ring_add_comm  y).
+  rewrite <- (ring_add_assoc   (- x)).
+  rewrite (ring_add_assoc  y).
+  rewrite (ring_add_comm  y);rewrite ring_opp_def .
+  rewrite (ring_add_comm  (-x) 0);rewrite ring_add_0_l .
+  rewrite ring_add_comm; reflexivity.
+ Qed.
+
+ Lemma ring_opp_opp : forall  x, - -x == x.
+ Proof.
+  intros x; rewrite <- (ring_add_0_l (- -x)).
+  rewrite <- (ring_opp_def x).
+  rewrite <- ring_add_assoc ; rewrite ring_opp_def .
+  rewrite (ring_add_comm  x); rewrite ring_add_0_l . reflexivity.
+ Qed.
+
+ Lemma ring_sub_ext :
+      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 (x2 - y2)  with (x2 + -y2).
+  rewrite H;rewrite H0;reflexivity.
+  rewrite ring_sub_def. reflexivity.
+  rewrite ring_sub_def. reflexivity.
+ Qed.
+
+ Ltac mrewrite :=
+   repeat first
+     [ rewrite ring_add_0_l
+     | rewrite <- (ring_add_comm 0)
+     | rewrite ring_mul_1_l
+     | rewrite ring_mul_0_l
+     | rewrite ring_distr_l
+     | reflexivity
+     ].
+
+ Lemma ring_add_0_r : forall  x, (x + 0) == x.
+ Proof. intros; mrewrite. Qed.
+
+ 
+ Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
+ Proof.
+  intros;rewrite <- (ring_add_assoc x).
+  rewrite (ring_add_comm x);reflexivity.
+ Qed.
+
+ Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
+ Proof.
+  intros; repeat rewrite <- ring_add_assoc.
+   rewrite (ring_add_comm x); reflexivity.
+ Qed.
+
+ Lemma ring_opp_zero : -0 == 0.
+ Proof.
+  rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l.
+  repeat rewrite ring_mul_0_r. reflexivity.
+ Qed.
+
+End Ring.
+
+(** Some simplification tactics*)
+Ltac gen_reflexivity := reflexivity.
+ 
+Ltac gen_rewrite :=
+  repeat first
+     [ reflexivity
+     | progress rewrite ring_opp_zero
+     | rewrite ring_add_0_l
+     | rewrite ring_add_0_r
+     | rewrite ring_mul_1_l 
+     | rewrite ring_mul_1_r
+     | rewrite ring_mul_0_l 
+     | rewrite ring_mul_0_r 
+     | rewrite ring_distr_l 
+     | rewrite ring_distr_r 
+     | rewrite ring_add_assoc 
+     | rewrite ring_mul_assoc
+     | progress rewrite ring_opp_add 
+     | progress rewrite ring_sub_def 
+     | progress rewrite <- ring_opp_mul_l 
+     | progress rewrite <- ring_opp_mul_r ].
+
+Ltac gen_add_push x :=
+repeat (match goal with
+  | |- context [(?y + x) + ?z] =>
+     progress rewrite (ring_add_assoc2 x y z)
+  | |- context [(x + ?y) + ?z] =>
+     progress rewrite  (ring_add_assoc1 x y z)
+  end).
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
new file mode 100644
index 00000000..3c79f7d9
--- /dev/null
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -0,0 +1,221 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import ZArith_base.
+Require Import Zpow_def.
+Require Import BinInt.
+Require Import BinNat.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Import Setoid.
+Require Export Ncring.
+Require Export Ncring_polynom.
+Import List.
+
+Set Implicit Arguments.
+
+(* An object to return when an expression is not recognized as a constant *)
+Definition NotConstant := false.
+
+(** Z is a ring and a setoid*)
+
+Lemma Zsth : Setoid_Theory Z (@eq Z).
+constructor;red;intros;subst;trivial.
+Qed.
+
+Instance Zops:@Ring_ops Z 0%Z 1%Z Zplus Zmult Zminus Zopp (@eq Z).
+
+Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops).
+constructor;
+try (try apply Zsth;
+   try (unfold respectful, Proper; unfold equality; unfold eq_notation in *;
+  intros; try rewrite H; try rewrite H0; reflexivity)).
+ exact Zplus_comm. exact Zplus_assoc.
+ exact Zmult_1_l.  exact Zmult_1_r. exact Zmult_assoc.
+ exact Zmult_plus_distr_l.  intros; apply Zmult_plus_distr_r.  exact Zminus_diag.
+Defined.
+
+(*Instance ZEquality: @Equality Z:= (@eq Z).*)
+
+(** Two generic morphisms from Z to (abrbitrary) rings, *)
+(**second one is more convenient for proofs but they are ext. equal*)
+Section ZMORPHISM.
+Context {R:Type}`{Ring R}.
+
+ Ltac rrefl := reflexivity.
+
+ Fixpoint gen_phiPOS1 (p:positive) : R :=
+  match p with
+  | xH => 1
+  | xO p => (1 + 1) * (gen_phiPOS1 p)
+  | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p))
+  end.
+
+ Fixpoint gen_phiPOS (p:positive) : R :=
+  match p with
+  | xH => 1
+  | xO xH => (1 + 1)
+  | xO p => (1 + 1) * (gen_phiPOS p)
+  | xI xH => 1 + (1 +1)
+  | xI p => 1 + ((1 + 1) * (gen_phiPOS p))
+  end.
+
+ Definition gen_phiZ1 z :=
+  match z with
+  | Zpos p => gen_phiPOS1 p
+  | Z0 => 0
+  | Zneg p => -(gen_phiPOS1 p)
+  end.
+
+ 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).
+
+ Definition get_signZ z :=
+  match z with
+  | Zneg p => Some (Zpos p)
+  | _ => None
+  end.
+
+   Ltac norm := gen_rewrite.
+   Ltac add_push :=  Ncring.gen_add_push.
+Ltac rsimpl := simpl.
+
+ Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
+ Proof.
+  induction x;rsimpl.
+  rewrite IHx. destruct x;simpl;norm.
+  rewrite IHx;destruct x;simpl;norm.
+  reflexivity.
+ Qed.
+
+ Lemma ARgen_phiPOS_Psucc : forall x,
+   gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
+ Proof.
+  induction x;rsimpl;norm.
+ rewrite IHx. gen_rewrite. add_push 1. reflexivity.
+ Qed.
+
+ Lemma ARgen_phiPOS_add : forall x y,
+   gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y).
+ Proof.
+  induction x;destruct y;simpl;norm.
+  rewrite Pplus_carry_spec.
+  rewrite ARgen_phiPOS_Psucc.
+  rewrite IHx;norm.
+  add_push (gen_phiPOS1 y);add_push 1;reflexivity.
+  rewrite IHx;norm;add_push (gen_phiPOS1 y);reflexivity.
+  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity.
+  rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;reflexivity.
+  rewrite IHx;norm;add_push(gen_phiPOS1 y);reflexivity.
+  add_push 1;reflexivity.
+  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity.
+ Qed.
+
+ Lemma ARgen_phiPOS_mult :
+   forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y.
+ Proof.
+  induction x;intros;simpl;norm.
+  rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm.
+  rewrite IHx;reflexivity.
+ Qed.
+
+
+(*morphisms are extensionaly equal*)
+ Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
+ Proof.
+  destruct x;rsimpl; try rewrite same_gen; reflexivity.
+ Qed.
+
+ Lemma gen_Zeqb_ok : forall x y,
+   Zeq_bool x y = true -> [x] == [y].
+ Proof.
+  intros x y H7.
+  assert (H10 := Zeq_bool_eq x y H7);unfold IDphi in H10.
+  rewrite H10;reflexivity.
+ Qed.
+
+ Lemma gen_phiZ1_add_pos_neg : forall x y,
+ gen_phiZ1 (Z.pos_sub x y)
+ == gen_phiPOS1 x + -gen_phiPOS1 y.
+ Proof.
+  intros x y.
+  rewrite Z.pos_sub_spec.
+  assert (HH0 := Pminus_mask_Gt x y). unfold Pos.gt in HH0.
+  assert (HH1 := Pminus_mask_Gt y x). unfold Pos.gt in HH1.
+  rewrite Pos.compare_antisym in HH1.
+  destruct (Pos.compare_spec x y) as [HH|HH|HH].
+  subst. rewrite ring_opp_def;reflexivity.
+  destruct HH1 as [h [HHeq1 [HHeq2 HHor]]];trivial.
+  unfold Pminus; rewrite HHeq1;rewrite <- HHeq2.
+  rewrite ARgen_phiPOS_add;simpl;norm.
+  rewrite ring_opp_def;norm.
+  destruct HH0 as [h [HHeq1 [HHeq2 HHor]]];trivial.
+  unfold Pminus; rewrite HHeq1;rewrite <- HHeq2.
+  rewrite ARgen_phiPOS_add;simpl;norm.
+  add_push (gen_phiPOS1 h). rewrite ring_opp_def ; norm.
+ Qed.
+
+ Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
+  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.
+
+ Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
+ Proof.
+  intros x y; repeat rewrite same_genZ; generalize x y;clear x y.
+  induction x;destruct y;simpl;norm.
+  apply ARgen_phiPOS_add.
+  apply gen_phiZ1_add_pos_neg. 
+   rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm.
+reflexivity.
+ rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity.
+Qed.
+
+Lemma gen_phiZ_opp : forall x, [- x] == - [x].
+ Proof.
+  intros x. repeat rewrite same_genZ. generalize x ;clear x.
+  induction x;simpl;norm.
+  rewrite ring_opp_opp.  reflexivity.
+ Qed.
+
+ Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y].
+ Proof.
+  intros x y;repeat rewrite same_genZ.
+  destruct x;destruct y;simpl;norm;
+  rewrite  ARgen_phiPOS_mult;try (norm;fail).
+  rewrite ring_opp_opp ;reflexivity.
+ Qed.
+
+ Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
+ Proof. intros;subst;reflexivity. Qed.
+
+(*proof that [.] satisfies morphism specifications*)
+Global Instance gen_phiZ_morph :
+(@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*)
+ apply Build_Ring_morphism; simpl;try reflexivity.
+   apply gen_phiZ_add. intros. rewrite ring_sub_def. 
+replace (Zminus x y) with (x + (-y))%Z. rewrite gen_phiZ_add. 
+rewrite gen_phiZ_opp.  rewrite ring_sub_def. reflexivity.
+reflexivity.
+ apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext. 
+ Defined.
+
+End ZMORPHISM.
+
+Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication  :=
+  {multiplication x y := (gen_phiZ x) * y}.
+
+
diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v
new file mode 100644
index 00000000..c0d31587
--- /dev/null
+++ b/plugins/setoid_ring/Ncring_polynom.v
@@ -0,0 +1,621 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*  A <X1,...,Xn>: non commutative polynomials on a commutative ring A *)
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_polynom. (* n'utilise que PExpr *)
+Require Export Ncring.
+
+Section MakeRingPol.
+
+Context (C R:Type) `{Rh:Ring_morphism C R}.
+
+Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x.
+
+ Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm).
+ Ltac add_push := gen_add_push .
+
+(* Definition of non commutative multivariable polynomials 
+   with coefficients in C :
+ *)
+
+ Inductive Pol : Type :=
+  | Pc : C -> Pol
+  | PX : Pol -> positive -> positive -> Pol -> Pol. 
+    (* PX P i n Q represents P * X_i^n + Q *)
+Definition cO:C . exact ring0. Defined.
+Definition cI:C . exact ring1. Defined.
+
+ Definition P0 := Pc 0.
+ Definition P1 := Pc 1.
+
+Variable Ceqb:C->C->bool.
+Class Equalityb (A : Type):= {equalityb : A -> A -> bool}.
+Notation "x =? y" := (equalityb x y) (at level 70, no associativity).
+Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y).
+
+Instance equalityb_coef : Equalityb C :=
+  {equalityb x y := Ceqb x y}.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+  match P, P' with
+  | Pc c, Pc c' => c =? c'
+  | PX P i n Q, PX P' i' n' Q' =>
+    match Pcompare i i' Eq, Pcompare n n' Eq with
+    | Eq, Eq => if Peq P P' then Peq Q Q' else false
+    | _,_ => false
+    end
+  | _, _ => false
+  end.
+
+Instance equalityb_pol : Equalityb Pol :=
+  {equalityb x y := Peq x y}.
+
+(* Q a ses variables de queue < i *)
+ Definition mkPX P i n Q :=
+  match P with
+  | Pc c => if c =? 0 then Q else PX P i n Q 
+  | PX P' i' n' Q' => 
+       match Pcompare i i' Eq with
+        | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q
+        | _ => PX P i n Q
+       end
+  end.
+
+ Definition mkXi i n := PX P1 i n P0.
+
+ Definition mkX i := mkXi i 1.
+
+ (** Opposite of addition *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+  match P with
+  | Pc c => Pc (- c)
+  | PX P i n Q => PX (Popp P) i n (Popp Q)
+  end.
+
+ Notation "-- P" := (Popp P)(at level 30).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c + c1)
+  | PX P i n Q => PX P i n (PaddCl c Q)
+  end.
+
+(* Q quelconque *)
+
+Section PaddX.
+Variable Padd:Pol->Pol->Pol.
+Variable P:Pol.
+
+(* Xi^n * P + Q
+les variables de tete de Q ne sont pas forcement < i 
+mais Q est normalisé : variables de tete decroissantes *)
+
+Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:=
+  match Q with
+  | Pc c => mkPX P i n Q
+  | PX P' i' n' Q' => 
+      match Pcompare i i' Eq with
+      | (* i > i' *)
+        Gt => mkPX P i n Q
+      | (* i < i' *)
+        Lt => mkPX P' i' n' (PaddX i n Q')
+      | (* i = i' *)
+        Eq => match ZPminus n n' with
+              | (* n > n' *) 
+                Zpos k => mkPX (PaddX i k P') i' n' Q'
+              | (* n = n' *)
+                Z0 => mkPX (Padd P P') i n Q'
+              | (* n < n' *)
+                Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q'
+              end
+      end
+  end.
+
+End PaddX.
+
+Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol :=
+  match P1 with
+  | Pc c => PaddCl c P2
+  | PX P' i' n' Q' =>
+      PaddX Padd P' i' n' (Padd Q' P2)
+  end.
+
+ Notation "P ++ P'" := (Padd P P').
+
+Definition Psub(P P':Pol):= P ++ (--P').
+
+ Notation "P -- P'" := (Psub P P')(at level 50).
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C)  {struct P} : Pol :=
+  match P with
+  | Pc c' => Pc (c' * c)
+  | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c)
+  end.
+
+ Definition PmulC P c :=
+  if c =? 0 then P0 else
+  if c =? 1 then P else PmulC_aux P c.
+
+ Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol :=
+   match P2 with
+   | Pc c => PmulC P1 c
+   | PX P i n Q =>
+     PaddX Padd (Pmul P1 P) i n (Pmul P1 Q)
+   end.
+
+ Notation "P ** P'" := (Pmul P P')(at level 40).
+
+ Definition Psquare (P:Pol) : Pol := P ** P.
+
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
+  match P with
+  | Pc c => [c]
+  | PX P i n Q =>
+     let x := nth 0 i l in
+     let xn := pow_pos x n in
+   (Pphi l P) * xn + (Pphi l Q)
+  end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+ (** Proofs *)
+ Lemma ZPminus_spec : forall x y,
+  match ZPminus x y with
+  | Z0 => x = y
+  | Zpos k => x = (y + k)%positive
+  | Zneg k => y = (x + k)%positive
+  end.
+ Proof.
+  induction x;destruct y.
+  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
+  assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble;
+rewrite Hh;trivial.
+  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));
+trivial.
+  assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;
+rewrite Hh;trivial.
+  apply Pplus_xI_double_minus_one.
+  simpl;trivial.
+  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));
+trivial.
+  assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;
+rewrite Hh;trivial.
+  apply Pplus_xI_double_minus_one.
+  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+  assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite Hh;
+trivial.
+  replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+  replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  simpl;trivial.
+ Qed.
+
+ 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.
+ apply ring_morphism_eq.
+ apply Ceqb_eq ;trivial.
+  assert (H1h := IHP1 P'1);assert (H2h := IHP2 P'2).
+   simpl in H1h. destruct (Peq P2 P'1). simpl in H2h; 
+destruct (Peq P3 P'2).
+  rewrite (H1h);trivial . rewrite (H2h);trivial. 
+assert (H3h := Pcompare_Eq_eq p p1);
+ destruct (Pos.compare_cont p p1 Eq);
+assert (H4h := Pcompare_Eq_eq p0 p2);
+destruct (Pos.compare_cont p0 p2 Eq); try (discriminate H).
+ rewrite H3h;trivial. rewrite H4h;trivial. reflexivity.
+ destruct (Pos.compare_cont p p1 Eq); destruct (Pos.compare_cont p0 p2 Eq);
+ try (discriminate H).
+ destruct (Pos.compare_cont p p1 Eq); destruct (Pos.compare_cont p0 p2 Eq);
+ try (discriminate H). 
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+  intros;simpl. 
+ rewrite ring_morphism0. reflexivity.
+ Qed.
+
+ Lemma Pphi1 : forall l,  P1@l == 1.
+ Proof.
+  intros;simpl; rewrite ring_morphism1. reflexivity.
+ Qed.
+
+ Lemma mkPX_ok : forall l P i n Q,
+  (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l.
+ Proof.
+  intros l P i n Q;unfold mkPX.
+  destruct P;try (simpl;reflexivity).
+  assert (Hh := ring_morphism_eq  c 0). 
+simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
+intros.
+  rewrite Hh. rewrite ring_morphism0.
+  rsimpl. apply Ceqb_eq. trivial. assert (Hh1 := Pcompare_Eq_eq i p);
+destruct (Pos.compare_cont i p Eq).
+  assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. 
+  rewrite Hh. 
+  rewrite Pphi0. rsimpl. rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl.
+rewrite Hh1;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity.
+ simpl. reflexivity.
+ Qed.
+
+Ltac Esimpl :=
+  repeat (progress (
+   match goal with
+   | |- context [?P@?l] =>
+       match P with
+       | P0 => rewrite (Pphi0 l)
+       | P1 => rewrite (Pphi1 l)
+       | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q)
+       end
+   | |- context [[?c]] =>
+       match c with
+       | 0 => rewrite ring_morphism0
+       | 1 => rewrite ring_morphism1
+       | ?x + ?y => rewrite ring_morphism_add
+       | ?x * ?y => rewrite ring_morphism_mul
+       | ?x - ?y => rewrite ring_morphism_sub
+       | - ?x => rewrite ring_morphism_opp
+       end
+   end));
+  simpl; rsimpl.
+
+ Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l .
+ Proof.
+  induction P; simpl; intros; Esimpl; try reflexivity.
+ rewrite IHP2. rsimpl. 
+rewrite (ring_add_comm  (P2 @ l * pow_pos (nth 0 p l) p0) [c]).
+reflexivity.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l ==  P@l * [c].
+ Proof.
+  induction P;simpl;intros.  rewrite ring_morphism_mul.
+try reflexivity.
+  simpl. Esimpl.  rewrite IHP1;rewrite IHP2;rsimpl. 
+  Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l ==  P@l * [c].
+ Proof.
+  intros c P l; unfold PmulC.
+  assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros.
+  rewrite Hh;Esimpl. apply Ceqb_eq;trivial. 
+  assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros.
+  rewrite H1h;Esimpl. apply Ceqb_eq;trivial.
+  apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+  Esimpl;
+  repeat (progress (
+   match goal with
+   | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l)
+   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+   end)); Esimpl.
+
+Lemma PaddXPX: forall P i n Q,
+  PaddX Padd P i n Q =
+  match Q with
+  | Pc c => mkPX P i n Q
+  | PX P' i' n' Q' => 
+      match Pcompare i i' Eq with
+      | (* i > i' *)
+        Gt => mkPX P i n Q
+      | (* i < i' *)
+        Lt => mkPX P' i' n' (PaddX Padd P i n Q')
+      | (* i = i' *)
+        Eq => match ZPminus n n' with
+              | (* n > n' *) 
+                Zpos k => mkPX (PaddX Padd P i k P') i' n' Q'
+              | (* n = n' *)
+                Z0 => mkPX (Padd P P') i n Q'
+              | (* n < n' *)
+                Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q'
+              end
+      end
+  end.
+induction Q; reflexivity.
+Qed.
+
+Lemma PaddX_ok2 : forall P2,
+   (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l)
+   /\
+   (forall P k n l,
+           (PaddX Padd P2 k n P) @ l == 
+             P2 @ l * pow_pos (nth 0 k l) n  + P @ l).
+induction P2;simpl;intros. split. intros. apply PaddCl_ok.
+ induction P.  unfold PaddX. intros. rewrite mkPX_ok.
+ simpl. rsimpl.
+intros. simpl. assert (Hh := Pcompare_Eq_eq k p);
+ destruct (Pos.compare_cont k p Eq).
+ assert (H1h := ZPminus_spec n p0);destruct (ZPminus n p0). Esimpl2.
+rewrite Hh; trivial. rewrite H1h. reflexivity.
+simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2.
+ rewrite Pplus_comm in H1h.
+rewrite H1h. 
+rewrite pow_pos_Pplus.  Esimpl2.
+rewrite Hh; trivial. reflexivity.
+rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pplus_comm in H1h.
+rewrite H1h.  Esimpl2. rewrite pow_pos_Pplus. Esimpl2.
+rewrite Hh; trivial. reflexivity.
+rewrite mkPX_ok. rewrite IHP2. Esimpl2.
+rewrite (ring_add_comm  (P2 @ l * pow_pos (nth 0 p l) p0) 
+                             ([c] * pow_pos (nth 0 k l) n)).
+reflexivity.  assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c  0); 
+ intros; simpl.
+rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity.
+decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2.
+split. intros. rewrite H0. rewrite H1.
+Esimpl2.
+induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity.
+intros. rewrite PaddXPX. 
+assert (H3h := Pcompare_Eq_eq k p1);
+ destruct (Pos.compare_cont k p1 Eq).
+assert (H4h := ZPminus_spec n p2);destruct (ZPminus n p2). 
+rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2.
+rewrite H4h. rewrite H3h;trivial. reflexivity.
+rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial.
+rewrite Pplus_comm in H4h.
+rewrite H4h. rewrite pow_pos_Pplus. Esimpl2.
+rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. 
+rewrite mkPX_ok.
+ Esimpl2. rewrite H3h;trivial.
+ rewrite Pplus_comm in H4h.
+rewrite H4h. rewrite pow_pos_Pplus. Esimpl2.
+rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2.
+gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity.
+rewrite mkPX_ok. simpl. reflexivity.
+Qed.
+
+Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l.
+intro P. elim (PaddX_ok2 P); auto.
+Qed.
+
+Lemma PaddX_ok : forall P2 P k n l,
+   (PaddX Padd P2 k n P) @ l ==  P2 @ l * pow_pos (nth 0 k l) n  + P @ l.
+intro P2. elim (PaddX_ok2 P2); auto.
+Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl.
+ Qed.
+
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+induction P'; simpl; intros. rewrite PmulC_ok. reflexivity.
+rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2.
+Qed.
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+  intros. unfold Psquare. apply Pmul_ok.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+(*
+ Inductive PExpr : Type :=
+  | PEc : C -> PExpr
+  | PEX : positive -> PExpr
+  | PEadd : PExpr -> PExpr -> PExpr
+  | PEsub : PExpr -> PExpr -> PExpr
+  | PEmul : PExpr -> PExpr -> PExpr
+  | PEopp : PExpr -> PExpr
+  | PEpow : PExpr -> N -> PExpr.
+*)
+
+ (** Specification of the power function *)
+ Section POWER.
+  Variable Cpow : Set.
+  Variable Cp_phi : N -> Cpow.
+  Variable rpow : R -> Cpow -> R.
+
+  Record power_theory : Prop := mkpow_th {
+    rpow_pow_N : forall r n,  (rpow r (Cp_phi n))== (pow_N r n)
+  }.
+
+ End POWER.
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory Cp_phi rpow.
+
+ (** evaluation of polynomial expressions towards R *)
+ Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R :=
+   match pe with
+   | PEc c => [c]
+   | PEX j => nth 0 j l
+   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
+   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
+   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
+   | PEopp pe1 => - (PEeval l pe1)
+   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
+   end.
+
+Strategy expand [PEeval].
+
+ Definition mk_X j := mkX j.
+
+ (** Correctness proofs *)
+
+ Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
+ Proof.
+  destruct p;simpl;intros;Esimpl;trivial.
+ Qed.
+
+ Ltac Esimpl3 :=
+  repeat match goal with
+  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l)
+  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l)
+  end;try Esimpl2;try reflexivity;try apply ring_add_comm.
+
+(* Power using the chinise algorithm *)
+
+Section POWER2.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => subst_l (Pmul P res)
+   | xO p => Ppow_pos (Ppow_pos res P p) P p
+   | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p))
+   end.
+
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P1 P p
+   end.
+
+  Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R :=
+  match i with
+  | xH => x
+  | xO i => let p := pow_pos_gen m x i in m p p
+  | xI i => let p := pow_pos_gen m x i in m x (m 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 == (pow_pos_gen Pmul P p)@l * res@l.
+  Proof.
+   intros l subst_l_ok res P p. generalize res;clear res.
+   induction p;simpl;intros. try rewrite subst_l_ok.
+ repeat rewrite Pmul_ok. repeat rewrite IHp.
+   rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl.
+ try rewrite subst_l_ok.
+ repeat rewrite Pmul_ok. reflexivity.
+  Qed.
+
+Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
+  match p with
+  | N0 => x1
+  | Npos p => pow_pos_gen m x p
+  end.
+
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl.  Qed.
+
+ End POWER2.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+  Let subst_l (P:Pol) := P.
+  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Ppow_subst := Ppow_N subst_l.
+
+  Fixpoint norm_aux (pe:PExpr C) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => mk_X j
+   | PEadd pe1 (PEopp pe2) =>
+     Psub (norm_aux pe1) (norm_aux pe2)
+   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
+   | PEsub pe1 pe2 => Psub (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).
+
+ 
+ Lemma norm_aux_spec :
+     forall l pe, 
+       PEeval l pe == (norm_aux pe)@l.
+  Proof.
+   intros.
+   induction pe.
+Esimpl3. Esimpl3. simpl.
+ rewrite IHpe1;rewrite IHpe2.
+ destruct pe2; Esimpl3. 
+unfold Psub.
+destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
+simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
+destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity.
+Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
+ Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
+simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
+simpl. rewrite IHpe; Esimpl3. 
+simpl.
+   rewrite Ppow_N_ok; (intros;try reflexivity). 
+   rewrite rpow_pow_N.  Esimpl3.
+   induction n;simpl. Esimpl3. induction p; simpl.
+  try rewrite IHp;try rewrite IHpe;
+ repeat rewrite Pms_ok;
+      repeat rewrite Pmul_ok;reflexivity.
+rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe;
+ repeat rewrite Pms_ok;
+      repeat rewrite Pmul_ok;reflexivity. trivial.
+exact pow_th.
+  Qed.
+
+ Lemma norm_subst_spec :
+     forall l pe, 
+       PEeval l pe == (norm_subst pe)@l.
+ Proof.
+  intros;unfold norm_subst.
+  unfold subst_l.  apply norm_aux_spec. 
+ Qed.
+
+ End NORM_SUBST_REC.
+
+ Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop :=
+   match lpe with
+   | nil => True
+   | (me,pe)::lpe =>
+     match lpe with
+     | nil => PEeval l me == PEeval l pe
+     | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
+     end
+  end.
+
+
+ Lemma norm_subst_ok : forall l pe,
+   PEeval l pe == (norm_subst pe)@l.
+ Proof.
+   intros;apply norm_subst_spec. 
+  Qed.
+
+
+ Lemma ring_correct : forall l pe1 pe2,
+   (norm_subst pe1 =? norm_subst pe2) = true ->
+   PEeval l pe1 == PEeval l pe2.
+ Proof.
+  simpl;intros.
+  do 2 (rewrite (norm_subst_ok l);trivial).
+  apply Peq_ok;trivial.
+ Qed.
+
+End MakeRingPol.
diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v
new file mode 100644
index 00000000..34731eb3
--- /dev/null
+++ b/plugins/setoid_ring/Ncring_tac.v
@@ -0,0 +1,308 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Export Morphisms Setoid Bool.
+Require Import ZArith.
+Require Import Algebra_syntax.
+Require Export Ncring.
+Require Import Ncring_polynom.
+Require Import Ncring_initial.
+
+
+Set Implicit Arguments.
+
+Class nth (R:Type) (t:R) (l:list R) (i:nat).
+
+Instance  Ifind0 (R:Type) (t:R) l
+ : nth t(t::l) 0.
+
+Instance  IfindS (R:Type) (t2 t1:R) l i 
+ {_:nth t1 l i} 
+ : nth t1 (t2::l) (S i) | 1.
+
+Class closed (T:Type) (l:list T).
+
+Instance Iclosed_nil T 
+ : closed (T:=T) nil.
+
+Instance Iclosed_cons T t (l:list T) 
+ {_:closed l} 
+ : closed (t::l).
+
+Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R).
+
+Instance  reify_zero (R:Type)  lvar op
+ `{Ring (T:=R)(ring0:=op)}
+ : reify (ring0:=op)(PEc 0%Z) lvar op.
+
+Instance  reify_one (R:Type)  lvar op
+ `{Ring (T:=R)(ring1:=op)}
+ : reify (ring1:=op) (PEc 1%Z) lvar op.
+
+Instance  reifyZ0 (R:Type)  lvar 
+ `{Ring (T:=R)}
+ : reify (PEc Z0) lvar Z0|11.
+
+Instance  reifyZpos (R:Type)  lvar (p:positive)
+ `{Ring (T:=R)}
+ : reify (PEc (Zpos p)) lvar (Zpos p)|11.
+
+Instance  reifyZneg (R:Type)  lvar (p:positive)
+ `{Ring (T:=R)}
+ : reify (PEc (Zneg p)) lvar (Zneg p)|11.
+
+Instance  reify_add (R:Type)
+  e1 lvar t1 e2 t2 op 
+ `{Ring (T:=R)(add:=op)}
+ {_:reify (add:=op) e1 lvar t1}
+ {_:reify (add:=op) e2 lvar t2}
+ : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2).
+
+Instance  reify_mul (R:Type) 
+  e1 lvar t1 e2 t2 op 
+ `{Ring (T:=R)(mul:=op)}
+ {_:reify (mul:=op) e1 lvar t1}
+ {_:reify (mul:=op) e2 lvar t2}
+ : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10.
+
+Instance  reify_mul_ext (R:Type) `{Ring R}
+  lvar z e2 t2 
+ `{Ring (T:=R)}
+ {_:reify e2 lvar t2}
+ : reify (PEmul (PEc z) e2) lvar
+      (@multiplication Z _ _  z t2)|9.
+
+Instance  reify_sub (R:Type)
+ e1 lvar t1 e2 t2 op
+ `{Ring (T:=R)(sub:=op)}
+ {_:reify (sub:=op) e1 lvar t1}
+ {_:reify (sub:=op) e2 lvar t2}
+ : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2).
+
+Instance  reify_opp (R:Type)
+ e1 lvar t1  op
+ `{Ring (T:=R)(opp:=op)}
+ {_:reify (opp:=op) e1 lvar t1}
+ : reify (opp:=op) (PEopp e1) lvar (op t1).
+
+Instance  reify_pow (R:Type) `{Ring R}
+ e1 lvar t1 n 
+ `{Ring (T:=R)}
+ {_:reify e1 lvar t1}
+ : reify (PEpow e1 n) lvar (pow_N t1 n)|1.
+
+Instance  reify_var (R:Type) t lvar i 
+ `{nth R t lvar i}
+ `{Rr: Ring (T:=R)}
+ : reify (Rr:= Rr) (PEX Z (P_of_succ_nat i))lvar t 
+ | 100.
+
+Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) 
+  (lterm:list R).
+
+Instance reify_nil (R:Type) lvar 
+ `{Rr: Ring (T:=R)}
+ : reifylist (Rr:= Rr) nil lvar (@nil R).
+
+Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2
+ `{Rr: Ring (T:=R)}
+ {_:reify (Rr:= Rr) e1 lvar t1}
+ {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2} 
+ : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2).
+
+Definition list_reifyl (R:Type) lexpr lvar lterm 
+ `{Rr: Ring (T:=R)}
+ {_:reifylist (Rr:= Rr) lexpr lvar lterm}
+ `{closed (T:=R) lvar}  := (lvar,lexpr).
+
+Unset Implicit Arguments.
+
+
+Ltac lterm_goal g :=
+  match g with
+  | ?t1 == ?t2 => constr:(t1::t2::nil)
+  | ?t1 = ?t2 => constr:(t1::t2::nil)
+  | (_ ?t1 ?t2) => constr:(t1::t2::nil)
+  end.
+
+Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
+ intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. 
+
+Ltac reify_goal lvar lexpr lterm:=
+  (*idtac lvar; idtac lexpr; idtac lterm;*)
+  match lexpr with
+     nil => idtac
+   | ?e1::?e2::_ =>  
+        match goal with
+          |- (?op ?u1 ?u2) =>
+           change (op 
+             (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N
+                      (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)
+                      lvar e1)
+             (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N
+                      (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)
+                      lvar e2))
+        end
+  end. 
+
+Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R),
+  x * (gen_phiZ c) == (gen_phiZ c) * x.
+induction c. intros. simpl. gen_rewrite. simpl. intros.
+rewrite <- same_gen.
+induction p. simpl.  gen_rewrite. rewrite IHp. reflexivity.
+simpl.  gen_rewrite. rewrite IHp. reflexivity.
+simpl.  gen_rewrite. 
+simpl. intros. rewrite <- same_gen.
+induction p. simpl. generalize IHp. clear IHp.
+gen_rewrite. intro IHp.  rewrite IHp. reflexivity.
+simpl. generalize IHp. clear IHp.
+gen_rewrite. intro IHp.  rewrite IHp. reflexivity.
+simpl.  gen_rewrite. Qed.
+
+Ltac ring_gen :=
+   match goal with
+     |- ?g => let lterm := lterm_goal g in 
+       match eval red in (list_reifyl (lterm:=lterm)) with
+         | (?fv, ?lexpr) => 
+           (*idtac "variables:";idtac fv;
+           idtac "terms:"; idtac lterm;
+           idtac "reifications:"; idtac lexpr; *)
+           reify_goal fv lexpr lterm;
+           match goal with 
+             |- ?g => 
+               apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
+                       (@gen_phiZ _ _ _ _ _ _ _ _ _) _
+                 (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n)
+                 (@pow_N _ _ _ _ _ _ _ _ _));
+               [apply mkpow_th; reflexivity
+                 |vm_compute; reflexivity]
+           end
+       end
+   end.
+
+Ltac non_commutative_ring:= 
+  intros;
+  ring_gen.
+
+(* simplification *)
+
+Ltac ring_simplify_aux lterm fv lexpr hyp :=
+    match lterm with
+      | ?t0::?lterm =>
+    match lexpr with
+      | ?e::?le => (* e:PExpr Z est la réification de t0:R *)
+        let t := constr:(@Ncring_polynom.norm_subst
+          Z 0%Z 1%Z Zplus Zmult Zminus Zopp (@eq Z) Zops Zeq_bool e) in
+        (* t:Pol Z *)
+        let te := 
+          constr:(@Ncring_polynom.Pphi Z 
+            _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in
+        let eq1 := fresh "ring" in
+        let nft := eval vm_compute in t in
+        let t':= fresh "t" in
+        pose (t' := nft);
+        assert (eq1 : t = t');
+        [vm_cast_no_check (refl_equal t')|
+        let eq2 := fresh "ring" in
+        assert (eq2:(@Ncring_polynom.PEeval Z
+          _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) 
+          (@Ring_theory.pow_N _ 1 multiplication) fv e) == te);
+        [apply (@Ncring_polynom.norm_subst_ok
+          Z _ 0%Z 1%Z Zplus Zmult Zminus Zopp (@eq Z)
+          _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _
+          (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Zeqb_ok);
+           apply mkpow_th; reflexivity
+          | match hyp with
+                | 1%nat => rewrite eq2
+                | ?H => try rewrite eq2 in H
+              end];
+        let P:= fresh "P" in
+        match hyp with
+          | 1%nat => idtac "ok";
+            rewrite eq1;
+            pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_
+              _ Ncring_initial.gen_phiZ fv t');
+            match goal with
+              |- (?p ?t) => set (P:=p)
+            end;
+              unfold t' in *; clear t' eq1 eq2; simpl
+          | ?H =>
+               rewrite eq1 in H;
+               pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_
+                  _ Ncring_initial.gen_phiZ fv t') in H; 
+               match type of H with
+                  | (?p ?t)  => set (P:=p) in H
+               end;
+               unfold t' in *; clear t' eq1 eq2; simpl in H
+        end; unfold P in *; clear P
+        ]; ring_simplify_aux lterm fv le hyp
+      | nil => idtac
+    end
+    | nil => idtac
+    end.
+
+Ltac set_variables fv :=
+  match fv with
+    | nil => idtac
+    | ?t::?fv =>
+        let v := fresh "X" in
+        set (v:=t) in *; set_variables fv
+  end.
+
+Ltac deset n:=
+   match n with
+    | 0%nat => idtac
+    | S ?n1 =>
+      match goal with
+        | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1
+      end
+   end.
+
+(* a est soit un terme de l'anneau, soit une liste de termes.
+J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list
+ dans Tactic Notation *)
+
+Ltac ring_simplify_gen a hyp :=
+  let lterm :=
+    match a with
+      | _::_ => a
+      | _ => constr:(a::nil)
+    end in
+    match eval red in (list_reifyl (lterm:=lterm)) with
+      | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr;
+      let n := eval compute in (length fv) in
+      idtac n;
+      let lt:=fresh "lt" in
+      set (lt:= lterm);
+      let lv:=fresh "fv" in
+      set (lv:= fv);
+      (* les termes de fv sont remplacés par des variables 
+         pour pouvoir utiliser simpl ensuite sans risquer
+         des simplifications indésirables *)
+      set_variables fv;
+      let lterm1 := eval unfold lt in lt in
+      let lv1 := eval unfold lv in lv in
+        idtac lterm1; idtac lv1;
+      ring_simplify_aux lterm1 lv1 lexpr hyp;
+      clear lt lv;
+      (* on remet les termes de fv *)
+      deset n
+    end.
+
+Tactic Notation "non_commutative_ring_simplify" constr(lterm):=
+ ring_simplify_gen lterm 1%nat.
+
+Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):=
+ ring_simplify_gen lterm H.
+
+
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index 7b48f590..c44c2edf 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index 9bc95a7f..6d4360d6 100644
--- a/plugins/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index d33a095f..b722a31b 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -38,7 +38,7 @@ Section MakeRingPol.
                                 cO cI cadd cmul csub copp ceqb phi.
 
   (* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -104,12 +104,12 @@ Section MakeRingPol.
   match P, P' with
   | Pc c, Pc c' => c ?=! c'
   | Pinj j Q, Pinj j' Q' =>
-    match Pcompare j j' Eq with
+    match j ?= j' with
     | Eq => Peq Q Q'
     | _ => false
     end
   | PX P i Q, PX P' i' Q' =>
-    match Pcompare i i' Eq with
+    match i ?= i' with
     | Eq => if Peq P P' then Peq Q Q' else false
     | _ => false
     end
@@ -435,7 +435,7 @@ Section MakeRingPol.
             CFactor P c
    | Pc _, _    => (P, Pc cO)
    | Pinj j1 P1, zmon j2 M1 =>
-      match (j1 ?= j2) Eq with
+      match j1 ?= j2 with
         Eq => let (R,S) := MFactor P1 c M1 in
                  (mkPinj j1 R, mkPinj j1 S)
       | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in
@@ -449,7 +449,7 @@ Section MakeRingPol.
              let (R2, S2) := MFactor Q1 c M2 in
                (mkPX R1 i R2, mkPX S1 i S2)
   | PX P1 i Q1, vmon j M1 =>
-      match (i ?= j) Eq with
+      match i ?= j with
         Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in
                  (mkPX R1 i Q1, S1)
       | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in
@@ -552,10 +552,10 @@ Section MakeRingPol.
  Proof.
   induction P;destruct P';simpl;intros;try discriminate;trivial.
   apply (morph_eq CRmorph);trivial.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+  assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0);
    try discriminate H.
   rewrite (IHP P' H); rewrite H1;trivial;rrefl.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+  assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0);
    try discriminate H.
   rewrite H1;trivial. clear H1.
   assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
@@ -947,8 +947,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    generalize (Mcphi_ok P c (jump i l)); case CFactor.
    intros R1 Q1 HH; rewrite HH; Esimpl.
      intros j M.
-     case_eq ((i ?= j) Eq); intros He; simpl.
-       rewrite (Pcompare_Eq_eq _ _ He).
+     case_eq (i ?= j); intros He; simpl.
+       rewrite (Pos.compare_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));
@@ -987,8 +987,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
      rewrite (ARadd_comm ARth); rsimpl.
      rewrite zmon_pred_ok;rsimpl.
    intros j M1.
-     case_eq ((i ?= j) Eq); intros He; simpl.
-       rewrite (Pcompare_Eq_eq _ _ He).
+     case_eq (i ?= j); intros He; simpl.
+       rewrite (Pos.compare_eq _ _ He).
        generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rewrite mkPX_ok; rsimpl.
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 4fbdcbaa..ab992552 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -229,7 +229,7 @@ Section DEFINITIONS.
 
  (** Specification of the power function *)
  Section POWER.
-  Variable Cpow : Set.
+  Variable Cpow : Type.
   Variable Cp_phi : N -> Cpow.
   Variable rpow : R -> Cpow -> R.
 
@@ -590,6 +590,21 @@ Ltac gen_srewrite Rsth Reqe ARth :=
      | progress rewrite <- (ARopp_mul_l ARth)
      | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ].
 
+Ltac gen_srewrite_sr Rsth Reqe ARth :=
+  repeat first
+     [ gen_reflexivity Rsth
+     | progress rewrite (ARopp_zero Rsth Reqe ARth)
+     | rewrite (ARadd_0_l ARth)
+     | rewrite (ARadd_0_r Rsth ARth)
+     | rewrite (ARmul_1_l ARth)
+     | rewrite (ARmul_1_r Rsth ARth)
+     | rewrite (ARmul_0_l ARth)
+     | rewrite (ARmul_0_r Rsth ARth)
+     | rewrite (ARdistr_l ARth)
+     | rewrite (ARdistr_r Rsth Reqe ARth)
+     | rewrite (ARadd_assoc ARth)
+     | rewrite (ARmul_assoc ARth) ].
+
 Ltac gen_add_push add Rsth Reqe ARth x :=
   repeat (match goal with
   | |- context [add (add ?y x) ?z] =>
diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v
new file mode 100644
index 00000000..fd765471
--- /dev/null
+++ b/plugins/setoid_ring/Rings_Q.v
@@ -0,0 +1,30 @@
+Require Export Cring.
+Require Export Integral_domain.
+
+(* Rational numbers *)
+Require Import QArith.
+
+Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq).
+
+Instance Qri : (Ring (Ro:=Qops)).
+constructor.
+try apply Q_Setoid. 
+apply Qplus_comp. 
+apply Qmult_comp. 
+apply Qminus_comp. 
+apply Qopp_comp.
+ exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc.
+ exact Qmult_1_l.  exact Qmult_1_r. apply Qmult_assoc.
+ apply Qmult_plus_distr_l.  intros. apply Qmult_plus_distr_r. 
+reflexivity. exact Qplus_opp_r.
+Defined.
+
+Instance Qcri: (Cring (Rr:=Qri)).
+red. exact Qmult_comm. Defined.
+
+Lemma Q_one_zero: not (Qeq 1%Q 0%Q).
+unfold Qeq. simpl. auto with *. Qed.
+
+Instance Qdi : (Integral_domain (Rcr:=Qcri)). 
+constructor. 
+exact Qmult_integral. exact Q_one_zero. Defined.
diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v
new file mode 100644
index 00000000..fd219c23
--- /dev/null
+++ b/plugins/setoid_ring/Rings_R.v
@@ -0,0 +1,34 @@
+Require Export Cring.
+Require Export Integral_domain.
+
+(* Real numbers *)
+Require Import Reals.
+Require Import RealField.
+
+Lemma Rsth : Setoid_Theory R (@eq R).
+constructor;red;intros;subst;trivial.
+Qed.
+
+Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)).
+
+Instance Rri : (Ring (Ro:=Rops)).
+constructor;
+try (try apply Rsth;
+   try (unfold respectful, Proper; unfold equality; unfold eq_notation in *;
+  intros; try rewrite H; try rewrite H0; reflexivity)).
+ exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc.
+ exact Rmult_1_l.  exact Rmult_1_r. symmetry. apply Rmult_assoc.
+ exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. 
+exact Rplus_opp_r.
+Defined.
+
+Instance Rcri: (Cring (Rr:=Rri)).
+red. exact Rmult_comm. Defined.
+
+Lemma R_one_zero: 1%R <> 0%R.
+discrR.
+Qed.
+
+Instance Rdi : (Integral_domain (Rcr:=Rcri)). 
+constructor. 
+exact Rmult_integral. exact R_one_zero. Defined.
diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v
new file mode 100644
index 00000000..88904865
--- /dev/null
+++ b/plugins/setoid_ring/Rings_Z.v
@@ -0,0 +1,14 @@
+Require Export Cring.
+Require Export Integral_domain.
+Require Export Ncring_initial.
+
+Instance Zcri: (Cring (Rr:=Zr)).
+red. exact Zmult_comm. Defined.
+
+Lemma Z_one_zero: 1%Z <> 0%Z.
+omega. 
+Qed.
+
+Instance Zdi : (Integral_domain (Rcr:=Zcri)). 
+constructor. 
+exact Zmult_integral. exact Z_one_zero. Defined.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 362542b9..d3ed36ee 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -27,11 +27,7 @@ Ltac isZpow_coef t :=
   | _ => constr:false
   end.
 
-Definition N_of_Z x :=
- match x with
- | Zpos p => Npos p
- | _ => N0
- end.
+Notation N_of_Z := Z.to_N (only parsing).
 
 Ltac Zpow_tac t :=
  match isZpow_coef t with
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index 820246af..9d61c06d 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: newring.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 open Names
@@ -18,8 +16,7 @@ open Closure
 open Environ
 open Libnames
 open Tactics
-open Rawterm
-open Termops
+open Glob_term
 open Tacticals
 open Tacexpr
 open Pcoq
@@ -87,7 +84,7 @@ let interp_map l c =
   with Not_found -> None
 
 let interp_map l t =
-  try Some(List.assoc t l) with Not_found -> None
+  try Some(list_assoc_f eq_constr t l) with Not_found -> None
 
 let protect_maps = ref Stringmap.empty
 let add_map s m = protect_maps := Stringmap.add s m !protect_maps
@@ -98,13 +95,13 @@ let lookup_map map =
 
 let protect_red map env sigma c =
   kl (create_clos_infos betadeltaiota env)
-    (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);;
+    (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
 
 let protect_tac map =
   Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id,InHyp));;
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));;
 
 
 TACTIC EXTEND protect_fv
@@ -144,7 +141,7 @@ let closed_term_ast l =
   let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
   TacFun([Some(id_of_string"t")],
   TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
+  [Genarg.in_gen Genarg.globwit_constr (GVar(dummy_loc,id_of_string"t"),None);
    Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
 (*
 let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
@@ -161,18 +158,18 @@ let ty c = Typing.type_of (Global.env()) Evd.empty c
 let decl_constant na c =
   mkConst(declare_constant (id_of_string na) (DefinitionEntry
     { const_entry_body = c;
+      const_entry_secctx = None;
       const_entry_type = None;
-      const_entry_opaque = true;
-      const_entry_boxed = true},
+      const_entry_opaque = 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))
+  TacArg(dummy_loc,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))
+  TacArg(dummy_loc,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)
@@ -188,8 +185,10 @@ let ltac_record flds =
 let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
 
 let dummy_goal env =
-  {Evd.it = Evd.make_evar (named_context_val env) mkProp;
-   Evd.sigma = Evd.empty}
+  let (gl,_,sigma) = 
+    Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in
+  {Evd.it = gl;
+   Evd.sigma = sigma}
 
 let exec_tactic env n f args =
   let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
@@ -344,7 +343,7 @@ type ring_info =
       ring_pre_tac : glob_tactic_expr;
       ring_post_tac : glob_tactic_expr }
 
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
 
 let from_carrier = ref Cmap.empty
 let from_relation = ref Cmap.empty
@@ -415,7 +414,7 @@ let subst_th (subst,th) =
   let posttac'= subst_tactic subst th.ring_post_tac in
   if c' == th.ring_carrier &&
      eq' == th.ring_req &&
-     set' = th.ring_setoid &&
+     eq_constr set' th.ring_setoid &&
      ext' == th.ring_ext &&
      morph' == th.ring_morph &&
      th' == th.ring_th &&
@@ -440,7 +439,7 @@ let subst_th (subst,th) =
       ring_post_tac = posttac' }
 
 
-let (theory_to_obj, obj_to_theory) =
+let theory_to_obj : ring_info -> obj =
   let cache_th (name,th) = add_entry name th in
   declare_object
     {(default_object "tactic-new-ring-theory") with
@@ -576,13 +575,13 @@ let dest_ring env sigma th_spec =
   let th_typ = Retyping.get_type_of env sigma th_spec in
   match kind_of_term th_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when f = Lazy.force coq_almost_ring_theory ->
+        when eq_constr f (Lazy.force coq_almost_ring_theory) ->
           (None,r,zero,one,add,mul,Some sub,Some opp,req)
     | App(f,[|r;zero;one;add;mul;req|])
-        when f = Lazy.force coq_semi_ring_theory ->
+        when eq_constr f (Lazy.force coq_semi_ring_theory) ->
         (Some true,r,zero,one,add,mul,None,None,req)
     | App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when f = Lazy.force coq_ring_theory ->
+        when eq_constr f (Lazy.force coq_ring_theory) ->
         (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
     | _ -> error "bad ring structure"
 
@@ -592,10 +591,10 @@ let dest_morph env sigma m_spec =
   match kind_of_term m_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req;
               c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-        when f = Lazy.force coq_ring_morph ->
+        when eq_constr f (Lazy.force coq_ring_morph) ->
           (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
     | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
-        when f = Lazy.force coq_semi_morph ->
+        when eq_constr f (Lazy.force coq_semi_morph) ->
         (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
     | _ -> error "bad morphism structure"
 
@@ -626,23 +625,23 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
         (match rk, opp, kind with
             Abstract, None, _ ->
               let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
-              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
+              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
           | Abstract, Some opp, Some _ ->
               let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
-              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
+              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
           | Abstract, Some opp, None ->
               let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in
               TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
+                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
           | Computational _,_,_ ->
               let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
               TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
+                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
           | Morphism mth,_,_ ->
               let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in
               let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
               TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
+                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
 
 let make_hyp env c =
   let t = Retyping.get_type_of env Evd.empty c in
@@ -659,7 +658,7 @@ let interp_power env pow =
   match pow with
   | None ->
       let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
-      (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+      (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
   | Some (tac, spec) ->
       let tac =
         match tac with
@@ -832,7 +831,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl =
 
 TACTIC EXTEND ring_lookup
 | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
-    [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t]
+    [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t]
 END
 
 
@@ -893,18 +892,18 @@ let dest_field env sigma th_spec =
   let th_typ = Retyping.get_type_of env sigma th_spec in
   match kind_of_term th_typ with
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when f = Lazy.force afield_theory ->
+        when eq_constr f (Lazy.force afield_theory) ->
         let rth = lapp af_ar
           [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when f = Lazy.force field_theory ->
+        when eq_constr f (Lazy.force field_theory) ->
         let rth =
           lapp f_r
             [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;div;inv;req|])
-        when f = Lazy.force sfield_theory ->
+        when eq_constr f (Lazy.force sfield_theory) ->
         let rth = lapp sf_sr
           [|r;zero;one;add;mul;div;inv;req;th_spec|] in
         (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
@@ -1016,7 +1015,7 @@ let subst_th (subst,th) =
       field_pre_tac = pretac';
       field_post_tac = posttac' }
 
-let (ftheory_to_obj, obj_to_ftheory) =
+let ftheory_to_obj : field_info -> obj =
   let cache_th (name,th) = add_field_entry name th in
   declare_object
     {(default_object "tactic-new-field-theory") with
@@ -1160,5 +1159,5 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl =
 
 TACTIC EXTEND field_lookup
 | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
-      [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ]
+      [ let (t,l) = list_sep_last lt in field_lookup f lH l t ]
 END
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
index 6934375b..580df9b5 100644
--- a/plugins/setoid_ring/vo.itarget
+++ b/plugins/setoid_ring/vo.itarget
@@ -13,3 +13,13 @@ Ring_tac.vo
 Ring_theory.vo
 Ring.vo
 ZArithRing.vo
+Algebra_syntax.vo
+Cring.vo
+Ncring.vo
+Ncring_polynom.vo
+Ncring_initial.vo
+Ncring_tac.vo
+Rings_Z.vo
+Rings_R.vo
+Rings_Q.vo
+Integral_domain.vo
\ No newline at end of file
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
index 3fb6824b..5ed335d0 100644
--- a/plugins/subtac/eterm.ml
+++ b/plugins/subtac/eterm.ml
@@ -1,4 +1,3 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (**
    - Get types of existentials ;
    - Flatten dependency tree (prefix order) ;
@@ -28,11 +27,15 @@ type oblinfo =
     ev_hyps: named_context;
     ev_status: obligation_definition_status;
     ev_chop: int option;
-    ev_source: hole_kind located;
+    ev_src: hole_kind located;
     ev_typ: types;
     ev_tac: tactic option;
     ev_deps: Intset.t }
 
+(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *)
+open Store.Field
+let evar_tactic = Store.field ()
+
 (** Substitute evar references in t using De Bruijn indices,
   where n binders were passed through. *)
 
@@ -210,7 +213,7 @@ let eterm_obligations env name isevars evm fs ?status t ty =
 	   | Some s -> s, None
 	   | None -> Define true, None
 	 in
-	 let tac = match ev.evar_extra with
+	 let tac = match evar_tactic.get ev.evar_extra with
 	   | Some t ->
 	       if Dyn.tag t = "tactic" then
 		 Some (Tacinterp.interp 
@@ -218,9 +221,9 @@ let eterm_obligations env name isevars evm fs ?status t ty =
 	       else None
 	   | None -> None
 	 in
-	 let info = { ev_name = (n, nstr); ev_hyps = hyps; 
-		      ev_status = status; ev_chop = chop;
-		      ev_source = (loc, k); ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
+	 let info = { ev_name = (n, nstr);
+		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
+		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
 	 in (id, info) :: l)
       evn []
   in
@@ -231,12 +234,12 @@ let eterm_obligations env name isevars evm fs ?status t ty =
   let evars = 
     List.map (fun (ev, info) ->
       let { ev_name = (_, name); ev_status = status;
-	    ev_source = source; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
+	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
       in
       let status = match status with
 	| Define true when Idset.mem name transparent -> Define false
 	| _ -> status
-      in name, typ, source, status, deps, tac) evts
+      in name, typ, src, status, deps, tac) evts
   in
   let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
   let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
index b4bbe3d5..03d76f29 100644
--- a/plugins/subtac/eterm.mli
+++ b/plugins/subtac/eterm.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eterm.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
 open Environ
 open Tacmach
 open Term
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
index ce6d12be..ca1240e5 100644
--- a/plugins/subtac/g_subtac.ml4
+++ b/plugins/subtac/g_subtac.ml4
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i camlp4deps: "parsing/grammar.cma" 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 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 
 open Flags
 open Util
@@ -37,14 +33,14 @@ module Tactic = Pcoq.Tactic
 
 module SubtacGram =
 struct
-  let gec s = Gram.Entry.create ("Subtac."^s)
+  let gec s = Gram.entry_create ("Subtac."^s)
 		(* types *)
-  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
+  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc"
 
-  let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac"
+  let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac"
 end
 
-open Rawterm
+open Glob_term
 open SubtacGram
 open Util
 open Pcoq
@@ -94,7 +90,7 @@ VERNAC COMMAND EXTEND Subtac
 
 let try_catch_exn f e =
   try f e
-  with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn)
+  with exn -> errorlabstrm "Program" (Errors.print exn)
 
 let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
 let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
index 95cacc38..710149ae 100644
--- a/plugins/subtac/subtac.ml
+++ b/plugins/subtac/subtac.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Global
 open Pp
 open Util
@@ -27,7 +26,7 @@ open List
 open Recordops
 open Evarutil
 open Pretype_errors
-open Rawterm
+open Glob_term
 open Evarconv
 open Pattern
 open Vernacexpr
@@ -50,7 +49,7 @@ open Tacinterp
 open Tacexpr
 
 let solve_tccs_in_type env id isevars evm c typ =
-  if not (evm = Evd.empty) then
+  if not (Evd.is_empty evm) then
     let stmt_id = Nameops.add_suffix id "_stmt" in
     let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
       match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with
@@ -89,7 +88,7 @@ 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 _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
 
 let assumption_message id =
   Flags.if_verbose message ((string_of_id id) ^ " is assumed")
@@ -142,12 +141,12 @@ let subtac (loc, command) =
 	    (fun _ _ -> ())
       | DefineBody (bl, _, c, tycon) ->
 	  ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
-  | VernacFixpoint (l, b) ->
+  | VernacFixpoint l ->
       List.iter (fun ((lid, _, _, _, _), _) ->
 	check_fresh lid;
 	Dumpglob.dump_definition lid false "fix") l;
       let _ = trace (str "Building fixpoint") in
-	ignore(Subtac_command.build_recursive l b)
+	ignore(Subtac_command.build_recursive l)
 
   | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) ->
       if guard <> None then 
@@ -172,10 +171,10 @@ let subtac (loc, command) =
 	error "Declare Instance not supported here.";
       ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
 
-  | VernacCoFixpoint (l, b) ->
+  | VernacCoFixpoint l ->
       if Dumpglob.dump () then
 	List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l;
-      ignore(Subtac_command.build_corecursive l b)
+      ignore(Subtac_command.build_corecursive l)
 
   (*| VernacEndProof e ->
     subtac_end_proof e*)
@@ -219,6 +218,11 @@ let subtac (loc, command) =
 
   | Type_errors.TypeError (env, exn) as e -> raise e
 
-  | Pretype_errors.PretypeError (env, exn) as e -> raise e
+  | Pretype_errors.PretypeError (env, _, exn) as e -> raise e
+
+  | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
+     Loc.Exc_located (loc, e') as e) -> raise e
 
-  | e -> raise e
+  | e -> 
+      (*       msg_warning (str "Uncaught exception: " ++ Errors.print e); *)
+      raise e
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
index 25aec39c..368d8bac 100644
--- a/plugins/subtac/subtac_cases.ml
+++ b/plugins/subtac/subtac_cases.ml
@@ -1,14 +1,11 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_cases.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Cases
 open Util
 open Names
@@ -23,7 +20,7 @@ open Sign
 open Reductionops
 open Typeops
 open Type_errors
-open Rawterm
+open Glob_term
 open Retyping
 open Pretype_errors
 open Evarutil
@@ -89,7 +86,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
 type rhs =
     { rhs_env    : env;
       avoid_ids  : identifier list;
-      it         : rawconstr;
+      it         : glob_constr;
     }
 
 type equation =
@@ -158,22 +155,22 @@ let feed_history arg = function
 
 (* This is for non exhaustive error message *)
 
-let rec rawpattern_of_partial_history args2 = function
+let rec glob_pattern_of_partial_history args2 = function
   | Continuation (n, args1, h) ->
       let args3 = make_anonymous_patvars (n - (List.length args2)) in
-      build_rawpattern (List.rev_append args1 (args2@args3)) h
+      build_glob_pattern (List.rev_append args1 (args2@args3)) h
   | Result pl -> pl
 
-and build_rawpattern args = function
+and build_glob_pattern args = function
   | Top -> args
   | MakeAlias (AliasLeaf, rh) ->
       assert (args = []);
-      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+      glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
   | MakeAlias (AliasConstructor pci, rh) ->
-      rawpattern_of_partial_history
+      glob_pattern_of_partial_history
 	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
 
-let complete_history = rawpattern_of_partial_history []
+let complete_history = glob_pattern_of_partial_history []
 
 (* This is to build glued pattern-matching history and alias bodies *)
 
@@ -237,7 +234,7 @@ type pattern_matching_problem =
       mat      : matrix;
       caseloc  : loc;
       casestyle: case_style;
-      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+      typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment }
 
 (*--------------------------------------------------------------------------*
  * A few functions to infer the inductive type from the patterns instead of *
@@ -369,10 +366,10 @@ let find_tomatch_tycon isevars env loc = function
   | None -> empty_tycon
 
 let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
-  let loc = Some (loc_of_rawconstr tomatch) in
+  let loc = Some (loc_of_glob_constr tomatch) in
   let tycon = find_tomatch_tycon isevars env loc indopt in
   let j = typing_fun tycon env tomatch in
-  let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in
+  let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !isevars j in
   isevars := evd;
   let typ = nf_evar ( !isevars) j.uj_type in
   let t =
@@ -530,7 +527,7 @@ let extract_rhs pb =
 let occur_in_rhs na rhs =
   match na with
     | Anonymous -> false
-    | Name id -> occur_rawconstr id rhs.it
+    | Name id -> occur_glob_constr id rhs.it
 
 let is_dep_patt eqn = function
   | PatVar (_,name) -> occur_in_rhs name eqn.rhs
@@ -604,7 +601,7 @@ let regeneralize_index_tomatch n =
   genrec 0
 
 let rec replace_term n c k t =
-  if t = mkRel (n+k) then lift k c
+  if isRel t && destRel t = n+k then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
 let replace_tomatch n c =
@@ -1518,7 +1515,7 @@ let mk_JMeq typ x typ' y =
   mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
 let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |])
 
-let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
+let hole = GHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
 
 let constr_of_pat env isevars arsign pat avoid =
   let rec typ env (ty, realargs) pat avoid =
@@ -1534,7 +1531,7 @@ let constr_of_pat env isevars arsign pat avoid =
     | PatCstr (l,((_, i) as cstr),args,alias) ->
 	let cind = inductive_of_constructor cstr in
 	let IndType (indf, _) = 
-	  try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) 
+	  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
@@ -1548,7 +1545,7 @@ let constr_of_pat env isevars arsign pat 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
+		 typ env (substl args (liftn (List.length sign) (succ (List.length args)) t), []) ua avoid
 	       in
 	       let args' = arg' :: List.map (lift n') args in
 	       let env' = push_rels sign' env in
@@ -1607,12 +1604,12 @@ let vars_of_ctx ctx =
       match b with
 	| Some t' when kind_of_term t' = Rel 0 ->
 	    prev,
-	    (RApp (dummy_loc,
-		(RRef (dummy_loc, delayed_force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
+	    (GApp (dummy_loc,
+		(GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars
 	| _ ->
 	    match na with
 		Anonymous -> raise (Invalid_argument "vars_of_ctx")
-	      | Name n -> n, RVar (dummy_loc, n) :: vars)
+	      | Name n -> n, GVar (dummy_loc, n) :: vars)
       ctx (id_of_string "vars_of_ctx_error", [])
   in List.rev y
 
@@ -1744,13 +1741,13 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
 	 let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in
 	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
 	 let branch =
-	   let bref = RVar (dummy_loc, branch_name) in
+	   let bref = GVar (dummy_loc, branch_name) in
 	     match vars_of_ctx rhs_rels with
 		 [] -> bref
-	       | l -> RApp (dummy_loc, bref, l)
+	       | l -> GApp (dummy_loc, bref, l)
 	 in
 	 let branch = match ineqs with
-	     Some _ -> RApp (dummy_loc, branch, [ hole ])
+	     Some _ -> GApp (dummy_loc, branch, [ hole ])
 	   | None -> branch
 	 in
 	 incr i;
@@ -1786,7 +1783,7 @@ let abstract_tomatch env tomatchs tycon =
 	     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
+		 (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
 	       let name = next_ident_away (id_of_string "filtered_var") names in
 		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
 	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
index bc2b2bb7..77537d33 100644
--- a/plugins/subtac/subtac_cases.mli
+++ b/plugins/subtac/subtac_cases.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtac_cases.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Util
 open Names
@@ -15,7 +13,7 @@ open Term
 open Evd
 open Environ
 open Inductiveops
-open Rawterm
+open Glob_term
 open Evarutil
 (*i*)
 
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
index 960bf162..c08dd16d 100644
--- a/plugins/subtac/subtac_classes.ml
+++ b/plugins/subtac/subtac_classes.ml
@@ -1,19 +1,16 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtac_classes.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pretyping
 open Evd
 open Environ
 open Term
-open Rawterm
+open Glob_term
 open Topconstr
 open Names
 open Libnames
@@ -23,24 +20,28 @@ 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 =
+let interp_constr_evars_gen evdref env ?(impls=Constrintern.empty_internalization_env) kind c =
   SPretyping.understand_tcc_evars evdref env kind
-    (intern_gen (kind=IsType) ~impls ( !evdref) env c)
+    (intern_gen (kind=IsType) ~impls !evdref env c)
 
-let interp_casted_constr_evars evdref env ?(impls=[]) c typ =
+let interp_casted_constr_evars evdref env ?(impls=Constrintern.empty_internalization_env) c typ =
   interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
 
 let interp_context_evars evdref env params =
-  Constrintern.interp_context_gen
+  let impls_env, bl = Constrintern.interp_context_gen
     (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
-    (SPretyping.understand_judgment_tcc evdref) !evdref env params
+    (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl
+
+let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c =
+  let c = intern_gen true ~impls !evdref env c in
+  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
+    SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps
 
 let type_ctx_instance evars env ctx inst subst =
   let rec aux (subst, instctx) l = function
@@ -113,11 +114,12 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p
   let subst = List.map (Evarutil.nf_evar sigma) subst in
   let props =
     match props with
-    | CRecord (loc, _, fs) ->
+    | Some (CRecord (loc, _, fs)) ->
 	if List.length fs > List.length k.cl_props then
 	  Classes.mismatched_props env' (List.map snd fs) k.cl_props;
 	Inl fs
-    | _ -> Inr props
+    | Some p -> Inr p
+    | None -> Inl []
   in
   let subst =
     match props with
@@ -138,7 +140,11 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p
 		  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);
+		    List.iter 
+		      (fun (n, _, x) -> 
+			 if n = Name mid then
+			   Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
+		      k.cl_projs;
 		    c :: props, rest'
 		with Not_found ->
 		  (CHole (Util.dummy_loc, None) :: props), rest
@@ -173,10 +179,9 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p
   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
+      Typeclasses.declare_instance pri (not global) (ConstRef cst)
   in
   let evm = Subtac_utils.evars_of_term !evars Evd.empty term in
   let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in
-    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,false,Instance) ~hook obls
+    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,Instance) ~hook obls
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
index 73ca5581..5b5c0203 100644
--- a/plugins/subtac/subtac_classes.mli
+++ b/plugins/subtac/subtac_classes.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtac_classes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Decl_kinds
@@ -35,7 +33,7 @@ val new_instance :
   ?global:bool ->
   local_binder list ->
   typeclass_constraint ->
-  constr_expr ->
+  constr_expr option ->
   ?generalize:bool ->
   int option ->
   identifier * Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
index bdebdf85..74f31a90 100644
--- a/plugins/subtac/subtac_coercion.ml
+++ b/plugins/subtac/subtac_coercion.ml
@@ -1,13 +1,10 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: subtac_coercion.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
@@ -144,7 +141,7 @@ module Coercion = struct
 		let restargs = lift_args 1
 		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
 		in
-		let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in
+		let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
 		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
 		let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in
 		let evar = make_existential loc env isevars eq in
@@ -205,7 +202,7 @@ module Coercion = struct
 				 | Lambda (n, t, t') -> c, t'
 				     (*| Prod (n, t, t') -> t'*)
 				 | Evar (k, args) ->
-				     let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in
+				     let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in
 				       isevars := evs;
 				       let (n, dom, rng) = destLambda t in
 				       let (domk, args) = destEvar dom in
@@ -330,8 +327,8 @@ module Coercion = struct
   let apply_pattern_coercion loc pat p =
     List.fold_left
       (fun pat (co,n) ->
-	 let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
-	   Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+	 let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
+	   Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
       pat p
 
   (* raise Not_found if no coercion found *)
@@ -411,10 +408,10 @@ module Coercion = struct
     else
     let v', t' =
       try
-	let t2,t1,p = lookup_path_between env ( evd) (t,c1) in
+	let t2,t1,p = lookup_path_between env evd (t,c1) in
 	  match v with
 	      Some v ->
-		let j = apply_coercion env ( evd) p
+		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
@@ -430,8 +427,8 @@ module Coercion = struct
     try inh_coerce_to_fail env evd rigidonly v t c1
     with NoCoercion ->
     match
-      kind_of_term (whd_betadeltaiota env ( evd) t),
-      kind_of_term (whd_betadeltaiota env ( evd) c1)
+      kind_of_term (whd_betadeltaiota env evd t),
+      kind_of_term (whd_betadeltaiota env evd c1)
     with
     | Prod (name,t1,t2), Prod (_,u1,u2) ->
         (* Conversion did not work, we may succeed with a coercion. *)
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
index a83611a4..ecae6759 100644
--- a/plugins/subtac/subtac_command.ml
+++ b/plugins/subtac/subtac_command.ml
@@ -6,7 +6,7 @@ open Libobject
 open Pattern
 open Matching
 open Pp
-open Rawterm
+open Glob_term
 open Sign
 open Tacred
 open Util
@@ -21,7 +21,6 @@ open Tacmach
 open Tactic_debug
 open Topconstr
 open Term
-open Termops
 open Tacexpr
 open Safe_typing
 open Typing
@@ -53,7 +52,7 @@ let evar_nf isevars c =
   Evarutil.nf_evar !isevars c
 
 let interp_gen kind isevars env
-               ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
+               ?(impls=Constrintern.empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
   let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in
   let c' = SPretyping.understand_tcc_evars isevars env kind c' in
@@ -62,13 +61,13 @@ let interp_gen kind isevars env
 let interp_constr isevars env c =
   interp_gen (OfType None) isevars env c
 
-let interp_type_evars isevars env ?(impls=[]) c =
+let interp_type_evars isevars env ?(impls=Constrintern.empty_internalization_env) c =
   interp_gen IsType isevars env ~impls c
 
-let interp_casted_constr isevars env ?(impls=[]) c typ =
+let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
   interp_gen (OfType (Some typ)) isevars env ~impls c
 
-let interp_casted_constr_evars isevars env ?(impls=[]) c typ =
+let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
   interp_gen (OfType (Some typ)) isevars env ~impls c
 
 let interp_open_constr isevars env c =
@@ -85,25 +84,25 @@ let interp_constr_judgment isevars env c =
     { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
 
 let locate_if_isevar loc na = function
-  | RHole _ ->
+  | GHole _ ->
       (try match na with
-	| Name id ->  Reserve.find_reserved_type id
+	| Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id)
 	| Anonymous -> raise Not_found
-      with Not_found -> RHole (loc, Evd.BinderType na))
+      with Not_found -> GHole (loc, Evd.BinderType na))
   | x -> x
 
 let interp_binder sigma env na t =
   let t = Constrintern.intern_gen true ( !sigma) env t in
-    SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t)
+    SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_glob_constr t) na t)
 
 let interp_context_evars evdref env params =
-  let bl = Constrintern.intern_context false ( !evdref) env params in
+  let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_env params in
   let (env, par, _, impls) =
     List.fold_left
       (fun (env,params,n,impls) (na, k, b, t) ->
 	match b with
 	    None ->
-	      let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+	      let t' = locate_if_isevar (loc_of_glob_constr t) na t in
 	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
 	      let d = (na,None,t) in
 	      let impls =
@@ -133,7 +132,7 @@ let collect_non_rec env =
       let i =
         list_try_find_i
           (fun i f ->
-             if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
+             if List.for_all (fun (_, def) -> not (Termops.occur_var env f def)) ldefrec
              then i else failwith "try_find_i")
           0 lnamerec
       in
@@ -184,11 +183,11 @@ 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_cstr_ndecls = [|2|];
     ci_pp_info   =  { ind_nargs = 0; style = LetStyle }
   }
 
-let telescope = function
+let rec telescope = function
   | [] -> assert false
   | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
   | (n, None, t) :: tl ->
@@ -209,13 +208,14 @@ let telescope = function
 	(List.rev tys) tl (mkRel 1, [])
       in ty, ((n, Some last, t) :: subst), constr
 
-  | _ -> raise (Invalid_argument "telescope")
+  | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in
+      ty, ((n, Some b, t) :: subst), lift 1 term
 
 let nf_evar_context isevars ctx =
   List.map (fun (n, b, t) ->
     (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx
 
-let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
+let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
   Coqlib.check_required_library ["Coq";"Program";"Wf"];
   let sigma = Evd.empty in
   let isevars = ref (Evd.create_evar_defs sigma) in
@@ -300,11 +300,11 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
       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
-    interp_casted_constr isevars ~impls:newimpls
-      (push_rel_context ctx env) body (lift 1 top_arity)
+    let newimpls = Idmap.singleton recname
+      (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))],
+       scopes @ [None]) in
+      interp_casted_constr isevars ~impls:newimpls
+	(push_rel_context ctx env) body (lift 1 top_arity)
   in
   let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
   let prop = mkLambda (Name argname, argtyp, top_arity_let) in
@@ -325,10 +325,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
 	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_body = Evarutil.nf_evar !isevars body;
+            const_entry_secctx = None;
 	    const_entry_type = Some ty;
-	    const_entry_opaque = false;
-	    const_entry_boxed = false} 
+	    const_entry_opaque = false }
 	in 
 	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
 	let gr = ConstRef c in
@@ -417,7 +417,7 @@ let out_def = function
   | Some def -> def
   | None -> error "Program Fixpoint needs defined bodies."
 
-let interp_recursive fixkind l boxed =
+let interp_recursive fixkind l =
   let env = Global.env() in
   let fixl, ntnl = List.split l in
   let kind = fixkind <> IsCoFixpoint in
@@ -506,7 +506,7 @@ let out_n = function
     Some n -> n
   | None -> raise Not_found
 
-let build_recursive l b =
+let build_recursive l =
   let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
     match g, l with
 	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
@@ -514,24 +514,24 @@ let build_recursive l b =
 		    (match n with Some n -> mkIdentC (snd n) | None ->
 		      errorlabstrm "Subtac_command.build_recursive"
 			(str "Recursive argument required for well-founded fixpoints"))
-		    ntn false)
+		    ntn)
 
       | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
 	  ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r)
-		    m ntn false)
+		    m ntn)
 
       | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
 	  let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) ->
 	    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n;
 	      Command.fix_body = def; Command.fix_type = typ},ntn)) l
-	  in interp_recursive (IsFixpoint g) fixl b
+	  in interp_recursive (IsFixpoint g) fixl
       | _, _ ->
 	  errorlabstrm "Subtac_command.build_recursive"
 	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
 
-let build_corecursive l b =
+let build_corecursive l =
   let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
     ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None;
       Command.fix_body = def; Command.fix_type = typ},ntn))
     l in
-  interp_recursive IsCoFixpoint fixl b
+  interp_recursive IsCoFixpoint fixl
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
index 0f24915e..72549a01 100644
--- a/plugins/subtac/subtac_command.mli
+++ b/plugins/subtac/subtac_command.mli
@@ -43,7 +43,7 @@ val interp_binder :     Evd.evar_map ref ->
 
 
 val telescope :
-  (Names.name * 'a option * Term.types) list ->
+  (Names.name * Term.types option * Term.types) list ->
   Term.types * (Names.name * Term.types option * Term.types) list *
     Term.constr
 
@@ -51,10 +51,10 @@ 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
+           Topconstr.constr_expr -> 'b -> Subtac_obligations.progress
 
 val build_recursive :
-  (fixpoint_expr * decl_notation list) list -> bool -> unit
+  (fixpoint_expr * decl_notation list) list -> unit
 
 val build_corecursive :
-  (cofixpoint_expr * decl_notation list) list -> bool -> unit
+  (cofixpoint_expr * decl_notation list) list -> unit
diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
index d3a63410..64d9f72c 100644
--- a/plugins/subtac/subtac_obligations.ml
+++ b/plugins/subtac/subtac_obligations.ml
@@ -1,4 +1,3 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 open Printf
 open Pp
 open Subtac_utils
@@ -16,6 +15,7 @@ open Util
 open Evd
 open Declare
 open Proof_type
+open Compat
 
 let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
 let pperror cmd = Util.errorlabstrm "Program" cmd
@@ -30,13 +30,13 @@ let explain_no_obligations = function
     Some ident -> str "No obligations for program " ++ str (string_of_id ident)
   | None -> str "No obligations remaining"
 
-type obligation_info = (Names.identifier * Term.types * hole_kind located * 
+type obligation_info = (Names.identifier * Term.types * hole_kind located *
 			  obligation_definition_status * Intset.t * tactic option) array
 
 type obligation =
   { obl_name : identifier;
     obl_type : types;
-    obl_source : hole_kind located;
+    obl_location : hole_kind located;
     obl_body : constr option;
     obl_status : obligation_definition_status;
     obl_deps : Intset.t;
@@ -82,11 +82,29 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "transparency of Program obligations";
       optkey   = ["Transparent";"Obligations"];
       optread  = get_proofs_transparency;
       optwrite = set_proofs_transparency; }
 
+(* true = hide obligations *)
+let hide_obligations = ref false
+
+let set_hide_obligations = (:=) hide_obligations
+let get_hide_obligations () = !hide_obligations
+
+open Goptions
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Hidding of Program obligations";
+      optkey   = ["Hide";"Obligations"];
+      optread  = get_hide_obligations;
+      optwrite = set_hide_obligations; }
+
 let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
 
 let get_obligation_body expand obl =
@@ -97,18 +115,54 @@ let get_obligation_body expand obl =
       | _ -> c
     else c
 
+let obl_substitution expand obls deps =
+  Intset.fold
+    (fun x acc ->
+       let xobl = obls.(x) in
+       let oblb =
+	 try get_obligation_body expand xobl
+	 with _ -> assert(false)
+       in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
+    deps []
+
 let subst_deps expand obls deps t =
-  let subst =
-    Intset.fold
-      (fun x acc ->
-	let xobl = obls.(x) in
-	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 = obl_substitution expand obls deps in
+    Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t
+
+let rec prod_app t n =
+  match kind_of_term (strip_outer_cast t) with
+    | Prod (_,_,b) -> subst1 n b
+    | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
+    | _ ->
+	errorlabstrm "prod_app"
+	  (str"Needed a product, but didn't find one" ++ fnl ())
+
+
+(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
+let prod_applist t nL = List.fold_left prod_app t nL
+
+let replace_appvars subst =
+  let rec aux c = 
+    let f, l = decompose_app c in
+      if isVar f then
+	try
+	  let c' = List.map (map_constr aux) l in
+	  let (t, b) = List.assoc (destVar f) subst in
+	    mkApp (delayed_force hide_obligation, 
+		   [| prod_applist t c'; applistc b c' |])
+	with Not_found -> map_constr aux c
+      else map_constr aux c
+  in map_constr aux
+       
+let subst_prog expand obls ints prg =
+  let subst = obl_substitution expand obls ints in
+    if get_hide_obligations () then
+      (replace_appvars subst prg.prg_body,
+       replace_appvars subst (Termops.refresh_universes prg.prg_type))
+    else 
+      let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
+	(Term.replace_vars subst' prg.prg_body,
+	 Term.replace_vars subst' (Termops.refresh_universes prg.prg_type))
 
 let subst_deps_obl obls obl =
   let t' = subst_deps true obls obl.obl_deps obl.obl_type in
@@ -153,20 +207,32 @@ let _ =
 
 let progmap_union = ProgMap.fold ProgMap.add
 
-let (input,output) =
+let close sec =
+  if not (ProgMap.is_empty !from_prg) then
+    let keys = map_keys !from_prg in
+      errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
+			      prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
+			      (str (if List.length keys = 1 then " has " else "have ") ++
+			       str "unsolved obligations"))
+
+let input : program_info ProgMap.t -> obj =
   declare_object
     { (default_object "Program state") with
-      classify_function = (fun () ->
-	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));
-	Dispose) }
+      cache_function = (fun (na, pi) -> from_prg := pi);
+      load_function = (fun _ (_, pi) -> from_prg := pi);
+      discharge_function = (fun _ -> close "section"; None);
+      classify_function = (fun _ -> close "module"; Dispose) }
     
 open Evd
 
 let progmap_remove prg =
-  from_prg := ProgMap.remove prg.prg_name !from_prg
+  Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
+  
+let progmap_add n prg =
+  Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
+
+let progmap_replace prg' = 
+  Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
 
 let rec intset_to = function
     -1 -> Intset.empty
@@ -175,21 +241,16 @@ let rec intset_to = function
 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)
+    subst_prog expand obls ints prg
 
 let declare_definition prg =
   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()) prg.prg_type);
-     with _ -> ());
-  let (local, boxed, kind) = prg.prg_kind in
+  let (local, kind) = prg.prg_kind in
   let ce =
     { const_entry_body = body;
+      const_entry_secctx = None;
       const_entry_type = Some typ;
-      const_entry_opaque = false;
-      const_entry_boxed = boxed}
+      const_entry_opaque = false }
   in
     (Command.get_declare_definition_hook ()) ce;
     match local with
@@ -207,7 +268,7 @@ let declare_definition prg =
     | (Global|Local) ->
 	let c =
 	  Declare.declare_constant
-	    prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind))
+	    prg.prg_name (DefinitionEntry ce,IsDefinition (snd prg.prg_kind))
 	in
 	let gr = ConstRef c in
 	  if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
@@ -255,7 +316,7 @@ let declare_mutual_definition l =
   let fixkind = Option.get first.prg_fixkind in
   let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
   let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
-  let (local,boxed,kind) = first.prg_kind in
+  let (local,kind) = first.prg_kind in
   let fixnames = first.prg_deps in
   let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
   let indexes, fixdecls =
@@ -269,7 +330,7 @@ let declare_mutual_definition l =
 	  None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
   in
   (* Declare the recursive definitions *)
-  let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in
+  let kns = list_map4 (declare_fix kind) fixnames fixdecls fixtypes fiximps in
     (* Declare notations *)
     List.iter Metasyntax.add_notation_interpretation first.prg_notations;
     Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
@@ -287,9 +348,9 @@ let declare_obligation prg obl body =
       let opaque = if get_proofs_transparency () then false else opaque in
       let ce = 
 	{ const_entry_body = body;
+          const_entry_secctx = None;
 	  const_entry_type = Some ty;
-	  const_entry_opaque = opaque;
-	  const_entry_boxed = false} 
+	  const_entry_opaque = opaque }
       in
       let constant = Declare.declare_constant obl.obl_name
 	(DefinitionEntry ce,IsProof Property)
@@ -307,14 +368,14 @@ let init_prog_info n b t deps fixkind notations obls impls kind reduce hook =
 	assert(obls = [||]);
 	let n = Nameops.add_suffix n "_obligation" in
 	  [| { obl_name = n; obl_body = None;
-	       obl_source = (dummy_loc, QuestionMark Expand); obl_type = t;
+	       obl_location = dummy_loc, InternalHole; obl_type = t;
 	       obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |],
 	mkVar n
     | Some b ->
 	Array.mapi
 	  (fun i (n, t, l, o, d, tac) ->
             { obl_name = n ; obl_body = None; 
-	      obl_source = l; obl_type = reduce t; obl_status = o;
+	      obl_location = l; obl_type = reduce t; obl_status = o;
 	      obl_deps = d; obl_tac = tac })
 	  obls, b
   in
@@ -359,7 +420,7 @@ let obligations_message 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; 
+    progmap_replace prg';
     obligations_message rem;
     if rem > 0 then Remain rem
     else (
@@ -437,7 +498,7 @@ let rec solve_obligation prg num tac =
 		let obls = Array.copy obls in
 		let _ = obls.(num) <- obl in
 		let res = try update_obls prg obls (pred rem)
-		  with e -> pperror (Cerrors.explain_exn e)
+		  with e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e))
 		in
 		  match res with
 		  | Remain n when n > 0 ->
@@ -485,10 +546,11 @@ and solve_obligation_by_tac prg obls i tac =
 	      true
 	  else false
 	with
-	| Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	| Stdpp.Exc_located(_, Refiner.FailError (_, s))
+	| Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
+	| Loc.Exc_located(_, Refiner.FailError (_, s))
 	| Refiner.FailError (_, s) ->
-	    user_err_loc (fst obl.obl_source, "solve_obligation", Lazy.force s)
+	    user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
+	| Util.Anomaly _ as e -> raise e
 	| e -> false
 
 and solve_prg_obligations prg tac =
@@ -556,7 +618,7 @@ 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 ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
+let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic
     ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls =
   Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
   let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in
@@ -568,23 +630,20 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?ta
   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;
+      progmap_add n prg;
       let res = auto_solve_obligations (Some n) tactic in
 	match res with
 	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
 	| _ -> res)
 
-let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) 
+let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce)
     ?(hook=fun _ _ -> ()) notations fixkind =
   let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
-  let upd = List.fold_left
-      (fun acc (n, b, t, imps, obls) ->
-	let prg = init_prog_info n (Some b) t deps (Some fixkind) 
-	  notations obls imps kind reduce hook 
-	in ProgMap.add n prg acc)
-      !from_prg l
-  in
-    from_prg := upd;
+    List.iter
+    (fun  (n, b, t, imps, obls) ->
+     let prg = init_prog_info n (Some b) t deps (Some fixkind) 
+       notations obls imps kind reduce hook 
+     in progmap_add n prg) l;
     let _defined =
       List.fold_left (fun finished x ->
 	if finished then finished
@@ -604,8 +663,8 @@ let admit_obligations n =
 	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) 
+	    let kn = Declare.declare_constant x.obl_name 
+              (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural)
 	    in
 	      assumption_message x.obl_name;
 	      obls.(i) <- { x with obl_body = Some (mkConst kn) }
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
index 5f6d1a2e..c1d665aa 100644
--- a/plugins/subtac/subtac_obligations.mli
+++ b/plugins/subtac/subtac_obligations.mli
@@ -8,7 +8,7 @@ open Vernacexpr
 type obligation_info =
   (identifier * Term.types * hole_kind located *
       obligation_definition_status * Intset.t * tactic option) array
-    (* ident, type, source, (opaque or transparent, expand or define),
+    (* ident, type, location, (opaque or transparent, expand or define),
        dependencies, tactic to solve it *)
 
 type progress = (* Resolution status of a program *)
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
index 9de7ddf2..7c0d1232 100644
--- a/plugins/subtac/subtac_pretyping.ml
+++ b/plugins/subtac/subtac_pretyping.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Global
 open Pp
 open Util
@@ -26,7 +24,7 @@ open List
 open Recordops
 open Evarutil
 open Pretype_errors
-open Rawterm
+open Glob_term
 open Evarconv
 open Pattern
 
@@ -60,13 +58,10 @@ let my_print_rec_info env t =
   str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
   str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
   str "Full type: " ++ my_print_constr env t.f_fulltype
-(*   trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *)
+(*   trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *)
 (* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
 (* 	   str " in environment: " ++ my_print_env env); *)
 
-let merge_evms x y =
-  Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
-
 let interp env isevars c tycon =
   let j = pretype tycon env isevars ([],[]) c in
   let _ = isevars := Evarutil.nf_evar_map !isevars in
@@ -86,9 +81,9 @@ let find_with_index x l =
 
 open Vernacexpr
 
-let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = 
+let coqintern_constr evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
   Constrintern.intern_constr evd env
-let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = 
+let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
   Constrintern.intern_type evd env
 
 let env_with_binders env isevars l =
@@ -119,14 +114,14 @@ let subtac_process ?(is_type=false) env isevars id bl c tycon =
       | Some t ->
 	  let t = Topconstr.prod_constr_expr t bl in
 	  let t = coqintern_type !isevars env t in
-	  let imps = Implicit_quantifiers.implicits_of_rawterm t in
+	  let imps = Implicit_quantifiers.implicits_of_glob_constr t in
 	  let coqt, ttyp = interp env isevars t empty_tycon in
 	    mk_tycon coqt, Some imps
   in
   let c = coqintern_constr !isevars env c in
   let imps = match imps with 
     | Some i -> i
-    | None -> Implicit_quantifiers.implicits_of_rawterm ~with_products:is_type c
+    | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type c
   in
   let coqc, ctyp = interp env isevars c tycon in
   let evm = non_instanciated_map env isevars !isevars in
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
index 48906b23..fa767790 100644
--- a/plugins/subtac/subtac_pretyping.mli
+++ b/plugins/subtac/subtac_pretyping.mli
@@ -13,7 +13,7 @@ module Pretyping : Pretyping.S
 val interp :
     Environ.env ->
     Evd.evar_map ref ->
-    Rawterm.rawconstr ->
+    Glob_term.glob_constr ->
     Evarutil.type_constraint -> Term.constr * Term.constr
 
 val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list ->
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
index 4f4ae92e..d5d427c7 100644
--- a/plugins/subtac/subtac_pretyping_F.ml
+++ b/plugins/subtac/subtac_pretyping_F.ml
@@ -1,21 +1,18 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping_F.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
+open Compat
 open Util
 open Names
 open Sign
 open Evd
 open Term
-open Termops
 open Reductionops
 open Environ
 open Type_errors
@@ -27,7 +24,7 @@ open List
 open Recordops
 open Evarutil
 open Pretype_errors
-open Rawterm
+open Glob_term
 open Evarconv
 open Pattern
 open Pretyping
@@ -78,15 +75,15 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	for i = 0 to lt-1 do
           if not (e_cumul env evdref (vdefj.(i)).uj_type
 		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env ( !evdref)
+            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 ind c (explft,lft) =
     for i = 0 to Array.length explft - 1 do
       if not (e_cumul env evdref lft.(i) explft.(i)) then
 	let sigma =  !evdref in
-	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
+	  error_ill_formed_branch_loc loc env sigma c (ind,i) lft.(i) explft.(i)
     done
 
   (* coerce to tycon if any *)
@@ -99,7 +96,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   (*
     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)
+    in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty)
   *)
 
   let strip_meta id = (* For Grammar v7 compatibility *)
@@ -108,7 +105,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
       else id
 
   let invert_ltac_bound_name env id0 id =
-    try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+    try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env)))
     with Not_found ->
       errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
 	str " depends on pattern variable name " ++ pr_id id ++
@@ -117,7 +114,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   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) = Termops.lookup_rel_id id (rel_context env) in
 	  { uj_val  = mkRel n; uj_type = lift n typ }
       with Not_found ->
 	try
@@ -153,7 +150,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     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=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
+      {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign}
 
   (*************************************************************************)
   (* Main pretyping function                                               *)
@@ -162,9 +159,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
 
-  let pretype_sort = function
-    | RProp c -> judge_of_prop_contents c
-    | RType _ -> judge_of_new_Type ()
+  let pretype_sort evdref = function
+    | GProp c -> judge_of_prop_contents c
+    | GType _ -> evd_comb0 judge_of_new_Type evdref
 
   let split_tycon_lam loc env evd tycon =
     let rec real_split evd c =
@@ -192,44 +189,44 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   (* in environment [env], with existential variables [( evdref)] and *)
   (* the type constraint tycon *)
   let rec pretype (tycon : type_constraint) env evdref lvar c =
-(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
+(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *)
 (* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
 (*     with _ -> () *)
 (*     in *)
     match c with
-    | RRef (loc,ref) ->
+    | GRef (loc,ref) ->
 	inh_conv_coerce_to_tycon loc env evdref
 	  (pretype_ref evdref env ref)
 	  tycon
 
-    | RVar (loc, id) ->
+    | GVar (loc, id) ->
 	inh_conv_coerce_to_tycon loc env evdref
 	  (pretype_id loc env !evdref lvar id)
 	  tycon
 
-    | REvar (loc, ev, instopt) ->
+    | GEvar (loc, ev, instopt) ->
 	(* Ne faudrait-il pas s'assurer que hyps est bien un
 	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find ( !evdref) ev) in
+	let hyps = evar_context (Evd.find !evdref ev) in
 	let args = match instopt with
           | None -> instance_from_named_context hyps
           | Some inst -> failwith "Evar subtitutions not implemented" in
 	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env ( !evdref) c) in
+	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"
+    | GPatVar (loc,(someta,n)) ->
+	anomaly "Found a pattern variable in a glob_constr to type"
 
-    | RHole (loc,k) ->
+    | GHole (loc,k) ->
 	let ty =
           match tycon with
             | Some (None, ty) -> ty
             | None | Some _ ->
-		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+		e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in
 	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
 
-    | RRec (loc,fixkind,names,bl,lar,vdef) ->
+    | GRec (loc,fixkind,names,bl,lar,vdef) ->
 	let rec type_bl env ctxt = function
             [] -> ctxt
           | (na,k,None,ty)::bl ->
@@ -260,7 +257,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  in
 	    push_rec_types (names,marked_ftys,[||]) env
 	in
-	let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in
+	let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in
 	let vdefj =
 	  array_map2_i
 	    (fun i ctxt def ->
@@ -284,10 +281,10 @@ module SubtacPretyping_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 ( !evdref)) ftys in
-	let fdefs = Array.map (fun x -> nf_evar ( !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) ->
+	  | GFix (vn,i) ->
 	      (* First, let's find the guard indexes. *)
 	      (* If recursive argument was not given by user, we try all args.
 	         An earlier approach was to look only for inductive arguments,
@@ -303,16 +300,17 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	      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 ->
+	  | GCoFix i ->
 	      let cofix = (i,(names,ftys,fdefs)) in
-	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
+	      (try check_cofix env cofix with e -> Loc.raise loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
-    | RSort (loc,s) ->
-	inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon
+    | GSort (loc,s) ->
+	let s' = pretype_sort evdref s in
+	inh_conv_coerce_to_tycon loc env evdref s' tycon
 
-    | RApp (loc,f,args) ->
+    | GApp (loc,f,args) ->
 	let length = List.length args in
 	let ftycon =
 	  let ty =
@@ -329,13 +327,13 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	    | _ -> None
 	in
 	let fj = pretype ftycon env evdref lvar f in
- 	let floc = loc_of_rawconstr f in
+ 	let floc = loc_of_glob_constr f in
 	let rec apply_rec env n resj tycon = function
 	  | [] -> resj
 	  | c::rest ->
-	      let argloc = loc_of_rawconstr c in
+	      let argloc = loc_of_glob_constr c in
 	      let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in
-              let resty = whd_betadeltaiota env ( !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) ->
 		      Option.iter (fun ty -> evdref :=
@@ -353,10 +351,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		  | _ ->
 		      let hj = pretype empty_tycon env evdref lvar c in
 			error_cant_apply_not_functional_loc
-			  (join_loc floc argloc) env ( !evdref)
+			  (join_loc floc argloc) env !evdref
 	      		  resj [hj]
 	in
-	let resj = j_nf_evar ( !evdref) (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 ->
@@ -367,7 +365,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  | _ -> resj in
 	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RLambda(loc,name,k,c1,c2)      ->
+    | GLambda(loc,name,k,c1,c2)      ->
 	let tycon' = evd_comb1
 	  (fun evd tycon ->
 	    match tycon with
@@ -385,32 +383,32 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	let resj = judge_of_abstraction env name j j' in
 	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RProd(loc,name,k,c1,c2)        ->
+    | GProd(loc,name,k,c1,c2)        ->
 	let j = pretype_type empty_valcon env evdref lvar c1 in
 	let var = (name,j.utj_val) in
-	let env' = push_rel_assum var env in
+	let env' = Termops.push_rel_assum var env in
 	let j' = pretype_type empty_valcon env' evdref lvar c2 in
 	let resj =
 	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
+	  with TypeError _ as e -> Loc.raise loc e in
 	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RLetIn(loc,name,c1,c2)      ->
+    | GLetIn(loc,name,c1,c2)      ->
 	let j = pretype empty_tycon env evdref lvar c1 in
-	let t = refresh_universes j.uj_type in
+	let t = Termops.refresh_universes j.uj_type in
 	let var = (name,Some j.uj_val,t) in
         let tycon = lift_tycon 1 tycon in
 	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
 	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
 	    uj_type = subst1 j.uj_val j'.uj_type }
 
-    | RLetTuple (loc,nal,(na,po),c,d) ->
+    | GLetTuple (loc,nal,(na,po),c,d) ->
 	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) =
-	  try find_rectype env ( !evdref) cj.uj_type
+	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env ( !evdref) cj
+	    let cloc = loc_of_glob_constr c in
+	      error_case_not_inductive_loc cloc env !evdref cj
 	in
 	let cstrs = get_constructors env indf in
 	if Array.length cstrs <> 1 then
@@ -434,14 +432,14 @@ module SubtacPretyping_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 ( !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 =
 		       (Array.to_list cs.cs_concl_realargs)
 		       @[build_dependent_constructor cs] in
 		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env ( !evdref) lp inst in
+		     let fty = hnf_lam_applist env !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 =
@@ -454,12 +452,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		     let tycon = lift_tycon cs.cs_nargs tycon in
 		     let fj = pretype tycon env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar ( !evdref) fj.uj_type in
+		     let ccl = nf_evar !evdref fj.uj_type in
 		     let ccl =
 		       if noccur_between 1 cs.cs_nargs ccl then
 			 lift (- cs.cs_nargs) ccl
 		       else
-			 error_cant_find_case_type_loc loc env ( !evdref)
+			 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 =
@@ -469,13 +467,13 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		     in
 		       { uj_val = v; uj_type = ccl })
 
-    | RIf (loc,c,(na,po),b1,b2) ->
+    | GIf (loc,c,(na,po),b1,b2) ->
 	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) =
-	  try find_rectype env ( !evdref) cj.uj_type
+	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env ( !evdref) cj in
+	    let cloc = loc_of_glob_constr c in
+	      error_case_not_inductive_loc cloc env !evdref cj in
 	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 2 then
             user_err_loc (loc,"",
@@ -494,7 +492,7 @@ module SubtacPretyping_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 ( !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;
@@ -505,11 +503,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		let p = match tycon with
 		  | Some (None, ty) -> ty
 		  | None | Some _ ->
-                      e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
+                      e_new_evar evdref env ~src:(loc,InternalHole) (Termops.new_Type ())
 		in
 		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar ( !evdref) pred in
-	  let p = nf_evar ( !evdref) p in
+	  let 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
@@ -539,12 +537,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  in
 	    { uj_val = v; uj_type = p }
 
-    | RCases (loc,sty,po,tml,eqns) ->
+    | GCases (loc,sty,po,tml,eqns) ->
 	Cases.compile_cases loc sty
 	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
 	  tycon env (* loc *) (po,tml,eqns)
 
-    | RCast (loc,c,k) ->
+    | GCast (loc,c,k) ->
 	let cj =
 	  match k with
 	      CastCoerce ->
@@ -560,18 +558,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	in
 	  inh_conv_coerce_to_tycon loc env evdref cj tycon
 
-    | RDynamic (loc,d) ->
-	if (Dyn.tag d) = "constr" then
-	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env ( !evdref) c) in
-	    j
-	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
-	else
-	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic."))
-
   (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
   and pretype_type valcon env evdref lvar = function
-    | RHole loc ->
+    | GHole loc ->
 	(match valcon with
 	   | Some v ->
                let s =
@@ -586,12 +575,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		 { utj_val = v;
 		   utj_type = s }
 	   | None ->
-	       let s = new_Type_sort () in
+	       let s = Termops.new_Type_sort () in
 		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
 		   utj_type = s})
     | c ->
 	let j = pretype empty_tycon env evdref lvar c in
-	let loc = loc_of_rawconstr c in
+	let loc = loc_of_glob_constr c in
 	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
 	  match valcon with
 	    | None -> tj
@@ -599,7 +588,7 @@ module SubtacPretyping_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 ( !evdref) tj.utj_val v
+                    (loc_of_glob_constr c) env !evdref tj.utj_val v
 
   let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
     let c' = match kind with
@@ -607,15 +596,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
 	  (pretype tycon env evdref lvar c).uj_val
       | IsType ->
-	  (pretype_type empty_valcon env evdref lvar c).utj_val in
-    evdref := consider_remaining_unif_problems env !evdref;
-    if resolve_classes then
-      (evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
-	  ~split:true ~fail:fail_evar env !evdref;
-       evdref := consider_remaining_unif_problems env !evdref);
-    let c = if expand_evar then nf_evar !evdref c' else c' in
-    if fail_evar then check_evars env Evd.empty !evdref c;
-    c
+	  (pretype_type empty_valcon env evdref lvar c).utj_val 
+    in
+      if resolve_classes then
+	(try 
+	   evdref := Typeclasses.resolve_typeclasses ~onlyargs:true
+	     ~split:true ~fail:true env !evdref;
+	   evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
+	     ~split:true ~fail:false env !evdref
+	 with e -> if fail_evar then raise e else ());
+      evdref := consider_remaining_unif_problems env !evdref;
+      let c = if expand_evar then nf_evar !evdref c' else c' in
+      if fail_evar then check_evars env Evd.empty !evdref c;
+      c
 
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
index 362c4ddc..28bbdd35 100644
--- a/plugins/subtac/subtac_utils.ml
+++ b/plugins/subtac/subtac_utils.ml
@@ -15,10 +15,8 @@ let ($) f x = f x
 let contrib_name = "Program"
 
 let subtac_dir = [contrib_name]
-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 fixsub_module = subtac_dir @ ["Wf"]
+let utils_module = subtac_dir @ ["Utils"]
 let tactics_module = subtac_dir @ ["Tactics"]
 let init_constant dir s () = gen_constant contrib_name dir s
 let init_reference dir s () = gen_reference contrib_name dir s
@@ -27,7 +25,6 @@ let safe_init_constant md name () =
   check_required_library ("Coq"::md);
   init_constant md name ()
 
-let fixsub = init_constant fixsub_module "Fix_sub"
 let ex_pi1 = init_constant utils_module "ex_pi1"
 let ex_pi2 = init_constant utils_module "ex_pi2"
 
@@ -55,11 +52,9 @@ let build_sig () =
 
 let sig_ = build_sig
 
-let fix_proto = 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 fix_proto = safe_init_constant tactics_module "fix_proto"
+
+let hide_obligation = safe_init_constant tactics_module "obligation"
 
 let eq_ind = init_constant ["Init"; "Logic"] "eq"
 let eq_rec = init_constant ["Init"; "Logic"] "eq_rec"
@@ -92,12 +87,6 @@ let ex_intro = init_reference ["Init"; "Logic"] "ex_intro"
 let proj1 = init_constant ["Init"; "Logic"] "proj1"
 let proj2 = init_constant ["Init"; "Logic"] "proj2"
 
-let boolind = init_constant ["Init"; "Datatypes"] "bool"
-let sumboolind = init_constant ["Init"; "Specif"] "sumbool"
-let natind = init_constant ["Init"; "Datatypes"] "nat"
-let intind = init_constant ["ZArith"; "binint"] "Z"
-let existSind = init_constant ["Init"; "Specif"] "sigS"
-
 let existS = build_sigma_type
 
 let prod = build_prod
@@ -120,8 +109,8 @@ let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
 let my_print_context = Termops.print_rel_context
 let my_print_named_context = Termops.print_named_context
 let my_print_env = Termops.print_env
-let my_print_rawconstr = Printer.pr_rawconstr_env
-let my_print_evardefs = Evd.pr_evar_map
+let my_print_glob_constr = Printer.pr_glob_constr_env
+let my_print_evardefs = Evd.pr_evar_map None
 
 let my_print_tycon_type = Evarutil.pr_tycon_type
 
@@ -253,7 +242,7 @@ let build_dependent_sum l =
 		([intros;
 		  (tclTHENSEQ
 		     [constructor_tac false (Some 1) 1
-			(Rawterm.ImplicitBindings [mkVar n]);
+			(Glob_term.ImplicitBindings [mkVar n]);
 		      cont]);
 		 ])))
 	in
@@ -356,7 +345,7 @@ let destruct_ex ext ex =
       | _ -> [acc]
   in aux ex ext
 
-open Rawterm
+open Glob_term
 
 let id_of_name = function
     Name n -> n
@@ -418,7 +407,6 @@ let string_of_intset d =
 open Printer
 open Ppconstr
 open Nameops
-open Termops
 open Evd
 
 let pr_meta_map evd =
@@ -430,11 +418,11 @@ let pr_meta_map evd =
     | (mv,Cltyp (na,b)) ->
       	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " : " ++
-           print_constr b.rebus ++ fnl ())
+           Termops.print_constr b.rebus ++ fnl ())
     | (mv,Clval(na,b,_)) ->
       	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " := " ++
-             print_constr (fst b).rebus ++ fnl ())
+             Termops.print_constr (fst b).rebus ++ fnl ())
   in
   prlist pr_meta_binding ml
 
@@ -445,11 +433,11 @@ let pr_evar_info evi =
     (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
     Printer.pr_named_context (Global.env()) (evar_context evi)
   in
-  let pty = print_constr evi.evar_concl in
+  let pty = Termops.print_constr evi.evar_concl in
   let pb =
     match evi.evar_body with
       | Evar_empty -> mt ()
-      | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
+      | Evar_defined c -> spc() ++ str"=> "  ++ Termops.print_constr c
   in
   hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
 
@@ -463,11 +451,11 @@ let pr_evar_map sigma =
 let pr_constraints pbs =
   h 0
     (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
-      print_constr t1 ++ spc() ++
+      Termops.print_constr t1 ++ spc() ++
       str (match pbty with
 	| Reduction.CONV -> "=="
 	| Reduction.CUMUL -> "<=") ++
-      spc() ++ print_constr t2) pbs)
+      spc() ++ Termops.print_constr t2) pbs)
 
 let pr_evar_map evd =
   let pp_evm =
@@ -486,4 +474,4 @@ let tactics_tac s =
   lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s))
 
 let tactics_call tac args =
-  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
+  TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
index f56c2932..de96cc60 100644
--- a/plugins/subtac/subtac_utils.mli
+++ b/plugins/subtac/subtac_utils.mli
@@ -6,7 +6,7 @@ open Pp
 open Evd
 open Decl_kinds
 open Topconstr
-open Rawterm
+open Glob_term
 open Util
 open Evarutil
 open Names
@@ -15,11 +15,9 @@ open Sign
 val ($) : ('a -> 'b) -> 'a -> 'b
 val contrib_name : string
 val subtac_dir : string list
-val fix_sub_module : string
 val fixsub_module : string list
 val init_constant : string list -> string -> constr delayed
 val init_reference : string list -> string -> global_reference delayed
-val fixsub : constr delayed
 val well_founded_ref : global_reference delayed
 val acc_ref : global_reference delayed
 val acc_inv_ref : global_reference delayed
@@ -35,7 +33,8 @@ val build_sig : unit -> coq_sigma_data
 val sig_ : coq_sigma_data delayed
 
 val fix_proto : constr delayed
-val fix_proto_ref : unit -> constant
+
+val hide_obligation : constr delayed
 
 val eq_ind : constr delayed
 val eq_rec : constr delayed
@@ -52,11 +51,6 @@ val jmeq_ind : constr delayed
 val jmeq_rec : constr delayed
 val jmeq_refl : constr delayed
 
-val boolind : constr delayed
-val sumboolind : constr delayed
-val natind : constr delayed
-val intind : constr delayed
-val existSind : constr delayed
 val existS : coq_sigma_data delayed
 val prod : coq_sigma_data delayed
 
@@ -74,7 +68,7 @@ val my_print_context : env -> std_ppcmds
 val my_print_rel_context : env -> rel_context -> std_ppcmds
 val my_print_named_context : env -> std_ppcmds
 val my_print_env : env -> std_ppcmds
-val my_print_rawconstr : env -> rawconstr -> std_ppcmds
+val my_print_glob_constr : env -> glob_constr -> std_ppcmds
 val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
 
 
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index ae3afff4..bd2285bb 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,13 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: ascii_syntax.ml 12406 2009-10-21 15:12:52Z soubiran $ i*)
-
 open Pp
 open Util
 open Names
 open Pcoq
-open Rawterm
+open Glob_term
 open Topconstr
 open Libnames
 open Coqlib
@@ -41,9 +39,9 @@ let interp_ascii dloc 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)
+     GRef (dloc,if mp = 0 then glob_false else glob_true)
      :: (aux (n-1) (p/2)) in
-  RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
+  GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p)
 
 let interp_ascii_string dloc s =
   let p =
@@ -59,12 +57,12 @@ let interp_ascii_string dloc s =
 let uninterp_ascii r =
   let rec uninterp_bool_list n = function
     | [] when n = 0 -> 0
-    | 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)
+    | GRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
     | _ -> raise Non_closed_ascii in
   try
     let rec aux = function
-    | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
     | _ -> raise Non_closed_ascii in
     Some (aux r)
   with
@@ -80,4 +78,4 @@ let _ =
   Notation.declare_string_interpreter "char_scope"
     (ascii_path,ascii_module)
     interp_ascii_string
-    ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
+    ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 7b92a92f..446ae522 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nat_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* This file defines the printer for natural numbers in [nat] *)
 
 (*i*)
@@ -16,7 +14,7 @@ open Pp
 open Util
 open Names
 open Coqlib
-open Rawterm
+open Glob_term
 open Libnames
 open Bigint
 open Coqlib
@@ -38,11 +36,11 @@ let nat_of_int dloc n =
 	   strbrk "working with large numbers in nat (observed threshold " ++
 	   strbrk "may vary from 5000 to 70000 depending on your system " ++
 	   strbrk "limits and on the command executed).");
-      let ref_O = RRef (dloc, glob_O) in
-      let ref_S = RRef (dloc, glob_S) in
+      let ref_O = GRef (dloc, glob_O) in
+      let ref_S = GRef (dloc, glob_S) in
       let rec mk_nat acc n =
 	if n <> zero then
-	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+	  mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n)
 	else
 	  acc
       in
@@ -58,8 +56,8 @@ let nat_of_int dloc n =
 exception Non_closed_number
 
 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
+  | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
+  | GRef (_,z) when z = glob_O -> zero
   | _ -> raise Non_closed_number
 
 let uninterp_nat p =
@@ -75,4 +73,4 @@ let _ =
   Notation.declare_numeral_interpreter "nat_scope"
     (nat_path,["Coq";"Init";"Datatypes"])
     nat_of_int
-    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true)
+    ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true)
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index a540a7d0..19a3c899 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: numbers_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* digit-based syntax for int31, bigN bigZ and bigQ *)
 
 open Bigint
 open Libnames
-open Rawterm
+open Glob_term
 
 (*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
 
@@ -48,7 +46,7 @@ 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"
-let bigN_t = make_mind_mpdot bigN_module "BigN" "t_"
+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) *)
@@ -100,9 +98,9 @@ exception Non_closed
 (* parses a *non-negative* integer (from bigint.ml) into an int31
    wraps modulo 2^31 *)
 let int31_of_pos_bigint dloc n =
-  let ref_construct = RRef (dloc, int31_construct) in
-  let ref_0 = RRef (dloc, int31_0) in
-  let ref_1 = RRef (dloc, int31_1) in
+  let ref_construct = GRef (dloc, int31_construct) in
+  let ref_0 = GRef (dloc, int31_0) in
+  let ref_1 = GRef (dloc, int31_1) in
   let rec args counter n =
     if counter <= 0 then
       []
@@ -110,7 +108,7 @@ let int31_of_pos_bigint dloc n =
       let (q,r) = div2_with_rest n in
 	(if r then ref_1 else ref_0)::(args (counter-1) q)
   in
-  RApp (dloc, ref_construct, List.rev (args 31 n))
+  GApp (dloc, ref_construct, List.rev (args 31 n))
 
 let error_negative dloc =
   Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
@@ -127,12 +125,12 @@ 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))
+      | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
+      | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
       | _ -> raise Non_closed
   in
   function
-  | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero
+  | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero
   | _ -> raise Non_closed
 
 let uninterp_int31 i =
@@ -145,7 +143,7 @@ let uninterp_int31 i =
 let _ = Notation.declare_numeral_interpreter int31_scope
   (int31_path, int31_module)
   interp_int31
-  ([RRef (Util.dummy_loc, int31_construct)],
+  ([GRef (Util.dummy_loc, int31_construct)],
    uninterp_int31,
    true)
 
@@ -176,24 +174,24 @@ let height bi =
 
 (* n must be a non-negative integer (from bigint.ml) *)
 let word_of_pos_bigint dloc hght n =
-  let ref_W0 = RRef (dloc, zn2z_W0) in
-  let ref_WW = RRef (dloc, zn2z_WW) in
+  let ref_W0 = GRef (dloc, zn2z_W0) in
+  let ref_WW = GRef (dloc, zn2z_WW) in
   let rec decomp hgt n =
     if is_neg_or_zero hgt then
       int31_of_pos_bigint dloc n
     else if equal n zero then
-      RApp (dloc, ref_W0, [RHole (dloc, Evd.InternalHole)])
+      GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)])
     else
       let (h,l) = split_at hgt n in
-      RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole);
+      GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole);
 			   decomp (sub_1 hgt) h;
 			   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
+  let ref_constructor i = GRef (dloc, bigN_constructor i) in
+  let result h word = GApp (dloc, ref_constructor h, if less_than h n_inlined then
 				                       [word]
 			                             else
 				                      [Nat_syntax.nat_of_int dloc (sub h n_inlined);
@@ -217,7 +215,7 @@ let interp_bigN dloc n =
 let bigint_of_word =
   let rec get_height rc =
     match rc with
-    | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+    | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
 	                                  let hleft = get_height lft in
 					  let hright = get_height rght in
 					  add_1
@@ -229,8 +227,8 @@ let bigint_of_word =
   in
   let rec transform hght rc =
     match rc with
-    | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero
-    | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in
+    | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero
+    | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in
 	                                                add (mult (rank new_hght)
                                                           (transform (new_hght) lft))
 	                                            (transform (new_hght) rght)
@@ -242,8 +240,8 @@ let bigint_of_word =
 
 let bigint_of_bigN rc =
   match rc with
-  | RApp (_,_,[one_arg]) -> bigint_of_word one_arg
-  | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg
+  | GApp (_,_,[one_arg]) -> bigint_of_word one_arg
+  | GApp (_,_,[_;second_arg]) -> bigint_of_word second_arg
   | _ -> raise Non_closed
 
 let uninterp_bigN rc =
@@ -259,7 +257,7 @@ let uninterp_bigN rc =
 let bigN_list_of_constructors =
   let rec build i =
     if less_than i (add_1 n_inlined) then
-      RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i))
+      GRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i))
     else
       []
   in
@@ -276,17 +274,17 @@ let _ = Notation.declare_numeral_interpreter bigN_scope
 
 (*** Parsing for bigZ in digital notation ***)
 let interp_bigZ dloc n =
-  let ref_pos = RRef (dloc, bigZ_pos) in
-  let ref_neg = RRef (dloc, bigZ_neg) in
+  let ref_pos = GRef (dloc, bigZ_pos) in
+  let ref_neg = GRef (dloc, bigZ_neg) in
   if is_pos_or_zero n then
-    RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
+    GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
   else
-    RApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)])
+    GApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg 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 ->
+  | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg
+  | GApp (_, GRef(_,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
@@ -305,19 +303,19 @@ let uninterp_bigZ rc =
 let _ = Notation.declare_numeral_interpreter bigZ_scope
   (bigZ_path, bigZ_module)
   interp_bigZ
-  ([RRef (Util.dummy_loc, bigZ_pos);
-    RRef (Util.dummy_loc, bigZ_neg)],
+  ([GRef (Util.dummy_loc, bigZ_pos);
+    GRef (Util.dummy_loc, bigZ_neg)],
    uninterp_bigZ,
    true)
 
 (*** Parsing for bigQ in digital notation ***)
 let interp_bigQ dloc n =
-  let ref_z = RRef (dloc, bigQ_z) in
-  RApp (dloc, ref_z, [interp_bigZ dloc n])
+  let ref_z = GRef (dloc, bigQ_z) in
+  GApp (dloc, ref_z, [interp_bigZ dloc n])
 
 let uninterp_bigQ rc =
   try match rc with
-    | RApp (_, RRef(_,c), [one_arg]) when c = bigQ_z ->
+    | GApp (_, GRef(_,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
@@ -326,5 +324,5 @@ let uninterp_bigQ rc =
 let _ = Notation.declare_numeral_interpreter bigQ_scope
   (bigQ_path, bigQ_module)
   interp_bigQ
-  ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
+  ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
    true)
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 43e79c82..b9c0bcd6 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: r_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Util
 open Names
@@ -22,7 +20,7 @@ exception Non_closed_number
 (**********************************************************************)
 
 open Libnames
-open Rawterm
+open Glob_term
 open Bigint
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
@@ -48,24 +46,24 @@ let four = mult_2 two
 
 (* Unary representation of strictly positive numbers *)
 let rec small_r dloc n =
-  if equal one n then RRef (dloc, glob_R1)
-  else RApp(dloc,RRef (dloc,glob_Rplus),
-            [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+  if equal one n then GRef (dloc, glob_R1)
+  else GApp(dloc,GRef (dloc,glob_Rplus),
+            [GRef (dloc, glob_R1);small_r dloc (sub_1 n)])
 
 let r_of_posint dloc n =
-  let r1 = RRef (dloc, glob_R1) in
+  let r1 = GRef (dloc, glob_R1) in
   let r2 = small_r dloc two in
   let rec r_of_pos n =
     if less_than n four then small_r dloc n
     else
       let (q,r) = div2_with_rest n in
-      let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
-      if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in
-  if n <> zero then r_of_pos n else RRef(dloc,glob_R0)
+      let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
+      if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in
+  if n <> zero then r_of_pos n else GRef(dloc,glob_R0)
 
 let r_of_int dloc z =
   if is_strictly_neg z then
-    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+    GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
   else
     r_of_posint dloc z
 
@@ -77,33 +75,33 @@ let bignat_of_r =
 (* for numbers > 1 *)
 let rec bignat_of_pos = function
   (* 1+1 *)
-  | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)])
+  | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)])
       when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
   (* 1+(1+1) *)
-  | RApp (_,RRef (_,p1), [RRef (_,o1);
-      RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])])
+  | GApp (_,GRef (_,p1), [GRef (_,o1);
+      GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])])
       when p1 = glob_Rplus & p2 = glob_Rplus &
            o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
   (* (1+1)*b *)
-  | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult ->
+  | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult ->
       if bignat_of_pos a <> two then raise Non_closed_number;
       mult_2 (bignat_of_pos b)
   (* 1+(1+1)*b *)
-  | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
+  | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])])
       when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  ->
       if bignat_of_pos a <> two then raise Non_closed_number;
         add_1 (mult_2 (bignat_of_pos b))
   | _ -> raise Non_closed_number
 in
 let bignat_of_r = function
-  | RRef (_,a) when a = glob_R0 -> zero
-  | RRef (_,a) when a = glob_R1 -> one
+  | GRef (_,a) when a = glob_R0 -> zero
+  | GRef (_,a) when a = glob_R1 -> one
   | r -> bignat_of_pos r
 in
 bignat_of_r
 
 let bigint_of_r = function
-  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+  | GApp (_,GRef (_,o), [a]) when o = glob_Ropp ->
       let n = bignat_of_r a in
       if n = zero then raise Non_closed_number;
       neg n
@@ -118,8 +116,8 @@ let uninterp_r p =
 let _ = Notation.declare_numeral_interpreter "R_scope"
   (r_path,["Coq";"Reals";"Rdefinitions"])
   r_of_int
-  ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0);
-    RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);
-    RRef(dummy_loc,glob_R1)],
+  ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0);
+    GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult);
+    GRef(dummy_loc,glob_R1)],
     uninterp_r,
     false)
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index 534605c8..d670f602 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: string_syntax.ml 12337 2009-09-17 15:58:14Z glondu $ i*)
-
 open Pp
 open Util
 open Names
@@ -15,7 +13,7 @@ open Pcoq
 open Libnames
 open Topconstr
 open Ascii_syntax
-open Rawterm
+open Glob_term
 open Coqlib
 
 exception Non_closed_string
@@ -39,8 +37,8 @@ open Lazy
 let interp_string dloc s =
   let le = String.length s in
   let rec aux n =
-     if n = le then RRef (dloc, force glob_EmptyString) else
-     RApp (dloc,RRef (dloc, force glob_String),
+     if n = le then GRef (dloc, force glob_EmptyString) else
+     GApp (dloc,GRef (dloc, force glob_String),
        [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
   in aux 0
 
@@ -48,11 +46,11 @@ let uninterp_string r =
   try
     let b = Buffer.create 16 in
     let rec aux = function
-    | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
+    | GApp (_,GRef (_,k),[a;s]) when k = force glob_String ->
 	(match uninterp_ascii a with
 	  | Some c -> Buffer.add_char b (Char.chr c); aux s
 	  | _ -> raise Non_closed_string)
-    | RRef (_,z) when z = force glob_EmptyString ->
+    | GRef (_,z) when z = force glob_EmptyString ->
 	Some (Buffer.contents b)
     | _ ->
 	raise Non_closed_string
@@ -64,6 +62,6 @@ 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_EmptyString)],
+    ([GRef (dummy_loc,static_glob_String);
+      GRef (dummy_loc,static_glob_EmptyString)],
      uninterp_string, true)
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index e6dcc35e..f8bce8f7 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: z_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pcoq
 open Pp
 open Util
@@ -23,18 +21,19 @@ exception Non_closed_number
 (**********************************************************************)
 
 open Libnames
-open Rawterm
+open Glob_term
+
+let binnums = ["Coq";"Numbers";"BinNums"]
+
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let positive_module = ["Coq";"NArith";"BinPos"]
 let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
 
-let positive_path = make_path positive_module "positive"
+let positive_path = make_path binnums "positive"
 
 (* TODO: temporary hack *)
 let make_kn dir id = Libnames.encode_mind dir id
 
-let positive_kn =
-  make_kn (make_dir positive_module) (id_of_string "positive")
+let positive_kn = make_kn (make_dir binnums) (id_of_string "positive")
 let glob_positive = IndRef (positive_kn,0)
 let path_of_xI = ((positive_kn,0),1)
 let path_of_xO = ((positive_kn,0),2)
@@ -44,13 +43,13 @@ let glob_xO = ConstructRef path_of_xO
 let glob_xH = ConstructRef path_of_xH
 
 let pos_of_bignat dloc x =
-  let ref_xI = RRef (dloc, glob_xI) in
-  let ref_xH = RRef (dloc, glob_xH) in
-  let ref_xO = RRef (dloc, glob_xO) in
+  let ref_xI = GRef (dloc, glob_xI) in
+  let ref_xH = GRef (dloc, glob_xH) in
+  let ref_xO = GRef (dloc, glob_xO) in
   let rec pos_of x =
     match div2_with_rest x with
-      | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
-      | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q])
+      | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
+      | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q])
       | (q,true) -> ref_xH
   in
   pos_of x
@@ -68,9 +67,9 @@ let interp_positive dloc n =
 (**********************************************************************)
 
 let rec bignat_of_pos = function
-  | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
-  | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
-  | RRef (_, a) when a = glob_xH -> Bigint.one
+  | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
+  | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | GRef (_, a) when a = glob_xH -> Bigint.one
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
@@ -84,11 +83,11 @@ let uninterp_positive p =
 (************************************************************************)
 
 let _ = Notation.declare_numeral_interpreter "positive_scope"
-  (positive_path,positive_module)
+  (positive_path,binnums)
   interp_positive
-  ([RRef (dummy_loc, glob_xI);
-    RRef (dummy_loc, glob_xO);
-    RRef (dummy_loc, glob_xH)],
+  ([GRef (dummy_loc, glob_xI);
+    GRef (dummy_loc, glob_xO);
+    GRef (dummy_loc, glob_xH)],
    uninterp_positive,
    true)
 
@@ -96,21 +95,20 @@ let _ = Notation.declare_numeral_interpreter "positive_scope"
 (* Parsing N via scopes                                               *)
 (**********************************************************************)
 
-let binnat_module = ["Coq";"NArith";"BinNat"]
-let n_kn = make_kn (make_dir binnat_module) (id_of_string "N")
+let n_kn = make_kn (make_dir binnums) (id_of_string "N")
 let glob_n = IndRef (n_kn,0)
 let path_of_N0 = ((n_kn,0),1)
 let path_of_Npos = ((n_kn,0),2)
 let glob_N0 = ConstructRef path_of_N0
 let glob_Npos = ConstructRef path_of_Npos
 
-let n_path = make_path binnat_module "N"
+let n_path = make_path binnums "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])
+    GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n])
   else
-    RRef (dloc, glob_N0)
+    GRef (dloc, glob_N0)
 
 let error_negative dloc =
   user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
@@ -124,8 +122,8 @@ let n_of_int dloc n =
 (**********************************************************************)
 
 let bignat_of_n = function
-  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
-  | RRef (_, a) when a = glob_N0 -> Bigint.zero
+  | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
+  | GRef (_, a) when a = glob_N0 -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_n p =
@@ -136,10 +134,10 @@ let uninterp_n p =
 (* Declaring interpreters and uninterpreters for N *)
 
 let _ = Notation.declare_numeral_interpreter "N_scope"
-  (n_path,binnat_module)
+  (n_path,binnums)
   n_of_int
-  ([RRef (dummy_loc, glob_N0);
-    RRef (dummy_loc, glob_Npos)],
+  ([GRef (dummy_loc, glob_N0);
+    GRef (dummy_loc, glob_Npos)],
   uninterp_n,
   true)
 
@@ -147,9 +145,8 @@ let _ = Notation.declare_numeral_interpreter "N_scope"
 (* Parsing Z via scopes                                               *)
 (**********************************************************************)
 
-let binint_module = ["Coq";"ZArith";"BinInt"]
-let z_path = make_path binint_module "Z"
-let z_kn = make_kn (make_dir binint_module) (id_of_string "Z")
+let z_path = make_path binnums "Z"
+let z_kn = make_kn (make_dir binnums) (id_of_string "Z")
 let glob_z = IndRef (z_kn,0)
 let path_of_ZERO = ((z_kn,0),1)
 let path_of_POS = ((z_kn,0),2)
@@ -162,18 +159,18 @@ 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])
+    GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n])
   else
-    RRef (dloc, glob_ZERO)
+    GRef (dloc, glob_ZERO)
 
 (**********************************************************************)
 (* Printing Z via scopes                                              *)
 (**********************************************************************)
 
 let bigint_of_z = function
-  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
-  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
-  | RRef (_, a) when a = glob_ZERO -> Bigint.zero
+  | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
+  | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | GRef (_, a) when a = glob_ZERO -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_z p =
@@ -185,10 +182,10 @@ let uninterp_z p =
 (* Declaring interpreters and uninterpreters for Z *)
 
 let _ = Notation.declare_numeral_interpreter "Z_scope"
-  (z_path,binint_module)
+  (z_path,binnums)
   z_of_int
-  ([RRef (dummy_loc, glob_ZERO);
-    RRef (dummy_loc, glob_POS);
-    RRef (dummy_loc, glob_NEG)],
+  ([GRef (dummy_loc, glob_ZERO);
+    GRef (dummy_loc, glob_POS);
+    GRef (dummy_loc, glob_NEG)],
   uninterp_z,
   true)
diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml
index 97287d18..653c2b7b 100644
--- a/plugins/xml/acic.ml
+++ b/plugins/xml/acic.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
index 631af9f0..97f7e2bd 100644
--- a/plugins/xml/acic2Xml.ml4
+++ b/plugins/xml/acic2Xml.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
index 0b98acd2..da0a65ff 100644
--- a/plugins/xml/cic2acic.ml
+++ b/plugins/xml/cic2acic.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
index d67c114e..a21a919a 100644
--- a/plugins/xml/doubleTypeInference.ml
+++ b/plugins/xml/doubleTypeInference.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -27,7 +27,7 @@ let cprop =
 ;;
 
 let whd_betadeltaiotacprop env _evar_map ty =
- let module R = Rawterm in
+ let module R = Glob_term in
  let module C = Closure in
  let module CR = C.RedFlags in
  (*** CProp is made Opaque ***)
diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
index 3858b906..5c00bdc6 100644
--- a/plugins/xml/doubleTypeInference.mli
+++ b/plugins/xml/doubleTypeInference.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
index 3cfc52b7..3c3e54fa 100644
--- a/plugins/xml/dumptree.ml4
+++ b/plugins/xml/dumptree.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -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 "\"/>"
 ;;
 
@@ -56,13 +56,11 @@ let pr_rule_xml pr = function
       hov 2 (str "<cmpdrule>" ++ fnl () ++
         begin match cmpd with
           Tactic (texp, _) -> pr_tactic_xml texp
-        | Proof_instr (_,instr) -> pr_proof_instr_xml instr
         end ++ fnl ()
         ++ pr subtree
       ) ++ fnl () ++ str "</cmpdrule>"
   | Daimon -> str "<daimon/>"
   | Decl_proof _ -> str "<proof/>"
-(*  | Change_evars -> str "<chgevars/>"*)
 ;;
 
 let pr_var_decl_xml env (id,c,typ) =
@@ -115,11 +113,11 @@ let pr_subgoal_metas_xml metas env=
   List.fold_left (++) (mt ()) (List.map pr_one metas)
 ;;
 
-let pr_goal_xml g =
-  let env = try evar_unfiltered_env g with _ -> empty_env in
-  if g.evar_extra = None then
+let pr_goal_xml sigma g =
+  let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in
+  if Decl_mode.try_get_info sigma g = None then
     (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
-    xmlstream (pr_ltype_env_at_top env g.evar_concl) ++
+    xmlstream (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) ++
     str "\"/>" ++
     (pr_context_xml env)) ++
     fnl () ++ str "</goal>")
@@ -129,23 +127,9 @@ let pr_goal_xml g =
     fnl () ++ str "</goal>")
 ;;
 
-let rec print_proof_xml 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 -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>"
-    | Some(r,spfl) ->
-        hov 2 (str "<tree>" ++ fnl () ++
-        (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++
-        (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
-      (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ())))
-  in
-  msgnl pp
-;;
+  Util.anomaly "Dump Tree command not supported in this version."
+
 
 VERNAC COMMAND EXTEND DumpTree
   [ "Dump" "Tree" ] -> [ print_proof_xml () ]
diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
index d871935b..2d16190b 100644
--- a/plugins/xml/proof2aproof.ml
+++ b/plugins/xml/proof2aproof.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -59,30 +59,6 @@ let nf_evar sigma ~preserve =
     aux
 ;;
 
-(* Unshares a proof-tree.                                                  *)
-(* 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 ;
-	    PT.ref = ref} ->
-   let unshared_ref =
-    match ref with
-       None -> None
-     | Some (rule,pfs) ->
-        let unshared_rule =
-         match rule with
-             PT.Nested (cmpd, pf) ->
-               PT.Nested (cmpd, unshare_proof_tree pf)
-	   | other -> other
-	in
-         Some (unshared_rule, List.map unshare_proof_tree pfs)
-   in
-    {PT.open_subgoals = status ;
-     PT.goal = goal ;
-     PT.ref = unshared_ref}
-;;
-
 module ProofTreeHash =
  Hashtbl.Make
   (struct
@@ -94,83 +70,9 @@ module ProofTreeHash =
 
 
 let extract_open_proof sigma pf =
- let module PT = Proof_type in
- let module L = Logic in
-  let evd = ref (Evd.create_evar_defs sigma) in
-  let proof_tree_to_constr = ProofTreeHash.create 503 in
-  let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in
-  let unshared_constrs = ref S.empty in
-  let rec proof_extractor vl node =
-   let constr =
-    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
-             (fun id ->
-                (* Section variables are in the [id] list but are not *)
-                (* lambda abstracted in the term [vl]                 *)
-                try let n = Logic.proof_variable_index id vl in (n,id)
-	        with Not_found -> failwith "caught")
-(*CSC: the above function must be modified such that when it is found  *)
-(*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
-		(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 =
-             List.map
-               (fun (_,id) -> Sign.lookup_named id
-		   (Environ.named_context_of_val goal.Evd.evar_hyps))
-               sorted_rels in
-	   Environ.val_of_named_context l
-         in
-(*CSC: the section variables in the right order must be added too *)
-         let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in
-    (*     let env = Global.env_of_context context in *)
-	 let evd',evar =
-           Evarutil.new_evar_instance context !evd goal.Evd.evar_concl
-             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)
-        ~preserve:(function e -> S.mem e !unshared_constrs) constr
-     in
-      Unshare.unshare
-       ~already_unshared:(function e -> S.mem e !unshared_constrs)
-       evar_nf_constr
-    in
-(*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) [] 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, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
-    unshared_pf)
-;;
+  (* Deactivated and candidate for removal. (Apr. 2010) *)
+   ()
 
 let extract_open_pftreestate pts =
-  extract_open_proof (Refiner.evc_of_pftreestate pts)
-   (Tacmach.proof_of_pftreestate pts)
-;;
+  (* Deactivated and candidate for removal. (Apr. 2010) *)
+   ()
diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
index 21c86c79..2f5eb6ac 100644
--- a/plugins/xml/proofTree2Xml.ml4
+++ b/plugins/xml/proofTree2Xml.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -14,11 +14,6 @@
 
 let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
 
-let std_ppcmds_to_string s =
-   Pp.msg_with Format.str_formatter s;
-   Format.flush_str_formatter ()
-;;
-
 let idref_of_id id = "v" ^ id;;
 
 (* Transform a constr to an Xml.token Stream.t *)
@@ -149,22 +144,24 @@ 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
         | _ ->
          (****** la tactique employee *)
 	 let prtac = Pptactic.pr_tactic (Global.env()) in
-         let tac = std_ppcmds_to_string (prtac tactic_expr) in
+         let tac = Pp.string_of_ppcmds (prtac tactic_expr) in
          let tacname= first_word tac in
          let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
 
          (****** le but *)
-         let {Evd.evar_concl=concl;
-              Evd.evar_hyps=hyps}=goal in
+
+	 let concl = Goal.V82.concl sigma goal in
+	 let hyps = Goal.V82.hyps sigma goal in
 
          let env = Global.env_of_context hyps in
+	   
 
          let xgoal =
           X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
@@ -188,14 +185,12 @@ Pp.ppnl (Pp.(++) (Pp.str
           [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
         end
 
-     | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
-         Util.anomaly "Not Implemented"
-
      | {PT.ref=Some(PT.Daimon,_)} ->
          X.xml_empty "Hidden_open_goal" of_attribute
 
      | {PT.ref=None;PT.goal=goal} ->
          X.xml_empty "Open_goal" of_attribute
+     | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof"
   in
    [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
       X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
index 344a1581..c854427d 100644
--- a/plugins/xml/unshare.ml
+++ b/plugins/xml/unshare.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
index 4b96b22e..cace2de6 100644
--- a/plugins/xml/unshare.mli
+++ b/plugins/xml/unshare.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
index 2d73074b..8a4eb39a 100644
--- a/plugins/xml/xml.ml4
+++ b/plugins/xml/xml.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
index ffaad957..0b6d5198 100644
--- a/plugins/xml/xml.mli
+++ b/plugins/xml/xml.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -12,8 +12,6 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Tokens for XML cdata, empty elements and not-empty elements           *)
 (* Usage:                                                                *)
 (*  Str cdata                                                            *)
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
index 7e7f890f..1037bbf0 100644
--- a/plugins/xml/xmlcommand.ml
+++ b/plugins/xml/xmlcommand.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -527,8 +527,10 @@ let print internal glob_ref kind xml_library_root =
         Cic2acic.Variable kn,mk_variable_obj id body typ
     | Ln.ConstRef kn ->
        let id = N.id_of_label (N.con_label kn) in
-       let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} =
-        G.lookup_constant kn in
+       let cb = G.lookup_constant kn in
+       let val0 = D.body_of_constant cb in
+       let typ = cb.D.const_type in
+       let hyps = cb.D.const_hyps in
        let typ = Typeops.type_of_constant_type (Global.env()) typ in
         Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
     | Ln.IndRef (kn,_) ->
@@ -557,43 +559,13 @@ let print_ref qid fn =
 (*  where dest is either None (for stdout) or (Some filename) *)
 (* pretty prints via Xml.pp the proof in progress on dest     *)
 let show_pftreestate internal fn (kind,pftst) id =
- let pf = Tacmach.proof_of_pftreestate pftst in
- let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in
- let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree,
-     unshared_pf
- =
-  Proof2aproof.extract_open_pftreestate pftst in
- let env = Global.env () in
- let obj =
-  mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in
- let uri =
-  match kind with
-     Decl_kinds.Local, _ ->
-      let uri =
-       "cic:/" ^ String.concat "/"
-        (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable)
-      in
-      let kind_of_var = "VARIABLE","LocalFact" in
-      (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
-      (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,
-    proof_tree_to_flattened_proof_tree)) fn
-;;
+ if true then
+   Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version."
 
 let show fn =
  let pftst = Pfedit.get_pftreestate () in
  let (id,kind,_,_) = Pfedit.current_proof_statement () in
-  show_pftreestate Declare.KernelVerbose fn (kind,pftst) id
+  show_pftreestate false fn (kind,pftst) id
 ;;
 
 
@@ -680,7 +652,7 @@ let _ =
        end ;
        Option.iter
 	(fun fn ->
-	  let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in
+	  let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in
 	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
           let command cmd =
            if Sys.command cmd <> 0 then
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
index eadf3cfd..ec50d623 100644
--- a/plugins/xml/xmlcommand.mli
+++ b/plugins/xml/xmlcommand.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -12,8 +12,6 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xmlcommand.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* print_global qid fn                                                    *)
 (*  where qid  is a long name denoting a definition/theorem or            *)
 (*             an inductive definition                                    *)
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
index f9d5bac0..d65a1bd3 100644
--- a/plugins/xml/xmlentries.ml4
+++ b/plugins/xml/xmlentries.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 (*         *   University of Bologna                                    *)
@@ -14,8 +14,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: xmlentries.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util;;
 open Vernacinterp;;
 
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
new file mode 100644
index 00000000..5e2284e1
--- /dev/null
+++ b/pretyping/arguments_renaming.ml
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i*)
+open Names
+open Libnames
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Util
+open Pp
+open Libobject
+open Nameops
+(*i*)
+
+let empty_name_table = (Refmap.empty : name list list Refmap.t)
+let name_table = ref empty_name_table
+
+let _ =
+  Summary.declare_summary "rename-arguments"
+    { Summary.freeze_function = (fun () -> !name_table);
+      Summary.unfreeze_function = (fun r -> name_table := r);
+      Summary.init_function = (fun () -> name_table := empty_name_table) }
+
+type req =
+  | ReqLocal
+  | ReqGlobal of global_reference * name list list
+
+let load_rename_args _ (_, (_, (r, names))) =
+  name_table := Refmap.add r names !name_table
+
+let cache_rename_args o = load_rename_args 1 o
+
+let classify_rename_args = function
+  | ReqLocal, _ -> Dispose
+  | ReqGlobal _, _ as o -> Substitute o
+
+let subst_rename_args (subst, (_, (r, names as orig))) = 
+  ReqLocal,
+  let r' = fst (subst_global subst r) in 
+  if r==r' then orig else (r', names)
+
+let section_segment_of_reference = function
+  | ConstRef con -> Lib.section_segment_of_constant con
+  | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
+      Lib.section_segment_of_mutual_inductive kn
+  | _ -> []
+
+let discharge_rename_args = function
+  | _, (ReqGlobal (c, names), _) ->
+     let c' = pop_global_reference c in
+     let vars = section_segment_of_reference c in
+     let var_names = List.map (fun (id, _,_,_) -> Name id) vars in
+     let names' = List.map (fun l -> var_names @ l) names in
+     Some (ReqGlobal (c', names), (c', names'))
+  | _ -> None
+
+let rebuild_rename_args x = x
+
+let inRenameArgs = declare_object { (default_object "RENAME-ARGUMENTS" ) with
+  load_function = load_rename_args;
+  cache_function = cache_rename_args;
+  classify_function = classify_rename_args;
+  subst_function = subst_rename_args;
+  discharge_function = discharge_rename_args;
+  rebuild_function = rebuild_rename_args;
+}
+
+let rename_arguments local r names =
+  let req = if local then ReqLocal else ReqGlobal (r, names) in
+  Lib.add_anonymous_leaf (inRenameArgs (req, (r, names)))       
+
+let arguments_names r = Refmap.find r !name_table
+
+let rec rename_prod c = function 
+  | [] -> c
+  | (Name _ as n) :: tl -> 
+      (match kind_of_type c with
+      | ProdType (_, s, t) -> mkProd (n, s, rename_prod t tl)
+      | _ -> c)
+  | _ :: tl -> 
+      match kind_of_type c with
+      | ProdType (n, s, t) -> mkProd (n, s, rename_prod t tl)
+      | _ -> c
+        
+let rename_type ty ref =
+  try rename_prod ty (List.hd (arguments_names ref))
+  with Not_found -> ty
+
+let rename_type_of_constant env c =
+  let ty = Typeops.type_of_constant env c in
+  rename_type ty (ConstRef c)
+
+let rename_type_of_inductive env ind =
+  let ty = Inductiveops.type_of_inductive env ind in
+  rename_type ty (IndRef ind)
+
+let rename_type_of_constructor env cstruct =
+  let ty = Inductiveops.type_of_constructor env cstruct in
+  rename_type ty (ConstructRef cstruct)
+
+let rename_typing env c =
+  let j = Typeops.typing env c in
+  match kind_of_term c with
+  | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) }
+  | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) }
+  | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) }
+  | _ -> j
+
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
new file mode 100644
index 00000000..a484ecf7
--- /dev/null
+++ b/pretyping/arguments_renaming.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Libnames
+open Environ
+open Term
+
+val rename_arguments : bool -> global_reference -> name list list -> unit
+
+(** [Not_found] is raised is no names are defined for [r] *)
+val arguments_names : global_reference -> name list list
+
+val rename_type_of_constant : env -> constant -> types
+val rename_type_of_inductive : env -> inductive -> types
+val rename_type_of_constructor : env -> constructor -> types
+val rename_typing : env -> constr -> unsafe_judgment
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 749101f7..8963ea5e 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml 14675 2011-11-17 22:19:34Z herbelin $ *)
-
+open Compat
 open Util
 open Names
 open Nameops
@@ -21,7 +20,7 @@ open Sign
 open Reductionops
 open Typeops
 open Type_errors
-open Rawterm
+open Glob_term
 open Retyping
 open Pretype_errors
 open Evarutil
@@ -44,7 +43,7 @@ type pattern_matching_error =
 exception PatternMatchingError of env * pattern_matching_error
 
 let raise_pattern_matching_error (loc,ctx,te) =
-  Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te))
+  Loc.raise loc (PatternMatchingError(ctx,te))
 
 let error_bad_pattern_loc loc cstr ind =
   raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind))
@@ -64,33 +63,12 @@ let error_wrong_predicate_arity_loc loc env c n1 n2 =
 let error_needs_inversion env x t =
   raise (PatternMatchingError (env, NeedsInversion (x,t)))
 
-(**********************************************************************)
-(* Functions to deal with impossible cases *)
-
-let impossible_default_case = ref None
-
-let set_impossible_default_clause c = impossible_default_case := Some c
-
-let coq_unit_judge =
-  let na1 = Name (id_of_string "A") in
-  let na2 = Name (id_of_string "H") in
-  fun () ->
-    match !impossible_default_case with
-    | Some (id,type_of_id) ->
-	make_judge id type_of_id
-    | 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)))
-
-(**********************************************************************)
-
 module type S = sig
   val compile_cases :
     loc -> case_style ->
-    (type_constraint -> env -> evar_map ref -> rawconstr -> unsafe_judgment) * evar_map ref ->
+    (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
     type_constraint ->
-    env -> rawconstr option * tomatch_tuples * cases_clauses ->
+    env -> glob_constr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
 
@@ -100,7 +78,7 @@ let rec list_try_compile f = function
   | h::t ->
       try f h
       with UserError _ | TypeError _ | PretypeError _
-	| Stdpp.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) ->
+	| Loc.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) ->
 	    list_try_compile f t
 
 let force_name =
@@ -128,37 +106,13 @@ let push_rels vars env = List.fold_right push_rel vars env
 (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
    over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
 
-let regeneralize_rel i k j = if j = i+k then k+1 else j
-
-let rec regeneralize_index i k t = match kind_of_term t with
-  | Rel j when j = i+k -> mkRel (k+1)
-  | Rel j when j < i+k -> t
-  | Rel j when j > i+k -> t
-  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
+let relocate_rel n1 n2 k j = if j = n1+k then n2+k else j
 
-type alias_constr =
-  | DepAlias
-  | NonDepAlias
-
-let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
-  { uj_val =
-    if
-      isRel deppat or not (dependent (mkRel 1) j.uj_val) or
-      d = NonDepAlias & not (dependent (mkRel 1) j.uj_type)
-    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. *)
-      (* We use nondeppat only if it's a Rel to preserve sharing. *)
-      if isRel nondeppat then
-        subst1 nondeppat j.uj_val
-      else subst1 deppat j.uj_val
-    else
-      (* The body of pat is not needed to type j but its value *)
-      (* is dependent in the type of j; our choice is to *)
-      (* enforce this dependency *)
-      mkLetIn (na,deppat,t,j.uj_val);
-    uj_type = subst1 deppat j.uj_type }
+let rec relocate_index n1 n2 k t = match kind_of_term t with
+  | Rel j when j = n1+k -> mkRel (n2+k)
+  | Rel j when j < n1+k -> t
+  | Rel j when j > n1+k -> t
+  | _ -> map_constr_with_binders succ (relocate_index n1 n2) k t
 
 (**********************************************************************)
 (* Structures used in compiling pattern-matching *)
@@ -178,29 +132,24 @@ type 'a equation =
 
 type 'a matrix = 'a equation list
 
-type dep_status = KnownDep | KnownNotDep | DepUnknown
-
 (* 1st argument of IsInd is the original ind before extracting the summary *)
 type tomatch_type =
   | IsInd of types * inductive_type * name list
   | NotInd of constr option * types
 
 type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list * (name * dep_status))
-  | Alias of (constr * constr * alias_constr * constr)
-  | Abstract of rel_declaration
+  | Pushed of ((constr * tomatch_type) * int list * name)
+  | Alias of (name * constr * (constr * types))
+  | NonDepAlias
+  | Abstract of int * rel_declaration
 
 type tomatch_stack = tomatch_status list
 
 (* We keep a constr for aliases and a cases_pattern for error message *)
 
-type alias_builder =
-  | AliasLeaf
-  | AliasConstructor of constructor
-
 type pattern_history =
   | Top
-  | MakeAlias of alias_builder * pattern_continuation
+  | MakeConstructor of constructor * pattern_continuation
 
 and pattern_continuation =
   | Continuation of int * cases_pattern list * pattern_history
@@ -218,51 +167,47 @@ let feed_history arg = function
 
 (* This is for non exhaustive error message *)
 
-let rec rawpattern_of_partial_history args2 = function
+let rec glob_pattern_of_partial_history args2 = function
   | Continuation (n, args1, h) ->
       let args3 = make_anonymous_patvars (n - (List.length args2)) in
-      build_rawpattern (List.rev_append args1 (args2@args3)) h
+      build_glob_pattern (List.rev_append args1 (args2@args3)) h
   | Result pl -> pl
 
-and build_rawpattern args = function
+and build_glob_pattern args = function
   | Top -> args
-  | MakeAlias (AliasLeaf, rh) ->
-      assert (args = []);
-      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
-  | MakeAlias (AliasConstructor pci, rh) ->
-      rawpattern_of_partial_history
+  | MakeConstructor (pci, rh) ->
+      glob_pattern_of_partial_history
 	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
 
-let complete_history = rawpattern_of_partial_history []
+let complete_history = glob_pattern_of_partial_history []
 
 (* This is to build glued pattern-matching history and alias bodies *)
 
-let rec simplify_history = function
-  | Continuation (0, l, Top) -> Result (List.rev l)
-  | Continuation (0, l, MakeAlias (f, rh)) ->
-      let pargs = List.rev l in
-      let pat = match f with
-	| AliasConstructor pci ->
-	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf ->
-	    assert (l = []);
-	    PatVar (dummy_loc, Anonymous) in
-      feed_history pat rh
-  | h -> h
+let rec pop_history_pattern = function
+  | Continuation (0, l, Top) ->
+      Result (List.rev l)
+  | Continuation (0, l, MakeConstructor (pci, rh)) ->
+      feed_history (PatCstr (dummy_loc,pci,List.rev l,Anonymous)) rh
+  | _ ->
+      anomaly "Constructor not yet filled with its arguments"
+
+let pop_history h =
+  feed_history (PatVar (dummy_loc, Anonymous)) h
 
 (* Builds a continuation expecting [n] arguments and building [ci] applied
    to this [n] arguments *)
 
-let push_history_pattern n current cont =
-  Continuation (n, [], MakeAlias (current, cont))
+let push_history_pattern n pci cont =
+  Continuation (n, [], MakeConstructor (pci, cont))
 
 (* A pattern-matching problem has the following form:
 
-   env, evd |- <pred> Cases tomatch of mat end
+   env, evd |- match terms_to_tomatch return pred with mat end
 
-  where tomatch is some sequence of "instructions" (t1  ... tn)
+  where terms_to_match is some sequence of "instructions" (t1 ... tp)
 
   and mat is some matrix
+
    (p11 ... p1n -> rhs1)
    (    ...            )
    (pm1 ... pmn -> rhsm)
@@ -270,16 +215,25 @@ let push_history_pattern n current cont =
   Terms to match: there are 3 kinds of instructions
 
   - "Pushed" terms to match are typed in [env]; these are usually just
-    Rel(n) except for the initial terms given by user and typed in [env]
-  - "Abstract" instructions means an abstraction has to be inserted in the
+    Rel(n) except for the initial terms given by user; in Pushed ((c,tm),deps,na),
+    [c] is the reference to the term (which is a Rel or an initial term), [tm] is
+    its type (telling whether we know if it is an inductive type or not),
+    [deps] is the list of terms to abstract before matching on [c] (these are
+    rels too)
+  - "Abstract" instructions mean that an abstraction has to be inserted in the
     current branch to build (this means a pattern has been detected dependent
-    in another one and generalisation is necessary to ensure well-typing)
-  - "Alias" instructions means an alias has to be inserted (this alias
+    in another one and a generalization is necessary to ensure well-typing)
+    Abstract instructions extend the [env] in which the other instructions
+    are typed
+  - "Alias" instructions mean an alias has to be inserted (this alias
     is usually removed at the end, except when its type is not the
     same as the type of the matched term from which it comes -
     typically because the inductive types are "real" parameters)
+  - "NonDepAlias" instructions mean the completion of a matching over
+    a term to match as for Alias but without inserting this alias
+    because there is no dependency in it
 
-  Right-hand-sides:
+  Right-hand sides:
 
   They consist of a raw term to type in an environment specific to the
   clause they belong to: the names of declarations are those of the
@@ -335,7 +289,7 @@ let inductive_template evdref env tmloc ind =
 	    let e = e_new_evar evdref env ~src:(hole_source n) ty' in
 	    (e::subst,e::evarl,n+1)
 	| Some b ->
-	    (b::subst,evarl,n+1))
+	    (substl subst b::subst,evarl,n+1))
       arsign ([],[],1) in
    applist (mkInd ind,List.rev evarl)
 
@@ -347,13 +301,24 @@ let try_find_ind env sigma typ realnames =
       | None -> list_make (List.length realargs) Anonymous in
   IsInd (typ,ind,names)
 
-
 let inh_coerce_to_ind evdref env ty tyi =
   let expected_typ = inductive_template evdref env None tyi in
      (* devrait être indifférent d'exiger leq ou pas puisque pour
         un inductif cela doit être égal *)
   let _ = e_cumul env evdref expected_typ ty in ()
 
+let binding_vars_of_inductive = function
+  | NotInd _ -> []
+  | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
+
+let extract_inductive_data env sigma (_,b,t) =
+  if b<>None then (NotInd (None,t),[]) else
+  let tmtyp =
+    try try_find_ind env sigma t None
+    with Not_found -> NotInd (None,t) in
+  let tmtypvars = binding_vars_of_inductive tmtyp in
+  (tmtyp,tmtypvars)
+
 let unify_tomatch_with_patterns evdref env loc typ pats realnames =
   match find_row_ind pats with
     | None -> NotInd (None,typ)
@@ -370,7 +335,7 @@ let find_tomatch_tycon evdref env loc = function
       empty_tycon,None
 
 let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
-  let loc = Some (loc_of_rawconstr tomatch) in
+  let loc = Some (loc_of_glob_constr tomatch) in
   let tycon,realnames = find_tomatch_tycon evdref env loc indopt in
   let j = typing_fun tycon env evdref tomatch in
   let typ = nf_evar !evdref j.uj_type in
@@ -466,6 +431,15 @@ let remove_current_pattern eqn =
 	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
     | [] -> anomaly "Empty list of patterns"
 
+let push_current_pattern (cur,ty) eqn =
+  match eqn.patterns with
+    | pat::pats ->
+        let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in
+	{ eqn with
+            rhs = { eqn.rhs with rhs_env = rhs_env };
+	    patterns = pats }
+    | [] -> anomaly "Empty list of patterns"
+
 let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
 
 (**********************************************************************)
@@ -540,7 +514,7 @@ let is_dep_patt_in eqn = function
   | PatVar (_,name) -> occur_in_rhs name eqn.rhs
   | PatCstr _ -> true
 
-let mk_dep_patt_row (pats,eqn) =
+let mk_dep_patt_row (pats,_,eqn) =
   List.map (is_dep_patt_in eqn) pats
 
 let dependencies_in_pure_rhs nargs eqns =
@@ -554,8 +528,8 @@ let dependent_decl a = function
   | (na,Some c,t) -> dependent a t || dependent a c
 
 let rec dep_in_tomatch n = function
-  | (Pushed _ | Alias _) :: l -> dep_in_tomatch n l
-  | Abstract d :: l -> dependent_decl (mkRel n) d or dep_in_tomatch (n+1) l
+  | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
+  | Abstract (_,d) :: l -> dependent_decl (mkRel n) d or dep_in_tomatch (n+1) l
   | [] -> false
 
 let dependencies_in_rhs nargs current tms eqns =
@@ -565,75 +539,90 @@ let dependencies_in_rhs nargs current tms eqns =
 
 (* Computing the matrix of dependencies *)
 
-(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
-   computes for declaration [k+1] in which of declarations in
-   [nextlist] (which corresponds to d(k+2)...dn) it depends;
-   declarations are expressed by index, e.g. in dependency list
-   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
+(* [find_dependency_list tmi [d(i+1);...;dn]] computes in which
+   declarations [d(i+1);...;dn] the term [tmi] is dependent in.
 
-let rec find_dependency_list k n = function
+   [find_dependencies_signature (used1,...,usedn) ((tm1,d1),...,(tmn,dn))]
+   returns [(deps1,...,depsn)] where [depsi] is a subset of n,..,i+1
+   denoting in which of the d(i+1)...dn, the term tmi is dependent.
+   Dependencies are expressed by index, e.g. in dependency list
+   [n-2;1], [1] points to [dn] and [n-2] to [d3]
+*)
+
+let rec find_dependency_list tmblock = function
   | [] -> []
   | (used,tdeps,d)::rest ->
-      let deps = find_dependency_list k (n+1) rest in
-      if used && dependent_decl (mkRel n) d
+      let deps = find_dependency_list tmblock rest in
+      if used && List.exists (fun x -> dependent_decl x d) tmblock
       then list_add_set (List.length rest + 1) (list_union deps tdeps)
       else deps
 
-let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
-  let deps = find_dependency_list k 1 nextlist in
+let find_dependencies is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist =
+  let deps = find_dependency_list (tm::tmtypleaves) nextlist in
   if is_dep_or_cstr_in_rhs || deps <> []
-  then (k-1,(true ,deps,d)::nextlist)
-  else (k-1,(false,[]  ,d)::nextlist)
+  then ((true ,deps,d)::nextlist)
+  else ((false,[]  ,d)::nextlist)
 
 let find_dependencies_signature deps_in_rhs typs =
-  let k = List.length deps_in_rhs in
-  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
+  let l = List.fold_right2 find_dependencies deps_in_rhs typs [] in
   List.map (fun (_,deps,_) -> deps) l
 
 (* Assume we had terms t1..tq to match in a context xp:Tp,...,x1:T1 |-
    and xn:Tn has just been regeneralized into x:Tn so that the terms
    to match are now to be considered in the context xp:Tp,...,x1:T1,x:Tn |-.
 
-   [regeneralize_index_tomatch n tomatch] updates t1..tq so that
-   former references to xn are now references to x. Note that t1..tq
-   are already adjusted to the context xp:Tp,...,x1:T1,x:Tn |-. *)
+   [relocate_index_tomatch n 1 tomatch] updates t1..tq so that
+   former references to xn1 are now references to x. Note that t1..tq
+   are already adjusted to the context xp:Tp,...,x1:T1,x:Tn |-.
+
+   [relocate_index_tomatch 1 n tomatch] will go the way back.
+ *)
 
-let regeneralize_index_tomatch n =
+let relocate_index_tomatch n1 n2 =
   let rec genrec depth = function
   | [] ->
       []
-  | Pushed ((c,tm),l,dep) :: rest ->
-      let c = regeneralize_index n depth c in
-      let tm = map_tomatch_type (regeneralize_index n depth) tm in
-      let l = List.map (regeneralize_rel n depth) l in
-      Pushed ((c,tm),l,dep) :: genrec depth rest
-  | Alias (c1,c2,d,t) :: rest ->
-      Alias (regeneralize_index n depth c1,c2,d,t) :: genrec depth rest
-  | Abstract d :: rest ->
-      Abstract (map_rel_declaration (regeneralize_index n depth) d)
+  | Pushed ((c,tm),l,na) :: rest ->
+      let c = relocate_index n1 n2 depth c in
+      let tm = map_tomatch_type (relocate_index n1 n2 depth) tm in
+      let l = List.map (relocate_rel n1 n2 depth) l in
+      Pushed ((c,tm),l,na) :: genrec depth rest
+  | Alias (na,c,d) :: rest ->
+      (* [c] is out of relocation scope *)
+      Alias (na,c,map_pair (relocate_index n1 n2 depth) d) :: genrec depth rest
+  | NonDepAlias :: rest ->
+      NonDepAlias :: genrec depth rest
+  | Abstract (i,d) :: rest ->
+      let i = relocate_rel n1 n2 depth i in
+      Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d)
       :: genrec (depth+1) rest in
   genrec 0
 
+(* [replace_tomatch n c tomatch] replaces [Rel n] by [c] in [tomatch] *)
+
 let rec replace_term n c k t =
-  if t = mkRel (n+k) then lift k c
+  if isRel t && destRel t = n+k then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
-let length_of_tomatch_type_sign (dep,_) = function
-  | NotInd _ -> if dep<>Anonymous then 1 else 0
-  | IsInd (_,_,names) -> List.length names + if dep<>Anonymous then 1 else 0
+let length_of_tomatch_type_sign na = function
+  | NotInd _ -> if na<>Anonymous then 1 else 0
+  | IsInd (_,_,names) -> List.length names + if na<>Anonymous then 1 else 0
 
 let replace_tomatch n c =
   let rec replrec depth = function
   | [] -> []
-  | Pushed ((b,tm),l,dep) :: rest ->
+  | Pushed ((b,tm),l,na) :: rest ->
       let b = replace_term n c depth b in
       let tm = map_tomatch_type (replace_term n c depth) tm in
       List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l,dep) :: replrec depth rest
-  | Alias (c1,c2,d,t) :: rest ->
-      Alias (replace_term n c depth c1,c2,d,t) :: replrec depth rest
-  | Abstract d :: rest ->
-      Abstract (map_rel_declaration (replace_term n c depth) d)
+      Pushed ((b,tm),l,na) :: replrec depth rest
+  | Alias (na,b,d) :: rest ->
+      (* [b] is out of replacement scope *)
+      Alias (na,b,map_pair (replace_term n c depth) d) :: replrec depth rest
+  | NonDepAlias  :: rest ->
+      NonDepAlias :: replrec depth rest
+  | Abstract (i,d) :: rest ->
+      Abstract (i,map_rel_declaration (replace_term n c depth) d)
       :: replrec (depth+1) rest in
   replrec 0
 
@@ -646,16 +635,19 @@ let replace_tomatch n c =
 
 let rec liftn_tomatch_stack n depth = function
   | [] -> []
-  | Pushed ((c,tm),l,dep)::rest ->
+  | Pushed ((c,tm),l,na)::rest ->
       let c = liftn n depth c in
       let tm = liftn_tomatch_type n depth tm in
       let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l,dep)::(liftn_tomatch_stack n depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
+      Pushed ((c,tm),l,na)::(liftn_tomatch_stack n depth rest)
+  | Alias (na,c,d)::rest ->
+      Alias (na,liftn n depth c,map_pair (liftn n depth) d)
       ::(liftn_tomatch_stack n depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (liftn n depth) d)
+  | NonDepAlias  :: rest ->
+      NonDepAlias :: liftn_tomatch_stack n depth rest
+  | Abstract (i,d)::rest ->
+      let i = if i<depth then i else i+n in
+      Abstract (i,map_rel_declaration (liftn n depth) d)
       ::(liftn_tomatch_stack n (depth+1) rest)
 
 let lift_tomatch_stack n = liftn_tomatch_stack n 1
@@ -675,8 +667,14 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1
    and [match y with (S (S n)) => n | n => n end] into
    [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
 
-  i.e. user names should be preserved and created names should not
-  interfere with user names *)
+   i.e. user names should be preserved and created names should not
+   interfere with user names
+
+   The exact names here are not important for typing (because they are
+   put in pb.env and not in the rhs.rhs_env of branches. However,
+   whether a name is Anonymous or not may have an effect on whether a
+   generalization is done or not.
+ *)
 
 let merge_name get_name obj = function
   | Anonymous -> get_name obj
@@ -687,15 +685,18 @@ 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,aliasname =
     List.fold_right
-      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
-      eqns names1 in
+      (fun (pats,pat_alias,eqn) (names,aliasname) ->
+        (merge_names alias_of_pat pats names,
+         merge_name (fun x -> x) pat_alias aliasname))
+      eqns (names1,Anonymous) in
   (* Otherwise, we take names from the parameters of the constructor but
      avoiding conflicts with user ids *)
   let allvars =
-    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
-  let names4,_ =
+    List.fold_left (fun l (_,_,eqn) -> list_union l eqn.rhs.avoid_ids)
+      [] eqns in
+  let names3,_ =
     List.fold_left2
       (fun (l,avoid) d na ->
 	 let na =
@@ -705,10 +706,18 @@ let get_names env sign eqns =
 	 in
          (na::l,(out_name na)::avoid))
       ([],allvars) (List.rev sign) names2 in
-  names4
+  names3,aliasname
 
-(************************************************************************)
+(*****************************************************************)
 (* Recovering names for variables pushed to the rhs' environment *)
+(* We just factorized a match over a matrix of equations         *)
+(* "C xi1 .. xin as xi" as a single match over "C y1 .. yn as y" *)
+(* We now replace the names y1 .. yn y by the actual names       *)
+(* xi1 .. xin xi to be found in the i-th clause of the matrix    *)
+
+let set_declaration_name x (_,c,t) = (x,c,t)
+
+let recover_initial_subpattern_names = List.map2 set_declaration_name
 
 let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
 
@@ -716,68 +725,28 @@ let push_rels_eqn sign eqn =
   {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env} }
 
 let push_rels_eqn_with_names sign eqn =
-  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
-  let sign = recover_alias_names alias_of_pat pats sign in
+  let subpats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+  let subpatnames = List.map alias_of_pat subpats in
+  let sign = recover_initial_subpattern_names subpatnames sign in
   push_rels_eqn sign eqn
 
-let build_aliases_context env sigma names allpats pats =
-  (* pats is the list of bodies to push as an alias *)
-  (* They all are defined in env and we turn them into a sign *)
-  (* cuts in sign need to be done in allpats *)
-  let rec insert env sign1 sign2 n newallpats oldallpats = function
-    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
-        (* Anonymous leaves must be considered named and treated in the *)
-        (* next clause because they may occur in implicit arguments *)
-	insert env sign1 sign2
-	  n newallpats (List.map List.tl oldallpats) (pats,names)
-    | (deppat,nondeppat,d,t)::pats, na::names ->
-	let nondeppat = lift n nondeppat in
-	let deppat = lift n deppat in
-	let newallpats =
-	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
-	let oldallpats = List.map List.tl oldallpats in
-	let decl = (na,Some deppat,t) in
-	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
-	  newallpats oldallpats (pats,names)
-    | [], [] -> newallpats, sign1, sign2, env
-    | _ -> anomaly "Inconsistent alias and name lists" in
-  let allpats = List.map (fun x -> [x]) allpats
-  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
-
-let insert_aliases_eqn sign eqnnames alias_rest eqn =
-  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
-  { eqn with
-      alias_stack = alias_rest;
-      rhs = {eqn.rhs with rhs_env = push_rels thissign eqn.rhs.rhs_env } }
-
-let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
-  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
-  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
-  (* name2 takes the meet of all needed aliases *)
-  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 =
-    build_aliases_context env sigma [name2] eqnsnames [alias] in
-  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
-  sign2, env, eqns
+let push_generalized_decl_eqn env n (na,c,t) eqn =
+  let na = match na with
+  | Anonymous -> Anonymous
+  | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in
+  push_rels_eqn [(na,c,t)] eqn
 
-(**********************************************************************)
-(* Functions to deal with elimination predicate *)
+let drop_alias_eqn eqn =
+  { eqn with alias_stack = List.tl eqn.alias_stack }
 
-exception Occur
-let noccur_between_without_evar n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p       -> if n<=p && p<n+m then raise Occur
-    | Evar (_,cl) -> ()
-    | _             -> iter_constr_with_binders succ occur_rec n c
-  in
-  (m = 0) or (try occur_rec n term; true with Occur -> false)
+let push_alias_eqn alias eqn =
+  let aliasname = List.hd eqn.alias_stack in
+  let eqn = drop_alias_eqn eqn in
+  let alias = set_declaration_name aliasname alias in
+  push_rels_eqn [alias] eqn
 
+(**********************************************************************)
+(* Functions to deal with elimination predicate *)
 
 (* Infering the predicate *)
 (*
@@ -797,8 +766,8 @@ Assume the types in the branches are the following
 
 Assume the type of the global case expression is Gamma |- T
 
-The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
-the following n+1 equations:
+The predicate has the form phi = [y1..yq][z:I(y1..yq)]psi and it has to
+satisfy the following n+1 equations:
 
   Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
    ...
@@ -808,11 +777,11 @@ the following n+1 equations:
 Some hints:
 
 - Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi)
-  => ..."  or a "psi(yk)", with psi extracting xij from uik, should be
+  => ... end"  or a "psi(yk)", with psi extracting xij from uik, should be
   inserted somewhere in Ti.
 
-- If T is undefined, an easy solution is to insert a "match z with (Ci
-  xi1..xipi) => ..." in front of each Ti
+- If T is undefined, an easy solution is to insert a "match z with
+  (Ci xi1..xipi) => ... end" in front of each Ti
 
 - Otherwise, T1..Tn and T must be step by step unified, if some of them
   diverge, then try to replace the diverging subterm by one of y1..yq or z.
@@ -825,10 +794,10 @@ Some hints:
 
 let rec map_predicate f k ccl = function
   | [] -> f k ccl
-  | Pushed ((_,tm),_,dep) :: rest ->
-      let k' = length_of_tomatch_type_sign dep tm in
+  | Pushed ((_,tm),_,na) :: rest ->
+      let k' = length_of_tomatch_type_sign na tm in
       map_predicate f (k+k') ccl rest
-  | Alias _ :: rest ->
+  | (Alias _ | NonDepAlias) :: rest ->
       map_predicate f k ccl rest
   | Abstract _ :: rest ->
       map_predicate f (k+1) ccl rest
@@ -839,7 +808,7 @@ let liftn_predicate n = map_predicate (liftn n)
 
 let lift_predicate n = liftn_predicate n 1
 
-let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
+let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0
 
 let substnl_predicate sigma = map_predicate (substnl sigma)
 
@@ -867,55 +836,74 @@ let specialize_predicate_var (cur,typ,dep) tms ccl =
 (* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
 (* then we have to replace x by x' in t(x) and y by y' in P                  *)
 (*****************************************************************************)
-let generalize_predicate (names,(nadep,_)) ny d tms ccl =
-  if nadep=Anonymous then anomaly "Undetected dependency";
+let generalize_predicate (names,na) ny d tms ccl =
+  if na=Anonymous then anomaly "Undetected dependency";
   let p = List.length names + 1 in
   let ccl = lift_predicate 1 ccl tms in
   regeneralize_index_predicate (ny+p+1) ccl tms
 
+(*****************************************************************************)
+(* We just matched over cur:ind(realargs) in the following matching problem  *)
+(*                                                                           *)
+(*   env |- match cur tms return ccl with ... end                            *)
+(*                                                                           *)
+(* and we want to build the predicate corresponding to the individual        *)
+(* matching over cur                                                         *)
+(*                                                                           *)
+(*    pred = fun X:realargstyps x:ind(X)] PI tms.ccl                         *)
+(*                                                                           *)
+(* where pred is computed by abstract_predicate and PI tms.ccl by            *)
+(* extract_predicate                                                         *)
+(*****************************************************************************)
 let rec extract_predicate ccl = function
-   | Alias (deppat,nondeppat,_,_)::tms ->
-       (* substitution already done in build_branch *)
+  | (Alias _ | NonDepAlias)::tms ->
+      (* substitution already done in build_branch *)
       extract_predicate ccl tms
-  | Abstract d::tms ->
-      mkProd_or_LetIn d (extract_predicate ccl tms)
-  | Pushed ((cur,NotInd _),_,(dep,_))::tms ->
-      let tms = if dep<>Anonymous then lift_tomatch_stack 1 tms else tms in
+  | Abstract (i,d)::tms ->
+      mkProd_wo_LetIn d (extract_predicate ccl tms)
+  | Pushed ((cur,NotInd _),_,na)::tms ->
+      let tms = if na<>Anonymous then lift_tomatch_stack 1 tms else tms in
       let pred = extract_predicate ccl tms in
-      if dep<>Anonymous then subst1 cur pred else pred
-  | Pushed ((cur,IsInd (_,IndType(_,realargs),_)),_,(dep,_))::tms ->
+      if na<>Anonymous then subst1 cur pred else pred
+  | Pushed ((cur,IsInd (_,IndType(_,realargs),_)),_,na)::tms ->
       let realargs = List.rev realargs in
-      let k = if dep<>Anonymous then 1 else 0 in
+      let k = if na<>Anonymous then 1 else 0 in
       let tms = lift_tomatch_stack (List.length realargs + k) tms in
       let pred = extract_predicate ccl tms in
-      substl (if dep<>Anonymous then cur::realargs else realargs) pred
+      substl (if na<>Anonymous then cur::realargs else realargs) pred
   | [] ->
       ccl
 
-let abstract_predicate env sigma indf cur (names,(nadep,_)) tms ccl =
+let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
   let sign = make_arity_signature env true indf in
-  (* n is the number of real args + 1 *)
+  (* n is the number of real args + 1 (+ possible let-ins in sign) *)
   let n = List.length sign in
-  let tms = lift_tomatch_stack n tms in
-  let tms =
-    match kind_of_term cur with
-      | Rel i -> regeneralize_index_tomatch (i+n) tms
-      | _ -> (* Initial case *) tms in
-  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
+  (* Before abstracting we generalize over cur and on those realargs *)
+  (* that are rels, consistently with the specialization made in     *)
+  (* build_branch                                                    *)
+  let tms = List.fold_right2 (fun par arg tomatch ->
+    match kind_of_term par with
+    | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch
+    | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign)
+       (lift_tomatch_stack n tms) in
+  (* Pred is already dependent in the current term to match (if      *)
+  (* (na<>Anonymous) and its realargs; we just need to adjust it to  *)
+  (* full sign if dep in cur is not taken into account               *)
+  let ccl = if na <> Anonymous then ccl else lift_predicate 1 ccl tms in
   let pred = extract_predicate ccl tms in
+  (* Build the predicate properly speaking *)
+  let sign = List.map2 set_declaration_name (na::names) sign in
   it_mkLambda_or_LetIn_name env pred sign
 
-let known_dependent (_,dep) = (dep = KnownDep)
-
 (* [expand_arg] is used by [specialize_predicate]
-   it replaces gamma, x1...xn, x1...xk |- pred
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
+   if Yk denotes [Xk;xk] or [Xk],
+   it replaces gamma, x1...xn, x1...xk Yk+1...Yn |- pred
+   by gamma, x1...xn, x1...xk-1 [Xk;xk] Yk+1...Yn |- pred (if dep) or
+   by gamma, x1...xn, x1...xk-1 [Xk] Yk+1...Yn |- pred (if not dep) *)
 
-let expand_arg tms ccl ((_,t),_,na) =
+let expand_arg tms (p,ccl) ((_,t),_,na) =
   let k = length_of_tomatch_type_sign na t in
-  lift_predicate (k-1) ccl tms
+  (p+k,liftn_predicate (k-1) (p+1) ccl tms)
 
 let adjust_impossible_cases pb pred tomatch submat =
   if submat = [] then
@@ -926,7 +914,7 @@ let adjust_impossible_cases pb pred tomatch submat =
       (* 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
+	map_succeed (function Alias _ | NonDepAlias -> Anonymous | _ -> failwith"") tomatch
       in
       [ { patterns = pats;
           rhs = { rhs_env = pb.env;
@@ -942,71 +930,132 @@ let adjust_impossible_cases pb pred tomatch submat =
     submat
 
 (*****************************************************************************)
-(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
+(* Let  pred = PI [X;x:I(X)]. PI tms. P  be a typing predicate for the       *)
+(* following pattern-matching problem:                                       *)
 (*                                                                           *)
-(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
+(*  Gamma |- match Pushed(c:I(V)) as x in I(X), tms return pred with...end   *)
 (*                                                                           *)
 (* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
-(* is considered. Assume each Ti is some Ii(argsi).                          *)
-(* We let e=Ci(x1,...,xn) and replace pred by                                *)
+(* is considered. Assume each Ti is some Ii(argsi) with Ti:PI Ui. sort_i     *)
+(* We let subst = X:=realargsi;x:=Ci(x1,...,xn) and replace pred by          *)
 (*                                                                           *)
-(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
+(* pred' = PI [X1:Ui;x1:I1(X1)]...[Xn:Un;xn:In(Xn)]. (PI tms. P)[subst]      *)
 (*                                                                           *)
-(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
+(* s.t. the following well-typed sub-pattern-matching problem is obtained    *)
+(*                                                                           *)
+(* Gamma,x'1..x'n |-                                                         *)
+(*   match                                                                   *)
+(*      Pushed(x'1) as x1 in I(X1),                                          *)
+(*      ..,                                                                  *)
+(*      Pushed(x'n) as xn in I(Xn),                                          *)
+(*      tms                                                                  *)
+(*      return pred'                                                         *)
+(*   with .. end                                                             *)
 (*                                                                           *)
 (*****************************************************************************)
-let specialize_predicate newtomatchs (names,(depna,_)) arsign cs tms ccl =
-  (* Assume some gamma st: gamma, (X,x:=realargs,copt), tms |- ccl *)
+let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
+  (* Assume some gamma st: gamma |- PI [X,x:I(X)]. PI tms. ccl *)
   let nrealargs = List.length names in
   let k = nrealargs + (if depna<>Anonymous then 1 else 0) in
-  (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt), tms |- ccl' *)
+  (* We adjust pred st: gamma, x1..xn |- PI [X,x:I(X)]. PI tms. ccl' *)
+  (* so that x can later be instantiated by Ci(x1..xn) *)
+  (* and X by the realargs for Ci *)
   let n = cs.cs_nargs in
   let ccl' = liftn_predicate n (k+1) ccl tms in
-  let argsi =
+  (* We prepare the substitution of X and x:I(X) *)
+  let realargsi =
     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'' *)
+  let copti =
+    if depna<>Anonymous then Some (build_dependent_constructor cs) else None in
+  (* The substituends realargsi, copti are all defined in gamma, x1...xn *)
+  (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *)
+  (* Note: applying the substitution in tms is not important (is it sure?) *)
   let ccl'' =
-    whd_betaiota Evd.empty (subst_predicate (argsi, copti) ccl' tms) in
-  (* We adjust ccl st: gamma, x1..xn, x1..xn, tms |- ccl'' *)
+    whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in
+  (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *)
   let ccl''' = liftn_predicate n (n+1) ccl'' tms in
-  (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
-  List.fold_left (expand_arg tms) ccl''' newtomatchs
+  (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*)
+  snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs)
 
 let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms =
-  let pred= abstract_predicate env !evdref indf current dep tms p in
+  let pred = abstract_predicate env !evdref indf current realargs dep tms p in
   (pred, whd_betaiota !evdref
-           (applist (pred, realargs@[current])), new_Type ())
+           (applist (pred, realargs@[current])))
 
 (* Take into account that a type has been discovered to be inductive, leading
    to more dependencies in the predicate if the type has indices *)
 let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb =
-  let ((_,oldtyp),deps,((nadep,_) as dep)) = tomatch in
+  let ((_,oldtyp),deps,na) = tomatch in
   match typ, oldtyp with
   | IsInd (_,_,names), NotInd _ ->
-      let k = if nadep <> Anonymous then 2 else 1 in
+      let k = if na <> Anonymous then 2 else 1 in
       let n = List.length names in
       { pb with pred = liftn_predicate n k pb.pred pb.tomatch },
-      (ct,List.map (fun i -> if i >= k then i+n else i) deps,dep)
+      (ct,List.map (fun i -> if i >= k then i+n else i) deps,na)
   | _ ->
-      pb, (ct,deps,dep)
+      pb, (ct,deps,na)
+
+(* Remove commutative cuts that turn out to be non-dependent after
+   some evars have been instantiated *)
+
+let rec ungeneralize n ng body =
+  match kind_of_term body with
+  | Lambda (_,_,c) when ng = 0 ->
+      subst1 (mkRel n) c
+  | Lambda (na,t,c) ->
+      (* We traverse an inner generalization *)
+      mkLambda (na,t,ungeneralize (n+1) (ng-1) c)
+  | LetIn (na,b,t,c) ->
+      (* We traverse an alias *)
+      mkLetIn (na,b,t,ungeneralize (n+1) ng c)
+  | Case (ci,p,c,brs) ->
+      (* We traverse a split *)
+      let p =
+        let sign,p = decompose_lam_assum p in
+        let sign2,p = decompose_prod_n_assum ng p in
+        let p = prod_applist p [mkRel (n+List.length sign+ng)] in
+        it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in
+      mkCase (ci,p,c,array_map2 (fun q c ->
+        let sign,b = decompose_lam_n_assum q c in
+        it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign)
+        ci.ci_cstr_ndecls brs)
+  | App (f,args) ->
+      (* We traverse an inner generalization *)
+      assert (isCase f);
+      mkApp (ungeneralize n (ng+Array.length args) f,args)
+  | _ -> assert false
+
+let ungeneralize_branch n k (sign,body) cs =
+  (sign,ungeneralize (n+cs.cs_nargs) k body)
+
+let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
+  let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
+  | [], _ -> brs,tomatch,pred,[]
+  | n::deps, Abstract (i,d) :: tomatch ->
+      let d = map_rel_declaration (nf_evar evd) d in
+      if List.exists (fun c -> dependent_decl (lift k c) d) tocheck || pi2 d <> None then
+        (* Dependency in the current term to match and its dependencies is real *)
+        let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in
+        let inst = if pi2 d = None then mkRel n::inst else inst in
+        brs, Abstract (i,d) :: tomatch, pred, inst
+      else
+        (* Finally, no dependency remains, so, we can replace the generalized *)
+        (* terms by its actual value in both the remaining terms to match and *)
+        (* the bodies of the Case *)
+        let pred = lift_predicate (-1) pred tomatch in
+        let tomatch = relocate_index_tomatch 1 (n+1) tomatch in
+        let tomatch = lift_tomatch_stack (-1) tomatch in
+        let brs = array_map2 (ungeneralize_branch n k) brs cs in
+        aux k brs tomatch pred tocheck deps
+  | _ -> assert false
+  in aux 0 brs tomatch pred tocheck deps
 
 (************************************************************************)
 (* Sorting equations by constructor *)
 
-type inversion_problem =
-  (* the discriminating arg in some Ind and its order in Ind *)
-  | Incompatible of int * (int * int)
-  | Constraints of (int * constr) list
-
-let solve_constraints constr_info indt =
-  (* TODO *)
-  Constraints []
-
 let rec irrefutable env = function
   | PatVar (_,name) -> true
   | PatCstr (_,cstr,args,_) ->
@@ -1034,12 +1083,12 @@ let group_equations pb ind current cstrs mat =
 	       (* 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
-		 brs.(i-1) <- (args, rest) :: brs.(i-1)
+		 brs.(i-1) <- (args, name, rest) :: brs.(i-1)
 	       done
-	   | PatCstr (loc,((_,i)),args,_) ->
+	   | PatCstr (loc,((_,i)),args,name) ->
 	       (* This is a regular clause *)
 	       only_default := false;
-	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
+	       brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in
   (brs,!only_default)
 
 (************************************************************************)
@@ -1047,16 +1096,18 @@ let group_equations pb ind current cstrs mat =
 
 (* Abstracting over dependent subterms to match *)
 let rec generalize_problem names pb = function
-  | [] -> pb
+  | [] -> pb, []
   | i::l ->
-      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let pb',deps = generalize_problem names pb l in
+      if na = Anonymous & b <> None then pb',deps else
       let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
-      let 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
+      let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
       { pb' with
-	  tomatch = Abstract d :: tomatch;
-          pred = generalize_predicate names i d pb.tomatch pb'.pred  }
+	  tomatch = Abstract (i,d) :: tomatch;
+          pred = generalize_predicate names i d pb'.tomatch pb'.pred  },
+      i::deps
 
 (* No more patterns: typing the right-hand side of equations *)
 let build_leaf pb =
@@ -1064,87 +1115,92 @@ let build_leaf pb =
   let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in
   j_nf_evar !(pb.evdref) j
 
-(* Building the sub-problem when all patterns are variables *)
-let shift_problem ((current,t),_,(nadep,_)) pb =
-  {pb with
-     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = specialize_predicate_var (current,t,nadep) pb.tomatch pb.pred;
-     history = push_history_pattern 0 AliasLeaf pb.history;
-     mat = List.map remove_current_pattern pb.mat }
-
-(* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps (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
-      DepAlias
-  in
+(* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *)
+let build_branch current realargs deps (realnames,curname) pb arsign eqns const_info =
+  (* We remember that we descend through constructor C *)
   let history =
-    push_history_pattern const_info.cs_nargs
-      (AliasConstructor const_info.cs_cstr)
-      pb.history in
+    push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in
 
-  (* We find matching clauses *)
+  (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *)
+  (* build the name x1..xn from the names present in the equations *)
+  (* that had matched constructor C *)
   let cs_args = const_info.cs_args in
-  let names = get_names pb.env cs_args eqns in
-  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
+  let names,aliasname = get_names pb.env cs_args eqns in
   let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
 
+  (* We build the matrix obtained by expanding the matching on *)
+  (* "C x1..xn as x" followed by a residual matching on eqn into *)
+  (* a matching on "x1 .. xn eqn" *)
+  let submat = List.map (fun (tms,_,eqn) -> prepend_pattern tms eqn) eqns in
+
+  (* We adjust the terms to match in the context they will be once the *)
+  (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
+  let typs' =
+    list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
+
+  let extenv = push_rels typs pb.env in
+
+  let typs' =
+    List.map (fun (c,d) ->
+      (c,extract_inductive_data extenv !(pb.evdref) d,d)) typs' in
+
+  (* We compute over which of x(i+1)..xn and x matching on xi will need a *)
+  (* generalization *)
   let dep_sign =
     find_dependencies_signature
       (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns)
-      (List.rev typs) in
+      (List.rev typs') in
 
   (* The dependent term to subst in the types of the remaining UnPushed
      terms is relative to the current context enriched by topushs *)
   let ci = build_dependent_constructor const_info in
 
-  (* We replace [(mkRel 1)] by its expansion [ci] *)
-  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
-  (* This is done in two steps : first from "Gamma |- tms" *)
-  (* into  "Gamma; typs; curalias |- tms" *)
-  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
+  (* Current context Gamma has the form Gamma1;cur:I(realargs);Gamma2 *)
+  (* We go from Gamma |- PI tms. pred to                              *)
+  (* Gamma;x1..xn;curalias:I(x1..xn) |- PI tms'. pred'                *)
+  (* where, in tms and pred, those realargs that are vars are         *)
+  (* replaced by the corresponding xi and cur replaced by curalias    *)
+  let cirealargs = Array.to_list const_info.cs_concl_realargs in
 
-  let tomatch = match kind_of_term current with
-    | Rel i -> replace_tomatch (i+const_info.cs_nargs) ci tomatch
-    | _ -> (* non-rel initial term *) tomatch in
+  (* Do the specialization for terms to match *)
+  let tomatch = List.fold_right2 (fun par arg tomatch ->
+    match kind_of_term par with
+    | Rel i -> replace_tomatch (i+const_info.cs_nargs) arg tomatch
+    | _ -> tomatch) (current::realargs) (ci::cirealargs)
+      (lift_tomatch_stack const_info.cs_nargs pb.tomatch) in
 
   let pred_is_not_dep =
     noccur_predicate_between 1 (List.length realnames + 1) pb.pred tomatch in
 
   let typs' =
-    list_map2_i
-      (fun i d deps ->
-        let (na,c,t) = map_rel_declaration (lift i) d in
-	let dep = match dep with
-	  | Name _ as na',k -> (if na <> Anonymous then na else na'),k
-	  | Anonymous,KnownNotDep ->
-	      if deps = [] && pred_is_not_dep then
-		(Anonymous,KnownNotDep)
-	      else
-		(force_name na,KnownDep)
-	  | _,_ -> anomaly "Inconsistent dependency" in
-	((mkRel i, NotInd (c,t)),deps,dep))
-      1 typs (List.rev dep_sign) in
-
+    List.map2
+      (fun (tm,(tmtyp,_),(na,_,_)) deps ->
+	let na = match curname with
+	| Name _ -> (if na <> Anonymous then na else curname)
+	| Anonymous ->
+	    if deps = [] && pred_is_not_dep then Anonymous else force_name na in
+	((tm,tmtyp),deps,na))
+      typs' (List.rev dep_sign) in
+
+  (* Do the specialization for the predicate *)
   let pred =
-    specialize_predicate typs' (realnames,dep) arsign const_info tomatch pb.pred in
+    specialize_predicate typs' (realnames,curname) arsign const_info tomatch pb.pred in
 
   let currents = List.map (fun x -> Pushed x) typs' in
 
-  let ind =
-    appvect (
-      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
-      List.map (lift const_info.cs_nargs) const_info.cs_params),
-      const_info.cs_concl_realargs) in
+  let alias =
+    if aliasname = Anonymous then
+      NonDepAlias
+    else
+      let cur_alias = lift const_info.cs_nargs current in
+      let ind =
+        appvect (
+          applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+                   List.map (lift const_info.cs_nargs) const_info.cs_params),
+          const_info.cs_concl_realargs) in
+      Alias (aliasname,cur_alias,(ci,ind)) in
 
-  let cur_alias = lift (List.length typs) current in
-  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
-  let tomatch = List.rev_append currents tomatch in
+  let tomatch = List.rev_append (alias :: currents) tomatch in
 
   let submat = adjust_impossible_cases pb pred tomatch submat in
   if submat = [] then
@@ -1153,7 +1209,7 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info =
 
   typs,
   { pb with
-      env = push_rels typs pb.env;
+      env = extenv;
       tomatch = tomatch;
       pred = pred;
       history = history;
@@ -1162,11 +1218,11 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info =
 (**********************************************************************
  INVARIANT:
 
-  pb = { env, subst, tomatch, mat, ...}
-  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
+  pb = { env, pred, tomatch, mat, ...}
+  tomatch = list of Pushed (c:T), Abstract (na:T), Alias (c:T) or NonDepAlias
 
-  "Pushed" terms and types are relative to env
-  "Abstract" types are relative to env enriched by the previous terms to match
+  all terms and types in Pushed, Abstract and Alias are relative to env
+  enriched by the Abstract coming before
 
 *)
 
@@ -1174,9 +1230,10 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info =
 (* Main compiling descent *)
 let rec compile pb =
   match pb.tomatch with
-    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
-    | (Alias x)::rest -> compile_alias pb x rest
-    | (Abstract d)::rest -> compile_generalization pb d rest
+    | Pushed cur :: rest -> match_current { pb with tomatch = rest } cur
+    | Alias x :: rest -> compile_alias pb x rest
+    | NonDepAlias :: rest -> compile_non_dep_alias pb rest
+    | Abstract (i,d) :: rest -> compile_generalization pb i d rest
     | [] -> build_leaf pb
 
 (* Case splitting *)
@@ -1187,63 +1244,108 @@ and match_current pb tomatch =
   match typ with
     | NotInd (_,typ) ->
 	check_all_variables typ pb.mat;
-	compile (shift_problem tomatch pb)
+	shift_problem tomatch pb
     | 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 tomatch pb)
+	  shift_problem tomatch pb
 	else
-          let _constraints = Array.map (solve_constraints indt) cstrs in
-
 	  (* We generalize over terms depending on current term to match *)
-	  let pb = generalize_problem (names,dep) pb deps in
+	  let pb,deps = generalize_problem (names,dep) pb deps in
 
 	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current (names,dep) deps pb arsign) eqns cstrs in
-
+	  let brvals = array_map2 (compile_branch current realargs (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) =
+          let depstocheck = current::binding_vars_of_inductive typ in
+          let brvals,tomatch,pred,inst =
+            postprocess_dependencies !(pb.evdref) depstocheck
+              brvals pb.tomatch pb.pred deps cstrs in
+          let brvals = Array.map (fun (sign,body) ->
+            it_mkLambda_or_LetIn body sign) brvals in
+	  let (pred,typ) =
 	    find_predicate pb.caseloc pb.env pb.evdref
-	      pb.pred current indt (names,dep) pb.tomatch in
+	      pred current indt (names,dep) tomatch in
 	  let ci = make_case_info pb.env mind pb.casestyle in
-	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
-	  let inst = List.map mkRel deps in
+	  let pred = nf_betaiota !(pb.evdref) pred in
+	  let case = mkCase (ci,pred,current,brvals) in
+	  Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred;
 	  { uj_val = applist (case, inst);
 	    uj_type = prod_applist typ inst }
 
-and compile_branch current names deps pb arsign eqn cstr =
-  let sign, pb = build_branch current deps names pb arsign eqn cstr in
+(* Building the sub-problem when all patterns are variables *)
+and shift_problem ((current,t),_,na) pb =
+  let ty = type_of_tomatch t in
+  let tomatch = lift_tomatch_stack 1 pb.tomatch in
+  let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
+  let pb =
+    { pb with
+       env = push_rel (na,Some current,ty) pb.env;
+       tomatch = tomatch;
+       pred = lift_predicate 1 pred tomatch;
+       history = pop_history pb.history;
+       mat = List.map (push_current_pattern (current,ty)) pb.mat } in
   let j = compile pb in
-  (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+  { uj_val = subst1 current j.uj_val;
+    uj_type = subst1 current j.uj_type }
 
-and compile_generalization pb d rest =
+(* Building the sub-problem when all patterns are variables *)
+and compile_branch current realargs names deps pb arsign eqns cstr =
+  let sign, pb = build_branch current realargs deps names pb arsign eqns cstr in
+  sign, (compile pb).uj_val
+
+(* Abstract over a declaration before continuing splitting *)
+and compile_generalization pb i d rest =
   let pb =
     { pb with
        env = push_rel d pb.env;
        tomatch = rest;
-       mat = List.map (push_rels_eqn [d]) pb.mat } in
+       mat = List.map (push_generalized_decl_eqn pb.env i d) pb.mat } in
   let j = compile pb in
   { uj_val = mkLambda_or_LetIn d j.uj_val;
-    uj_type = mkProd_or_LetIn d j.uj_type }
+    uj_type = mkProd_wo_LetIn d j.uj_type }
 
-and compile_alias pb aliases rest =
-  let history = simplify_history pb.history in
-  let sign, newenv, mat = insert_aliases pb.env !(pb.evdref) aliases pb.mat in
-  let n = List.length sign in
-  let tomatch = lift_tomatch_stack n rest in
+and compile_alias pb (na,orig,(expanded,expanded_typ)) rest =
+  let f c t =
+    let alias = (na,Some c,t) in
+    let pb =
+      { pb with
+         env = push_rel alias pb.env;
+         tomatch = lift_tomatch_stack 1 rest;
+         pred = lift_predicate 1 pb.pred pb.tomatch;
+         history = pop_history_pattern pb.history;
+         mat = List.map (push_alias_eqn alias) pb.mat } in
+    let j = compile pb in
+    { uj_val =
+        if isRel c || isVar c || count_occurrences (mkRel 1) j.uj_val <= 1 then
+          subst1 c j.uj_val
+        else
+          mkLetIn (na,c,t,j.uj_val);
+      uj_type = subst1 c j.uj_type } in
+  if isRel orig or isVar orig then
+    (* Try to compile first using non expanded alias *)
+    try f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+    with e when precatchable_exception e ->
+    (* Try then to compile using expanded alias *)
+    f expanded expanded_typ
+  else
+    (* Try to compile first using expanded alias *)
+    try f expanded expanded_typ
+    with e when precatchable_exception e ->
+    (* Try then to compile using non expanded alias *)
+    f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+
+
+(* Remember that a non-trivial pattern has been consumed *)
+and compile_non_dep_alias pb rest =
   let pb =
-    {pb with
-       env = newenv;
-       tomatch = tomatch;
-       pred = lift_predicate n pb.pred tomatch;
-       history = history;
-       mat = mat } in
-  let j = compile pb in
-  List.fold_left mkSpecialLetInJudge j sign
+    { pb with
+       tomatch = rest;
+       history = pop_history_pattern pb.history;
+       mat = List.map drop_alias_eqn pb.mat } in
+  compile pb
 
 (* pour les alias des initiaux, enrichir les env de ce qu'il faut et
 substituer après par les initiaux *)
@@ -1260,7 +1362,7 @@ let matx_of_eqns env tomatchl eqns =
     let initial_rhs = rhs in
     let rhs =
       { rhs_env = env;
-        rhs_vars = free_rawvars initial_rhs;
+        rhs_vars = free_glob_vars initial_rhs;
 	avoid_ids = ids@(ids_of_named_context (named_context env));
 	it = Some initial_rhs } in
     { patterns = initial_lpat;
@@ -1273,7 +1375,7 @@ let matx_of_eqns env tomatchl eqns =
 (***************** Building an inversion predicate ************************)
 
 (* Let "match t1 in I1 u11..u1n_1 ... tm in Im um1..umn_m with ... end : T"
-   be a pattern-matching problem. We assume that the each uij can be
+   be a pattern-matching problem. We assume that each uij can be
    decomposed under the form pij(vij1..vijq_ij) where pij(aij1..aijq_ij)
    is a pattern depending on some variables aijk and the vijk are
    instances of these variables.  We also assume that each ti has the
@@ -1314,26 +1416,23 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
     (* \--env-/          (= x:ty)         *)
     (* \--------------extenv------------/ *)
     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 extenv)
-      | None ->
-	  (n,ty) 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
-      (p,u,(expand_vars_in_term extenv u,lift p ty))
-    else
-      failwith "") subst in
+    let rec traverse_local_defs p =
+      match pi2 (lookup_rel p extenv) with
+      | Some c -> assert (isRel c); traverse_local_defs (p + destRel c)
+      | None -> p in
+    let p = traverse_local_defs p in
+    let u = lift (n'-n) u in
+    (p,u,expand_vars_in_term extenv u)) subst in
   let t0 = lift (n'-n) t in
   (subst0,t0)
 
 let push_binder d (k,env,subst) =
   (k+1,push_rel d env,List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst)
 
+let rec list_assoc_in_triple x = function
+    [] -> raise Not_found
+  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l
+
 (* 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.
@@ -1359,46 +1458,62 @@ 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 t = whd_evar !evdref t in match kind_of_term t with
+    | Rel n when pi2 (lookup_rel n env) <> None ->
+        map_constr_with_full_binders push_binder aux x t
+    | Evar ev ->
+        let ty = get_type_of env sigma t in
+        let inst =
+	  list_map_i
+	    (fun i _ ->
+              try list_assoc_in_triple i subst0 with Not_found -> mkRel i)
+              1 (rel_context env) in
+        let ev = e_new_evar evdref env ~src:(loc, CasesType) ty in
+        evdref := add_conv_pb (Reduction.CONV,env,substl inst ev,t) !evdref;
+        ev
+    | _ ->
     let 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 u = pi3 (List.hd good) in (* u is in extenv *)
       let vl = List.map pi1 good in
+      let ty = lift (-k) (aux x (get_type_of env !evdref t)) in
+      let depvl = free_rels ty in
       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 =
-	List.map (fun a -> not (isRel a) or dependent a u) inst in
+	List.map (fun a -> not (isRel a) || dependent a u
+                           || Intset.mem (destRel a) depvl) inst in
       let named_filter =
 	List.map (fun (id,_,_) -> dependent (mkVar id) u)
 	  (named_context extenv) in
       let filter = rel_filter@named_filter in
+      let candidates = u :: List.map mkRel vl in
       let ev =
-	e_new_evar evdref extenv ~src:(loc, CasesType) ~filter:filter ty in
-      evdref := add_conv_pb (Reduction.CONV,extenv,substl inst ev,u) !evdref;
+	e_new_evar evdref extenv ~src:(loc, CasesType) ~filter ~candidates ty in
       lift k ev
     else
       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
+  let t,tt = match t with
     | None ->
 	(* This is the situation we are building a return predicate and
            we are in an impossible branch *)
 	let n = rel_context_length (rel_context env) in
 	let n' = rel_context_length (rel_context tycon_env) in
+        let tt = new_Type () in
 	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
-  try get_judgment_of extenv !evdref t
-  with Not_found | Anomaly _ ->
-    (* Quick workaround to acknowledge failure to build a well-typed pred *)
-    error "Unable to infer a well-typed return clause."
+	  e_new_evar evdref env ~src:(loc,ImpossibleCase) tt in
+	(lift (n'-n) impossible_case_type, tt)
+    | Some t ->
+        let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in
+        let evd,tt = Typing.e_type_of extenv !evdref t in
+        evdref := evd;
+        (t,tt) in
+  { uj_val = t; uj_type = tt }
 
 (* 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
@@ -1432,12 +1547,16 @@ let build_inversion_problem loc env sigma tms t =
 	let pat,acc = make_patvar t acc in
 	let indf' = lift_inductive_family n indf in
 	let sign = make_arity_signature env true indf' in
+	let sign = recover_alias_names alias_of_pat (pat :: List.rev patl) sign in
 	let p = List.length realargs in
 	let env' = push_rels sign env in
 	let patl',acc_sign,acc = aux (n+p+1) env' (sign@acc_sign) tms acc in
 	patl@pat::patl',acc_sign,acc
     | (t, NotInd (bo,typ)) :: tms ->
-	aux n env acc_sign tms acc in
+      let pat,acc = make_patvar t acc in
+      let d = (alias_of_pat pat,None,t) in
+      let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in
+      pat::patl,acc_sign,acc in
   let avoid0 = ids_of_context env in
   (* [patl] is a list of patterns revealing the substructure of
      constructors present in the constraints on the type of the
@@ -1450,16 +1569,22 @@ let build_inversion_problem loc env sigma tms t =
      problem have to be abstracted *)
   let patl,sign,(subst,avoid) = aux 0 env [] tms ([],avoid0) in
   let n = List.length sign in
-  let (pb_env,_),sub_tms =
-    list_fold_map (fun (env,i) (na,b,t as d) ->
-      let typ =
-	if b<>None then NotInd(None,t) else
-	  try try_find_ind env sigma t None
-	  with Not_found -> NotInd (None,t) in
-      let ty = lift_tomatch_type (n-i) typ in
-      let tm = Pushed ((mkRel (n-i),ty),[],(Anonymous,KnownNotDep)) in
-      ((push_rel d env,i+1),tm))
-      (env,0) (List.rev sign) in
+
+  let decls =
+    list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
+
+  let pb_env = push_rels sign env in
+  let decls =
+    List.map (fun (c,d) -> (c,extract_inductive_data pb_env sigma d,d)) decls in
+
+  let decls = List.rev decls in
+  let dep_sign = find_dependencies_signature (list_make n true) decls in
+
+  let sub_tms =
+    List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) ->
+      let na = if deps = [] then Anonymous else force_name na in
+      Pushed ((tm,tmtyp),deps,na))
+      dep_sign decls in
   let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
   (* [eqn1] is the first clause of the auxiliary pattern-matching that
      serves as skeleton for the return type: [patl] is the
@@ -1508,26 +1633,14 @@ let build_inversion_problem loc env sigma tms t =
 
 (* Here, [pred] is assumed to be in the context built from all *)
 (* realargs and terms to match *)
-let build_initial_predicate knowndep allnames pred =
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let rec buildrec n pred nal = function
-    | [] -> List.rev nal,pred
-    | names::lnames ->
-        let names' = List.tl names in
-        let n' = n + List.length names' in
-        let pred, p =
-          if dependent (mkRel (nar-n')) pred then pred, 1
-          else liftn (-1) (nar-n') pred, 0 in
-        let na =
-          if p=1 then
-            let na = List.hd names in
-            ((if na = Anonymous then
-              (* can happen if evars occur in the return clause *)
-              Name (id_of_string "x") (*Hum*)
-            else na),knowndep)
-          else (Anonymous,KnownNotDep) in
-        buildrec (n'+1) pred (na::nal) lnames
-  in buildrec 0 pred [] allnames
+let build_initial_predicate arsign pred =
+  let rec buildrec n pred tmnames = function
+    | [] -> List.rev tmnames,pred
+    | ((na,c,t)::realdecls)::lnames ->
+        let n' = n + List.length realdecls in
+        buildrec (n'+1) pred (force_name na::tmnames) lnames
+    | _ -> assert false
+  in buildrec 0 pred [] (List.rev arsign)
 
 let extract_arity_signature env0 tomatchl tmsign =
   let get_one_sign n tm (na,t) =
@@ -1553,19 +1666,11 @@ let extract_arity_signature env0 tomatchl tmsign =
 		      anomaly "Ill-formed 'in' clause in cases";
 		  List.rev realnal
 	      | None -> list_make nrealargs_ctxt Anonymous in
-(* 	  let na =  *)
-(* 	    match na with  *)
-(* 	      | Name _ -> na *)
-(* 	      | Anonymous -> *)
-(* 		  match kind_of_term term with *)
-(* 		    | Rel n -> pi1 (lookup_rel n (Environ.rel_context env0)) *)
-(* 		    | _ -> Anonymous *)
-(* 	  in *)
 	  (na,None,build_dependent_inductive env0 indf')
 	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
   let rec buildrec n = function
     | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
+    | (_,tm)::ltm, (_,x)::tmsign ->
 	let l = get_one_sign n tm x in
 	l :: buildrec (n + List.length l) (ltm,tmsign)
     | _ -> assert false
@@ -1581,7 +1686,7 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
 
 (* We put the tycon inside the arity signature, possibly discovering dependencies. *)
 
-let prepare_predicate_from_arsign_tycon loc tomatchs sign arsign c =
+let prepare_predicate_from_arsign_tycon loc 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 ->
@@ -1635,9 +1740,7 @@ let prepare_predicate_from_arsign_tycon loc tomatchs sign arsign c =
  * tycon to make the predicate if it is not closed.
  *)
 
-let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred =
-  let arsign = extract_arity_signature env tomatchs sign in
-  let names = List.rev (List.map (List.map pi1) arsign) in
+let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred =
   let preds =
     match pred, tycon with
     (* No type annotation *)
@@ -1646,40 +1749,40 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred =
         (* 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
+          prepare_predicate_from_arsign_tycon loc tomatchs 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) ->
-	(* First strategy: we build an "inversion" predicate *)
-	let sigma1,pred = build_inversion_problem loc env !evdref tomatchs t in
-	(* Second strategy: we abstract the tycon wrt to the dependencies *)
-        let pred2 = lift (List.length names) t in
-	[sigma1, DepUnknown, pred; !evdref, KnownNotDep, pred2]
-    | 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
+	let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
+	[sigma, pred1; sigma2, pred2]
+    | None, _ ->
+	(* No dependent type constraint, or no constraints at all: *)
+	(* we use two strategies *)
+        let sigma,t = match tycon with
+	| Some (None, t) -> sigma,t
+	| _ -> new_type_evar sigma env ~src:(loc, CasesType) in
+        (* First strategy: we build an "inversion" predicate *)
+	let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in
 	(* Second strategy: we directly use the evar as a non dependent pred *)
-        let pred2 = lift (List.length names) t in
-	[sigma1, DepUnknown, pred1; !evdref, KnownNotDep, pred2]
+        let pred2 = lift (List.length arsign) t in
+	[sigma1, pred1; sigma, pred2]
     (* Some type annotation *)
     | Some rtntyp, _ ->
       (* We extract the signature of the arity *)
-      let env = List.fold_right push_rels arsign env in
-      let predcclj = typing_fun (mk_tycon (new_Type ())) env evdref rtntyp in
-      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]
+      let envar = List.fold_right push_rels arsign env in
+      let sigma, newt = new_sort_variable sigma in
+      let evdref = ref sigma in
+      let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in
+      let sigma = Option.cata (fun tycon ->
+          let na = Name (id_of_string "x") in
+          let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in
+          let predinst = extract_predicate predcclj.uj_val tms in
+          Coercion.inh_conv_coerces_to loc env !evdref predinst tycon)
+        !evdref tycon in
+      let predccl = (j_nf_evar sigma predcclj).uj_val in
+      [sigma, predccl]
   in
   List.map
-    (fun (sigma,dep,pred) ->
-      let (nal,pred) = build_initial_predicate dep names pred in
+    (fun (sigma,pred) ->
+      let (nal,pred) = build_initial_predicate arsign pred in
       sigma,nal,pred)
     preds
 
@@ -1698,15 +1801,33 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
   (* 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 arsign = extract_arity_signature env tomatchs tomatchl in
+  let preds = prepare_predicate loc typing_fun !evdref env tomatchs arsign tycon predopt in
 
   let compile_for_one_predicate (sigma,nal,pred) =
     (* We push the initial terms to match and push their alias to rhs' envs *)
     (* names of aliases will be recovered from patterns (hence Anonymous *)
     (* here) *)
 
-    let initial_pushed = List.map2 (fun tm na -> Pushed(tm,[],na)) tomatchs nal in
+    let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+    let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
+
+    let typs =
+      List.map (fun (c,d) -> (c,extract_inductive_data env sigma d,d)) typs in
+
+    let dep_sign =
+      find_dependencies_signature
+        (list_make (List.length typs) true)
+        typs in
+
+    let typs' =
+      list_map3
+        (fun (tm,tmt) deps na ->
+          let deps = if not (isRel tm) then [] else deps in
+          ((tm,tmt),deps,na))
+        tomatchs dep_sign nal in
+
+    let initial_pushed = List.map (fun x -> Pushed x) typs' in
 
     (* A typing function that provides with a canonical term for absurd cases*)
     let typing_fun tycon env evdref = function
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 2711276a..f773da0e 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -1,24 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cases.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Evd
 open Environ
 open Inductiveops
-open Rawterm
+open Glob_term
 open Evarutil
-(*i*)
 
+(** {5 Compilation of pattern-matching } *)
+
+(** {6 Pattern-matching errors } *)
 type pattern_matching_error =
   | BadPattern of constructor * constr
   | BadConstructor of constructor * inductive
@@ -46,27 +45,14 @@ val error_wrong_predicate_arity_loc : loc -> env -> constr -> constr -> constr -
 
 val error_needs_inversion : env -> constr -> types -> 'a
 
-val set_impossible_default_clause : constr * types -> unit
-(*s Compilation of pattern-matching. *)
-
-type alias_constr =
-  | DepAlias
-  | NonDepAlias
-type dep_status = KnownDep | KnownNotDep | DepUnknown
-type tomatch_type =
-  | IsInd of types * inductive_type * name list
-  | NotInd of constr option * types
-type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list * (name * dep_status))
-  | Alias of (constr * constr * alias_constr * constr)
-  | Abstract of rel_declaration
+(** {6 Compilation primitive. } *)
 
 module type S = sig
   val compile_cases :
     loc -> case_style ->
-    (type_constraint -> env -> evar_map ref -> rawconstr -> unsafe_judgment) * evar_map ref ->
+    (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
     type_constraint ->
-    env -> rawconstr option * tomatch_tuples * cases_clauses ->
+    env -> glob_constr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
 
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 802f9c58..ad33bae1 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cbv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Term
@@ -94,13 +92,6 @@ 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
@@ -299,7 +290,7 @@ and cbv_stack_term info stack env t =
         cbv_stack_term info (stack_app cargs stk) env br.(n-1)
 
     (* constructor of arity 0 in a Case -> IOTA *)
-    | (CONSTR((_,n),_), CASE(_,br,_,env,stk))
+    | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk))
             when red_set (info_flags info) fIOTA ->
                     cbv_stack_term info stk env br.(n-1)
 
@@ -365,14 +356,14 @@ and cbv_norm_value info = function (* reduction under binders *)
 
 (* with profiling *)
 let cbv_norm infos constr =
-  with_stats (lazy (cbv_norm_term infos (ESID 0) constr))
+  with_stats (lazy (cbv_norm_term infos (subs_id 0) constr))
 
 type cbv_infos = cbv_value infos
 
 (* constant bodies are normalized at the first expansion *)
 let create_cbv_infos flgs env sigma =
   create
-    (fun old_info c -> cbv_stack_term old_info TOP (ESID 0) c)
+    (fun old_info c -> cbv_stack_term old_info TOP (subs_id 0) c)
     flgs
     env
     (Reductionops.safe_evar_value sigma)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index e66e6dc6..acaf7e49 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -1,32 +1,28 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cbv.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Environ
 open Closure
 open Esubst
-(*i*)
 
-(************************************************************************)
-(*s Call-by-value reduction *)
+(***********************************************************************
+  s Call-by-value reduction *)
 
-(* Entry point for cbv normalization of a constr *)
+(** Entry point for cbv normalization of a constr *)
 type cbv_infos
 
 val create_cbv_infos : RedFlags.reds -> env -> Evd.evar_map -> cbv_infos
 val cbv_norm         : cbv_infos -> constr -> constr
 
-(************************************************************************)
-(*i This is for cbv debug *)
+(***********************************************************************
+  i This is for cbv debug *)
 type cbv_value =
   | VAL of int * constr
   | STACK of int * cbv_value * cbv_stack
@@ -46,7 +42,7 @@ 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
 
-(* recursive functions... *)
+(** recursive functions... *)
 val cbv_stack_term : cbv_infos ->
   cbv_stack -> cbv_value subs -> constr -> cbv_value
 val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr
@@ -54,4 +50,5 @@ val norm_head : cbv_infos ->
   cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack
 val apply_stack : cbv_infos -> constr -> cbv_stack -> constr
 val cbv_norm_value : cbv_infos -> cbv_value -> constr
-(* End of cbv debug section i*)
+
+(** End of cbv debug section i*)
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 504d01af..62d774bd 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: classops.ml 14776 2011-12-07 17:54:28Z herbelin $ *)
-
 open Util
 open Pp
 open Flags
@@ -19,7 +17,7 @@ open Libobject
 open Library
 open Term
 open Termops
-open Rawterm
+open Glob_term
 open Decl_kinds
 open Mod_subst
 
@@ -48,6 +46,13 @@ type coe_info_typ = {
   coe_is_identity : bool;
   coe_param : int }
 
+let coe_info_typ_equal c1 c2 =
+  eq_constr c1.coe_value c2.coe_value &&
+    eq_constr c1.coe_type c2.coe_type &&
+    c1.coe_strength = c2.coe_strength &&
+    c1.coe_is_identity = c2.coe_is_identity &&
+    c1.coe_param = c2.coe_param
+
 type cl_index = int
 
 type coe_index = coe_info_typ
@@ -134,9 +139,9 @@ let coercion_info coe = Gmap.find coe !coercion_tab
 
 let coercion_exists coe = Gmap.mem coe !coercion_tab
 
-(* find_class_type : env -> evar_map -> constr -> cl_typ * int *)
+(* find_class_type : evar_map -> constr -> cl_typ * constr list *)
 
-let find_class_type env sigma t =
+let find_class_type sigma t =
   let t', args = Reductionops.whd_betaiotazeta_stack sigma t in
   match kind_of_term t' with
     | Var id -> CL_SECVAR id, args
@@ -154,7 +159,7 @@ let subst_cl_typ subst ct = match ct with
   | 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)
+         fst (find_class_type Evd.empty t)
   | CL_IND (kn,i) ->
       let kn' = subst_ind subst kn in
 	if kn' == kn then ct else
@@ -169,12 +174,12 @@ let subst_coe_typ subst t = fst (subst_global subst t)
 let class_of env sigma t =
   let (t, n1, i, args) =
     try
-      let (cl,args) = find_class_type env sigma t in
+      let (cl,args) = find_class_type 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 sigma t in
       let (i, { cl_param = n1 } ) = class_info cl in
       (t, n1, i, args)
   in
@@ -182,7 +187,7 @@ let class_of env sigma t =
 
 let inductive_class_of ind = fst (class_info (CL_IND ind))
 
-let class_args_of env sigma c = snd (find_class_type env sigma c)
+let class_args_of env sigma c = snd (find_class_type sigma c)
 
 let string_of_class = function
   | CL_FUN -> "Funclass"
@@ -211,14 +216,14 @@ let lookup_path_to_sort_from_class s =
 
 let apply_on_class_of env sigma t cont =
   try
-    let (cl,args) = find_class_type env sigma t in
+    let (cl,args) = find_class_type sigma t in
     let (i, { cl_param = n1 } ) = class_info cl in
     if List.length args <> n1 then raise Not_found;
     t, cont i
   with Not_found ->
     (* Is it worth to be more incremental on the delta steps? *)
     let t = Tacred.hnf_constr env sigma t in
-    let (cl, args) = find_class_type env sigma t in
+    let (cl, args) = find_class_type sigma t in
     let (i, { cl_param = n1 } ) = class_info cl in
     if List.length args <> n1 then raise Not_found;
     t, cont i
@@ -308,7 +313,7 @@ let add_coercion_in_graph (ic,source,target) =
              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 &&  not (list_equal coe_info_typ_equal p q) then
 		    try_add_new_path1 (s,v) (p@[ic]@q))
                old_inheritance_graph
            end;
@@ -344,6 +349,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic import of coercions";
       optkey   = ["Automatic";"Coercions";"Import"];
       optread  = (fun () -> !automatically_import_coercions);
@@ -400,7 +406,10 @@ let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
 let classify_coercion (coe,stre,isid,cls,clt,ps as obj) =
   if stre = Local then Dispose else Substitute obj
 
-let (inCoercion,_) =
+type coercion_obj =
+  coe_typ * Decl_kinds.locality * bool * cl_typ * cl_typ * int
+
+let inCoercion : coercion_obj -> obj =
   declare_object {(default_object "COERCION") with
     open_function = open_coercion;
     load_function = load_coercion;
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index 964b44a0..66bb5c6c 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Decl_kinds
 open Term
@@ -16,9 +13,8 @@ open Evd
 open Environ
 open Nametab
 open Mod_subst
-(*i*)
 
-(*s This is the type of class kinds *)
+(** {6 This is the type of class kinds } *)
 type cl_typ =
   | CL_SORT
   | CL_FUN
@@ -28,53 +24,53 @@ type cl_typ =
 
 val subst_cl_typ : substitution -> cl_typ -> cl_typ
 
-(* This is the type of infos for declared classes *)
+(** This is the type of infos for declared classes *)
 type cl_info_typ = {
   cl_param : int }
 
-(* This is the type of coercion kinds *)
+(** This is the type of coercion kinds *)
 type coe_typ = Libnames.global_reference
 
-(* This is the type of infos for declared coercions *)
+(** This is the type of infos for declared coercions *)
 type coe_info_typ
 
-(* [cl_index] is the type of class keys *)
+(** [cl_index] is the type of class keys *)
 type cl_index
 
-(* [coe_index] is the type of coercion keys *)
+(** [coe_index] is the type of coercion keys *)
 type coe_index
 
-(* This is the type of paths from a class to another *)
+(** This is the type of paths from a class to another *)
 type inheritance_path = coe_index list
 
-(*s Access to classes infos *)
+(** {6 Access to classes infos } *)
 val class_info : cl_typ -> (cl_index * cl_info_typ)
 val class_exists : cl_typ -> bool
 val class_info_from_index : cl_index -> cl_typ * cl_info_typ
 
-(* [find_class_type env sigma c] returns the head reference of [c] and its
+(** [find_class_type env sigma c] returns the head reference of [c] and its
    arguments *)
-val find_class_type : env -> evar_map -> types -> cl_typ * constr list
+val find_class_type : evar_map -> types -> cl_typ * constr list
 
-(* raises [Not_found] if not convertible to a class *)
+(** raises [Not_found] if not convertible to a class *)
 val class_of : env -> evar_map -> types -> types * cl_index
 
-(* raises [Not_found] if not mapped to a class *)
+(** raises [Not_found] if not mapped to a class *)
 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 *)
+(** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *)
 val declare_coercion :
   coe_typ -> locality -> isid:bool ->
       src:cl_typ -> target:cl_typ -> params:int -> unit
 
-(*s Access to coercions infos *)
+(** {6 Access to coercions infos } *)
 val coercion_exists : coe_typ -> bool
 
 val coercion_value : coe_index -> (unsafe_judgment * bool)
 
-(*s Lookup functions for coercion paths *)
+(** {6 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 ->
@@ -86,13 +82,14 @@ val lookup_path_to_sort_from : env -> evar_map -> types ->
 val lookup_pattern_path_between :
   inductive * inductive -> (constructor * int) list
 
-(*i Crade *)
+(**/**)
+(* Crade *)
 open Pp
 val install_path_printer :
   ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit
-(*i*)
+(**/**)
 
-(*s This is for printing purpose *)
+(** {6 This is for printing purpose } *)
 val string_of_class : cl_typ -> string
 val pr_class : cl_typ -> std_ppcmds
 val pr_cl_index : cl_index -> std_ppcmds
@@ -101,6 +98,6 @@ val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list
 val classes : unit -> cl_typ list
 val coercions : unit -> coe_index list
 
-(* [hide_coercion] returns the number of params to skip if the coercion must
+(** [hide_coercion] returns the number of params to skip if the coercion must
    be hidden, [None] otherwise; it raises [Not_found] if not a coercion *)
 val hide_coercion : coe_typ -> int option
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index d0f20615..553c9127 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -1,11 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: coercion.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+
+(* Created by Hugo Herbelin for Coq V7 by isolating the coercion
+   mechanism out of the type inference algorithm in file trad.ml from
+   Coq V6.3, Nov 1999; The coercion mechanism was implemented in
+   trad.ml by Amokrane Saïbi, May 1996 *)
+(* Addition of products and sorts in canonical structures by Pierre
+   Corbineau, Feb 2008 *)
+(* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *)
 
 open Util
 open Names
@@ -66,7 +73,7 @@ module type S = sig
      pattern [pat] typed in [ind1] into a pattern typed in [ind2];
      raises [Not_found] if no coercion found *)
   val inh_pattern_coerce_to :
-    loc  -> Rawterm.cases_pattern -> inductive -> inductive -> Rawterm.cases_pattern
+    loc  -> Glob_term.cases_pattern -> inductive -> inductive -> Glob_term.cases_pattern
 end
 
 module Default = struct
@@ -92,8 +99,8 @@ module Default = struct
   let apply_pattern_coercion loc pat p =
     List.fold_left
       (fun pat (co,n) ->
-	 let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
-	   Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+	 let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
+	   Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
       pat p
 
   (* raise Not_found if no coercion found *)
@@ -130,8 +137,8 @@ module Default = struct
 	      (evd',{ uj_val = j.uj_val; uj_type = t })
 	| _ ->
       	    let t,p =
-	      lookup_path_to_fun_from env ( evd) j.uj_type in
-	      (evd,apply_coercion env ( evd) p j t)
+	      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
@@ -141,15 +148,15 @@ module Default = struct
 
   let inh_tosort_force loc env evd j =
     try
-      let t,p = lookup_path_to_sort_from env ( evd) j.uj_type in
-      let j1 = apply_coercion env ( evd) p j t in
-      let j2 = on_judgment_type (whd_evar ( evd)) j1 in
+      let t,p = lookup_path_to_sort_from env evd j.uj_type in
+      let j1 = apply_coercion env evd p j t in
+      let j2 = on_judgment_type (whd_evar evd) j1 in
         (evd,type_judgment env j2)
     with Not_found ->
-      error_not_a_type_loc loc env ( evd) j
+      error_not_a_type_loc loc env evd j
 
   let inh_coerce_to_sort loc env evd j =
-    let typ = whd_betadeltaiota env ( evd) j.uj_type in
+    let typ = whd_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) ->
@@ -195,6 +202,8 @@ module Default = struct
         (* We eta-expand (hence possibly modifying the original term!) *)
 	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
 	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
+        (* Note: we retype the term because sort-polymorphism may have *)
+        (* weaken its type *)
 	let name = match name with
 	  | Anonymous -> Name (id_of_string "x")
 	  | _ -> name in
@@ -204,7 +213,9 @@ module Default = struct
             (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
         let v1 = Option.get v1 in
 	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
-        let t2 = subst_term v1 t2 in
+	let t2 = match v2 with
+	  | None -> subst_term v1 t2
+	  | Some v2 -> Retyping.get_type_of env1 evd' v2 in
 	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
 	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
     | _ -> raise NoCoercion
@@ -231,7 +242,14 @@ module Default = struct
   let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
 
 
-    let inh_conv_coerces_to loc env (evd : evar_map) t (abs, t') = evd
+    let inh_conv_coerces_to loc env (evd : evar_map) t (abs, t') =
+      if abs = None then
+	try
+	  fst (inh_conv_coerce_to_fail loc env evd true None t t')
+	with NoCoercion ->
+	  evd (* Maybe not enough information to unify *)
+      else
+        evd
       (* Still problematic, as it changes unification
       let nabsinit, nabs =
 	match abs with
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 6ad1023e..5d814b29 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coercion.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Evd
 open Names
@@ -16,35 +13,34 @@ open Term
 open Sign
 open Environ
 open Evarutil
-open Rawterm
-(*i*)
+open Glob_term
 
 module type S = sig
-  (*s Coercions. *)
+  (** {6 Coercions. } *)
 
-  (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+  (** [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_map -> unsafe_judgment -> evar_map * unsafe_judgment
 
-  (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+  (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a sort; it fails if no coercion is applicable *)
   val inh_coerce_to_sort : loc ->
     env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
 
-  (* [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
+  (** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type its base type (the notion depends on the coercion system) *)
   val inh_coerce_to_base : loc ->
     env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
 
-  (* [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
+  (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
   val inh_coerce_to_prod : loc ->
     env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type
 
-  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of 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 ->
@@ -53,13 +49,13 @@ module type S = sig
   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 isevars t t'] checks if an object of type [t]
+  (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
      is coercible to an object of type [t'] adding evar constraints if needed;
      it fails if no coercion exists *)
   val inh_conv_coerces_to : loc ->
     env -> evar_map -> types -> type_constraint_type -> evar_map
 
-  (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+  (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
      pattern [pat] typed in [ind1] into a pattern typed in [ind2];
      raises [Not_found] if no coercion found *)
   val inh_pattern_coerce_to :
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 14e72807..c194a0f2 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: detyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Univ
@@ -18,7 +16,7 @@ open Inductive
 open Inductiveops
 open Environ
 open Sign
-open Rawterm
+open Glob_term
 open Nameops
 open Termops
 open Namegen
@@ -47,34 +45,34 @@ let has_two_constructors lc =
 let isomorphic_to_tuple lc = (Array.length lc = 1)
 
 let encode_bool r =
-  let (_,lc as x) = encode_inductive r in
+  let (x,lc) = encode_inductive r in
   if not (has_two_constructors lc) then
     user_err_loc (loc_of_reference r,"encode_if",
       str "This type has not exactly two constructors.");
   x
 
 let encode_tuple r =
-  let (_,lc as x) = encode_inductive r in
+  let (x,lc) = encode_inductive r in
   if not (isomorphic_to_tuple lc) then
     user_err_loc (loc_of_reference r,"encode_tuple",
       str "This type cannot be seen as a tuple type.");
   x
 
-module PrintingCasesMake =
+module PrintingInductiveMake =
   functor (Test : sig
-     val encode : reference -> inductive * int array
+     val encode : reference -> inductive
      val member_message : std_ppcmds -> bool -> std_ppcmds
      val field : string
      val title : string
   end) ->
   struct
-    type t = inductive * int array
+    type t = inductive
     let encode = Test.encode
-    let subst subst ((kn,i), ints as obj) =
+    let subst subst (kn, ints as obj) =
       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)
+	  kn', ints
+    let printer ind = pr_global_env Idset.empty (IndRef ind)
     let key = ["Printing";Test.field]
     let title = Test.title
     let member_message x = Test.member_message (printer x)
@@ -82,7 +80,7 @@ module PrintingCasesMake =
   end
 
 module PrintingCasesIf =
-  PrintingCasesMake (struct
+  PrintingInductiveMake (struct
     let encode = encode_bool
     let field = "If"
     let title = "Types leading to pretty-printing of Cases using a `if' form: "
@@ -94,7 +92,7 @@ module PrintingCasesIf =
   end)
 
 module PrintingCasesLet =
-  PrintingCasesMake (struct
+  PrintingInductiveMake (struct
     let encode = encode_tuple
     let field = "Let"
     let title =
@@ -118,6 +116,7 @@ let force_wildcard () = !wildcard_value
 
 let _ = declare_bool_option
 	  { optsync  = true;
+            optdepr  = false;
 	    optname  = "forced wildcard";
 	    optkey   = ["Printing";"Wildcard"];
 	    optread  = force_wildcard;
@@ -128,6 +127,7 @@ let synthetize_type () = !synth_type_value
 
 let _ = declare_bool_option
 	  { optsync  = true;
+            optdepr  = false;
 	    optname  = "pattern matching return type synthesizability";
 	    optkey   = ["Printing";"Synth"];
 	    optread  = synthetize_type;
@@ -138,6 +138,7 @@ let reverse_matching () = !reverse_matching_value
 
 let _ = declare_bool_option
 	  { optsync  = true;
+            optdepr  = false;
 	    optname  = "pattern-matching reversibility";
 	    optkey   = ["Printing";"Matching"];
 	    optread  = reverse_matching;
@@ -168,8 +169,6 @@ let computable p k =
   &&
   noccur_between 1 (k+1) ccl
 
-let avoid_flag isgoal = if isgoal then Some true else None
-
 let lookup_name_as_displayed env t s =
   let rec lookup avoid n c = match kind_of_term c with
     | Prod (name,_,c') ->
@@ -237,7 +236,7 @@ let rec decomp_branch n nal b (avoid,env as e) c =
 
 let rec build_tree na isgoal e ci cl =
   let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in
-  let cnl = ci.ci_cstr_nargs in
+  let cnl = ci.ci_cstr_ndecls in
   List.flatten
     (list_tabulate (fun i -> contract_branch isgoal e (cnl.(i),mkpat i,cl.(i)))
        (Array.length cl))
@@ -279,30 +278,30 @@ let is_nondep_branch c n =
 let extract_nondep_branches test c b n =
   let rec strip n r = if n=0 then r else
     match r with
-      | RLambda (_,_,_,_,t) -> strip (n-1) t
-      | RLetIn (_,_,_,t) -> strip (n-1) t
+      | GLambda (_,_,_,_,t) -> strip (n-1) t
+      | GLetIn (_,_,_,t) -> strip (n-1) t
       | _ -> assert false in
   if test c n then Some (strip n b) else None
 
 let it_destRLambda_or_LetIn_names n c =
   let rec aux n nal c =
     if n=0 then (List.rev nal,c) else match c with
-      | RLambda (_,na,_,_,c) -> aux (n-1) (na::nal) c
-      | RLetIn (_,na,_,c) -> aux (n-1) (na::nal) c
+      | GLambda (_,na,_,_,c) -> aux (n-1) (na::nal) c
+      | GLetIn (_,na,_,c) -> aux (n-1) (na::nal) c
       | _ ->
           (* eta-expansion *)
 	  let rec next l =
 	    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 *)
+	    (* Not efficient but unusual and no function to get free glob_vars *)
+(* 	    if occur_glob_constr x c then next (x::l) else x in *)
 	    x
 	  in
-	  let x = next (free_rawvars c) in
-	  let a = RVar (dl,x) in
+	  let x = next (free_glob_vars c) in
+	  let a = GVar (dl,x) in
 	  aux (n-1) (Name x :: nal)
             (match c with
-              | RApp (loc,p,l) -> RApp (loc,c,l@[a])
-              | _ -> (RApp (dl,c,[a])))
+              | GApp (loc,p,l) -> GApp (loc,c,l@[a])
+              | _ -> (GApp (dl,c,[a])))
   in aux n [] c
 
 let detype_case computable detype detype_eqns testdep avoid data p c bl =
@@ -319,7 +318,7 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
         | Some p ->
             let nl,typ = it_destRLambda_or_LetIn_names k p in
 	    let n,typ = match typ with
-              | RLambda (_,x,_,t,c) -> x, c
+              | GLambda (_,x,_,t,c) -> x, c
 	      | _ -> Anonymous, typ in
 	    let aliastyp =
 	      if List.for_all ((=) Anonymous) nl then None
@@ -333,9 +332,9 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
         RegularStyle
       else if st = LetPatternStyle then
 	st
-      else if PrintingLet.active (indsp,consnargsl) then
+      else if PrintingLet.active indsp then
 	LetStyle
-      else if PrintingIf.active (indsp,consnargsl) then
+      else if PrintingIf.active indsp then
 	IfStyle
       else
 	st
@@ -345,24 +344,24 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
   | 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)
+      GLetTuple (dl,nal,(alias,pred),tomatch,d)
   | IfStyle when aliastyp = None ->
       let bl' = Array.map detype bl in
       let nondepbrs =
 	array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
       if array_for_all ((<>) None) nondepbrs then
-	RIf (dl,tomatch,(alias,pred),
+	GIf (dl,tomatch,(alias,pred),
              Option.get nondepbrs.(0),Option.get nondepbrs.(1))
       else
 	let eqnl = detype_eqns constructs consnargsl bl in
-	RCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+	GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
   | _ ->
       let eqnl = detype_eqns constructs consnargsl bl in
-      RCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+      GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
 
 let detype_sort = function
-  | Prop c -> RProp c
-  | Type u -> RType (Some u)
+  | Prop c -> GProp c
+  | Type u -> GType (Some u)
 
 type binder_kind = BProd | BLambda | BLetIn
 
@@ -376,43 +375,43 @@ let rec detype (isgoal:bool) avoid env t =
   match kind_of_term (collapse_appl t) with
     | Rel n ->
       (try match lookup_name_of_rel n env with
-	 | Name id   -> RVar (dl, id)
+	 | Name id   -> GVar (dl, id)
 	 | Anonymous -> !detype_anonymous dl n
        with Not_found ->
 	 let s = "_UNBOUND_REL_"^(string_of_int n)
-	 in RVar (dl, id_of_string s))
+	 in GVar (dl, id_of_string s))
     | Meta n ->
 	(* Meta in constr are not user-parsable and are mapped to Evar *)
-	REvar (dl, n, None)
+	GEvar (dl, n, None)
     | Var id ->
 	(try
-	  let _ = Global.lookup_named id in RRef (dl, VarRef id)
+	  let _ = Global.lookup_named id in GRef (dl, VarRef id)
 	 with _ ->
-	  RVar (dl, id))
-    | Sort s -> RSort (dl,detype_sort s)
+	  GVar (dl, id))
+    | Sort s -> GSort (dl,detype_sort s)
     | Cast (c1,k,c2) ->
-	RCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2))
+	GCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2))
     | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c
     | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c
     | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c
     | App (f,args) ->
-	RApp (dl,detype isgoal avoid env f,
+	GApp (dl,detype isgoal avoid env f,
               array_map_to_list (detype isgoal avoid env) args)
-    | Const sp -> RRef (dl, ConstRef sp)
+    | Const sp -> GRef (dl, ConstRef sp)
     | Evar (ev,cl) ->
-        REvar (dl, ev,
+        GEvar (dl, ev,
                Some (List.map (detype isgoal avoid env) (Array.to_list cl)))
     | Ind ind_sp ->
-	RRef (dl, IndRef ind_sp)
+	GRef (dl, IndRef ind_sp)
     | Construct cstr_sp ->
-	RRef (dl, ConstructRef cstr_sp)
+	GRef (dl, ConstructRef cstr_sp)
     | Case (ci,p,c,bl) ->
 	let comp = computable p (ci.ci_pp_info.ind_nargs) in
 	detype_case comp (detype isgoal avoid env)
 	  (detype_eqns isgoal avoid env ci comp)
 	  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)
+	   ci.ci_cstr_ndecls,ci.ci_pp_info.ind_nargs)
 	  (Some p) c bl
     | Fix (nvn,recdef) -> detype_fix isgoal avoid env nvn recdef
     | CoFix (n,recdef) -> detype_cofix isgoal avoid env n recdef
@@ -428,7 +427,7 @@ and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) =
   let v = array_map3
     (fun c t i -> share_names isgoal (i+1) [] def_avoid def_env c (lift n t))
     bodies tys vn in
-  RRec(dl,RFix (Array.map (fun i -> Some i, RStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
+  GRec(dl,GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
@@ -444,7 +443,7 @@ and detype_cofix isgoal avoid env n (names,tys,bodies) =
   let v = array_map2
     (fun c t -> share_names isgoal 0 [] def_avoid def_env c (lift ntys t))
     bodies tys in
-  RRec(dl,RCoFix n,Array.of_list (List.rev lfi),
+  GRec(dl,GCoFix n,Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
@@ -539,9 +538,9 @@ and detype_binder isgoal bk avoid env na ty 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 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)
+  | BProd -> GProd (dl, na',Explicit,detype false avoid env ty, r)
+  | BLambda -> GLambda (dl, na',Explicit,detype false avoid env ty, r)
+  | BLetIn -> GLetIn (dl, na',detype false avoid env ty, r)
 
 let rec detype_rel_context where avoid env sign =
   let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
@@ -573,42 +572,42 @@ let rec subst_cases_pattern subst pat =
 	if kn' == kn && cpl' == cpl then pat else
 	  PatCstr (loc,((kn',i),j),cpl',n)
 
-let rec subst_rawconstr subst raw =
+let rec subst_glob_constr subst raw =
   match raw with
-  | RRef (loc,ref) ->
+  | GRef (loc,ref) ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
          detype false [] [] t
 
-  | RVar _ -> raw
-  | REvar _ -> raw
-  | RPatVar _ -> raw
+  | GVar _ -> raw
+  | GEvar _ -> raw
+  | GPatVar _ -> raw
 
-  | RApp (loc,r,rl) ->
-      let r' = subst_rawconstr subst r
-      and rl' = list_smartmap (subst_rawconstr subst) rl in
+  | GApp (loc,r,rl) ->
+      let r' = subst_glob_constr subst r
+      and rl' = list_smartmap (subst_glob_constr subst) rl in
 	if r' == r && rl' == rl then raw else
-	  RApp(loc,r',rl')
+	  GApp(loc,r',rl')
 
-  | RLambda (loc,n,bk,r1,r2) ->
-      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+  | GLambda (loc,n,bk,r1,r2) ->
+      let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
-	  RLambda (loc,n,bk,r1',r2')
+	  GLambda (loc,n,bk,r1',r2')
 
-  | RProd (loc,n,bk,r1,r2) ->
-      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+  | GProd (loc,n,bk,r1,r2) ->
+      let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
-	  RProd (loc,n,bk,r1',r2')
+	  GProd (loc,n,bk,r1',r2')
 
-  | RLetIn (loc,n,r1,r2) ->
-      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+  | GLetIn (loc,n,r1,r2) ->
+      let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
-	  RLetIn (loc,n,r1',r2')
+	  GLetIn (loc,n,r1',r2')
 
-  | RCases (loc,sty,rtno,rl,branches) ->
-      let rtno' = Option.smartmap (subst_rawconstr subst) rtno
+  | GCases (loc,sty,rtno,rl,branches) ->
+      let rtno' = Option.smartmap (subst_glob_constr subst) rtno
       and rl' = list_smartmap (fun (a,x as y) ->
-        let a' = subst_rawconstr subst a in
+        let a' = subst_glob_constr subst a in
         let (n,topt) = x in
         let topt' = Option.smartmap
           (fun (loc,(sp,i),x,y as t) ->
@@ -619,72 +618,71 @@ let rec subst_rawconstr subst raw =
 			(fun (loc,idl,cpl,r as branch) ->
 			   let cpl' =
 			     list_smartmap (subst_cases_pattern subst) cpl
-			   and r' = subst_rawconstr subst r in
+			   and r' = subst_glob_constr subst r in
 			     if cpl' == cpl && r' == r then branch else
 			       (loc,idl,cpl',r'))
 			branches
       in
 	if rtno' == rtno && rl' == rl && branches' == branches then raw else
-	  RCases (loc,sty,rtno',rl',branches')
+	  GCases (loc,sty,rtno',rl',branches')
 
-  | RLetTuple (loc,nal,(na,po),b,c) ->
-      let po' = Option.smartmap (subst_rawconstr subst) po
-      and b' = subst_rawconstr subst b
-      and c' = subst_rawconstr subst c in
+  | GLetTuple (loc,nal,(na,po),b,c) ->
+      let po' = Option.smartmap (subst_glob_constr subst) po
+      and b' = subst_glob_constr subst b
+      and c' = subst_glob_constr subst c in
 	if po' == po && b' == b && c' == c then raw else
-          RLetTuple (loc,nal,(na,po'),b',c')
+          GLetTuple (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 c' = subst_rawconstr subst c in
+  | GIf (loc,c,(na,po),b1,b2) ->
+      let po' = Option.smartmap (subst_glob_constr subst) po
+      and b1' = subst_glob_constr subst b1
+      and b2' = subst_glob_constr subst b2
+      and c' = subst_glob_constr subst c in
 	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
-          RIf (loc,c',(na,po'),b1',b2')
+          GIf (loc,c',(na,po'),b1',b2')
 
-  | RRec (loc,fix,ida,bl,ra1,ra2) ->
-      let ra1' = array_smartmap (subst_rawconstr subst) ra1
-      and ra2' = array_smartmap (subst_rawconstr subst) ra2 in
+  | GRec (loc,fix,ida,bl,ra1,ra2) ->
+      let ra1' = array_smartmap (subst_glob_constr subst) ra1
+      and ra2' = array_smartmap (subst_glob_constr subst) ra2 in
       let bl' = array_smartmap
         (list_smartmap (fun (na,k,obd,ty as dcl) ->
-          let ty' = subst_rawconstr subst ty in
-          let obd' = Option.smartmap (subst_rawconstr subst) obd in
+          let ty' = subst_glob_constr subst ty in
+          let obd' = Option.smartmap (subst_glob_constr subst) obd in
           if ty'==ty & obd'==obd then dcl else (na,k,obd',ty')))
         bl in
 	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
-	  RRec (loc,fix,ida,bl',ra1',ra2')
+	  GRec (loc,fix,ida,bl',ra1',ra2')
 
-  | RSort _ -> raw
+  | GSort _ -> raw
 
-  | RHole (loc,ImplicitArg (ref,i,b)) ->
+  | GHole (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 |
+	  GHole (loc,InternalHole)
+  | GHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole |
       TomatchTypeParameter _ | GoalEvar | ImpossibleCase | MatchingVar _)) ->
       raw
 
-  | RCast (loc,r1,k) ->
+  | GCast (loc,r1,k) ->
       (match k with
 	   CastConv (k,r2) ->
-	     let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+	     let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
 	       if r1' == r1 && r2' == r2 then raw else
-		 RCast (loc,r1', CastConv (k,r2'))
+		 GCast (loc,r1', CastConv (k,r2'))
 	 | CastCoerce ->
-	     let r1' = subst_rawconstr subst r1 in
-	       if r1' == r1 then raw else RCast (loc,r1',k))
-  | RDynamic _ -> raw
+	     let r1' = subst_glob_constr subst r1 in
+	       if r1' == r1 then raw else GCast (loc,r1',k))
 
 (* Utilities to transform kernel cases to simple pattern-matching problem *)
 
-let simple_cases_matrix_of_branches ind brns brs =
-  list_map2_i (fun i n b ->
+let simple_cases_matrix_of_branches ind brs =
+  List.map (fun (i,n,b) ->
       let nal,c = it_destRLambda_or_LetIn_names n b in
       let mkPatVar na = PatVar (dummy_loc,na) in
       let p = PatCstr (dummy_loc,(ind,i+1),List.map mkPatVar nal,Anonymous) in
       let ids = map_succeed Nameops.out_name nal in
       (dummy_loc,ids,[p],c))
-    0 brns brs
+    brs
 
 let return_type_of_predicate ind nparams nrealargs_ctxt pred =
   let nal,p = it_destRLambda_or_LetIn_names (nrealargs_ctxt+1) pred in
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 556b2477..40e3d0f8 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -1,60 +1,74 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: detyping.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Sign
 open Environ
-open Rawterm
+open Glob_term
 open Termops
 open Mod_subst
-(*i*)
 
 val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern
 
-val subst_rawconstr : substitution -> rawconstr -> rawconstr
+val subst_glob_constr : substitution -> glob_constr -> glob_constr
 
-(* [detype isgoal avoid ctx c] turns a closed [c], into a rawconstr *)
-(* de Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
-(* [isgoal] tells if naming must avoid global-level synonyms as intro does *)
-(* [ctx] gives the names of the free variables *)
+(** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr 
+   de Bruijn indexes are turned to bound names, avoiding names in [avoid] 
+   [isgoal] tells if naming must avoid global-level synonyms as intro does 
+   [ctx] gives the names of the free variables *)
 
-val detype : bool -> identifier list -> names_context -> constr -> rawconstr
+val detype : bool -> identifier list -> names_context -> constr -> glob_constr
 
 val detype_case :
-  bool -> ('a -> rawconstr) ->
+  bool -> ('a -> glob_constr) ->
   (constructor array -> int array -> 'a array ->
-    (loc * identifier list * cases_pattern list * rawconstr) list) ->
+    (loc * identifier list * cases_pattern list * glob_constr) list) ->
   ('a -> int -> bool) ->
   identifier list -> inductive * case_style * int * int array * int ->
-    'a option -> 'a -> 'a array -> rawconstr
+    'a option -> 'a -> 'a array -> glob_constr
 
-val detype_sort : sorts -> rawsort
+val detype_sort : sorts -> glob_sort
 
 val detype_rel_context : constr option -> identifier list -> names_context ->
-  rel_context -> rawdecl list
+  rel_context -> glob_decl list
 
-(* look for the index of a named var or a nondep var as it is renamed *)
+(** look for the index of a named var or a nondep var as it is renamed *)
 val lookup_name_as_displayed  : env -> constr -> identifier -> int option
 val lookup_index_as_renamed : env -> constr -> int -> int option
 
-val set_detype_anonymous : (loc -> int -> rawconstr) -> unit
+val set_detype_anonymous : (loc -> int -> glob_constr) -> unit
 val force_wildcard : unit -> bool
 val synthetize_type : unit -> bool
 
-(* Utilities to transform kernel cases to simple pattern-matching problem *)
+(** Utilities to transform kernel cases to simple pattern-matching problem *)
 
-val it_destRLambda_or_LetIn_names : int -> rawconstr -> name list * rawconstr
+val it_destRLambda_or_LetIn_names : int -> glob_constr -> name list * glob_constr
 val simple_cases_matrix_of_branches :
-  inductive -> int list -> rawconstr list -> cases_clauses
+  inductive -> (int * int * glob_constr) list -> cases_clauses
 val return_type_of_predicate :
-  inductive -> int -> int -> rawconstr -> predicate_pattern * rawconstr option
+  inductive -> int -> int -> glob_constr -> predicate_pattern * glob_constr option
+
+module PrintingInductiveMake :
+  functor (Test : sig
+    val encode : Libnames.reference -> Names.inductive
+    val member_message : Pp.std_ppcmds -> bool -> Pp.std_ppcmds
+    val field : string
+    val title : string
+  end) ->
+    sig
+      type t = Names.inductive
+      val encode : Libnames.reference -> Names.inductive
+      val subst : substitution -> t -> t
+      val printer : t -> Pp.std_ppcmds
+      val key : Goptions.option_name
+      val title : string
+      val member_message : t -> bool -> Pp.std_ppcmds
+      val synchronous : bool
+    end
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 6d080016..04f86e70 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarconv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -24,44 +22,52 @@ open Evd
 
 type flex_kind_of_term =
   | Rigid of constr
-  | MaybeFlexible of constr
+  | PseudoRigid of constr (* approximated as rigid but not necessarily so *)
+  | MaybeFlexible of constr (* approx'ed as reducible but not necessarily so *)
   | Flexible of existential
 
 let flex_kind_of_term c l =
   match kind_of_term c with
-    | Const _ -> MaybeFlexible c
-    | Rel n -> MaybeFlexible c
-    | Var id -> MaybeFlexible c
+    | Rel _ | Const _ | Var _ -> MaybeFlexible c
     | Lambda _ when l<>[] -> MaybeFlexible c
     | LetIn _  -> MaybeFlexible c
     | Evar ev -> Flexible ev
-    | _ -> Rigid c
+    | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid c
+    | Meta _ | Case _ | Fix _ -> PseudoRigid c
+    | Cast _ | App _ -> assert false
 
-let eval_flexible_term env c =
+let eval_flexible_term ts env c =
   match kind_of_term c with
-  | Const c -> constant_opt_value env c
+  | Const c -> 
+      if is_transparent_constant ts c
+      then constant_opt_value env c
+      else None
   | Rel n ->
       (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
       with Not_found -> None)
   | Var id ->
-      (try let (_,v,_) = lookup_named id env in v with Not_found -> None)
+      (try
+	 if is_transparent_variable ts id then
+	   let (_,v,_) = lookup_named id env in v 
+	 else None 
+       with Not_found -> None)
   | LetIn (_,b,_,c) -> Some (subst1 b c)
   | Lambda _ -> Some c
   | _ -> assert false
 
-let evar_apprec env evd stack c =
+let evar_apprec ts env evd stack c =
   let sigma =  evd in
   let rec aux s =
-    let (t,stack) = whd_betaiota_deltazeta_for_iota_state env sigma s in
+    let (t,stack) = whd_betaiota_deltazeta_for_iota_state ts env sigma s in
     match kind_of_term t with
       | Evar (evk,_ as ev) when Evd.is_defined sigma evk ->
 	  aux (Evd.existential_value sigma ev, stack)
       | _ -> (t, list_of_stack stack)
   in aux (c, append_stack_list stack empty_stack)
 
-let apprec_nohdbeta env evd c =
+let apprec_nohdbeta ts env evd c =
   match kind_of_term (fst (Reductionops.whd_stack evd c)) with
-    | (Case _ | Fix _) -> applist (evar_apprec env evd [] c)
+    | (Case _ | Fix _) -> applist (evar_apprec ts env evd [] c)
     | _ -> c
 
 let position_problem l2r = function
@@ -159,16 +165,15 @@ let ise_array2 evd f v1 v2 =
   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 =  evd in
-  let term1 = whd_head_evar sigma term1 in
-  let term2 = whd_head_evar sigma term2 in
+let rec evar_conv_x ts env evd pbty term1 term2 =
+  let term1 = whd_head_evar evd term1 in
+  let term2 = whd_head_evar evd term2 in
   (* 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 evd term1 term2 then
+      if is_trans_fconv pbty ts env evd term1 term2 then
         Some true
       else if is_ground_env evd env then Some false
       else None
@@ -176,19 +181,22 @@ let rec evar_conv_x env evd pbty term1 term2 =
   match ground_test with
       Some b -> (evd,b)
     | None ->
-        let term1 = apprec_nohdbeta env evd term1 in
-        let term2 = apprec_nohdbeta env evd term2 in
+	(* Until pattern-unification is used consistently, use nohdbeta to not
+	   destroy beta-redexes that can be used for 1st-order unification *)
+        let term1 = apprec_nohdbeta ts env evd term1 in
+        let term2 = apprec_nohdbeta ts env evd term2 in
         if is_undefined_evar evd term1 then
-          solve_simple_eqn evar_conv_x env evd
+          solve_simple_eqn (evar_conv_x ts) env evd
 	    (position_problem true pbty,destEvar term1,term2)
         else if is_undefined_evar evd term2 then
-          solve_simple_eqn evar_conv_x env evd
+          solve_simple_eqn (evar_conv_x ts) env evd
 	    (position_problem false pbty,destEvar term2,term1)
         else
-          evar_eqappr_x env evd pbty
+          evar_eqappr_x ts env evd pbty
             (decompose_app term1) (decompose_app term2)
 
-and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
+and evar_eqappr_x ?(rhs_is_stuck_proj = false)
+  ts env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
   (* 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) ->
@@ -196,23 +204,23 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	  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
+              [(fun i -> solve_simple_eqn (evar_conv_x ts) env i
 	        (position_problem false pbty,ev2,applist(term1,deb1)));
               (fun i -> ise_list2 i
-                  (fun i -> evar_conv_x env i CONV) rest1 l2)]
+                  (fun i -> evar_conv_x ts env i CONV) rest1 l2)]
 	  else
 	    let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
             ise_and i
-              [(fun i -> solve_simple_eqn evar_conv_x env i
+              [(fun i -> solve_simple_eqn (evar_conv_x ts) env i
 	          (position_problem true pbty,ev1,applist(term2,deb2)));
               (fun i -> ise_list2 i
-                  (fun i -> evar_conv_x env i CONV) l1 rest2)]
+                  (fun i -> evar_conv_x ts env i CONV) l1 rest2)]
 	and f2 i =
           if sp1 = sp2 then
             ise_and 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,
+                  (fun i -> evar_conv_x ts env i CONV) l1 l2);
+             (fun i -> solve_refl (evar_conv_x ts) env i sp1 al1 al2,
                   true)]
           else (i,false)
 	in
@@ -220,17 +228,17 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 
     | Flexible ev1, MaybeFlexible flex2 ->
 	let f1 i =
-	  if
-	    is_unification_pattern_evar env ev1 l1 (applist appr2) &
-	    not (occur_evar (fst ev1) (applist appr2))
-	  then
+          match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with
+          | Some l1' ->
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
 	    let t2 = nf_evar evd (applist appr2) in
-	    let t2 = solve_pattern_eqn env l1 t2 in
-	    solve_simple_eqn evar_conv_x env evd
+	    let t2 = solve_pattern_eqn env l1' t2 in
+	    solve_simple_eqn (evar_conv_x ts) env evd
 	      (position_problem true pbty,ev1,t2)
-	  else if
+          | None -> (i,false)
+        and f2 i =
+	  if
             List.length l1 <= List.length l2
 	  then
 	    (* Try first-order unification *)
@@ -240,30 +248,30 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
             ise_and i
               (* First compare extra args for better failure message *)
               [(fun i -> ise_list2 i
-                  (fun i -> evar_conv_x env i CONV) l1 rest2);
-               (fun i -> evar_conv_x env i pbty term1 (applist(term2,deb2)))]
+                  (fun i -> evar_conv_x ts env i CONV) l1 rest2);
+               (fun i -> evar_conv_x ts env i pbty term1 (applist(term2,deb2)))]
           else (i,false)
-	and f4 i =
-	  match eval_flexible_term env flex2 with
+	and f3 i =
+	  match eval_flexible_term ts env flex2 with
 	    | Some v2 ->
-		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
 	    | None -> (i,false)
 	in
-	ise_try evd [f1; f4]
+	ise_try evd [f1; f2; f3]
 
     | MaybeFlexible flex1, Flexible ev2 ->
 	let f1 i =
-	  if
-	    is_unification_pattern_evar env ev2 l2 (applist appr1) &
-	    not (occur_evar (fst ev2) (applist appr1))
-	  then
+	  match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with
+          | Some l1' ->
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
 	    let t1 = nf_evar evd (applist appr1) in
 	    let t1 = solve_pattern_eqn env l2 t1 in
-	    solve_simple_eqn evar_conv_x env evd
+	    solve_simple_eqn (evar_conv_x ts) env evd
 	      (position_problem false pbty,ev2,t1)
-	  else if
+          | None -> (i,false)
+        and f2 i =
+          if
        	    List.length l2 <= List.length l1
 	  then
 	    (* Try first-order unification *)
@@ -272,25 +280,43 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
             ise_and i
             (* First compare extra args for better failure message *)
               [(fun i -> ise_list2 i
-                  (fun i -> evar_conv_x env i CONV) rest1 l2);
-               (fun i -> evar_conv_x env i pbty (applist(term1,deb1)) term2)]
+                  (fun i -> evar_conv_x ts env i CONV) rest1 l2);
+               (fun i -> evar_conv_x ts env i pbty (applist(term1,deb1)) term2)]
           else (i,false)
-	and f4 i =
-	  match eval_flexible_term env flex1 with
+	and f3 i =
+	  match eval_flexible_term ts env flex1 with
 	    | Some v1 ->
-		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
 	    | None -> (i,false)
 	in
-	ise_try evd [f1; f4]
+	ise_try evd [f1; f2; f3]
+
+    | MaybeFlexible flex1, MaybeFlexible flex2 -> begin
+        match kind_of_term flex1, kind_of_term flex2 with
+        | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
+        let f1 i =
+          ise_and i
+	    [(fun i -> evar_conv_x ts env i CONV b1 b2);
+	     (fun i ->
+	       let b = nf_evar i b1 in
+	       let t = nf_evar i t1 in
+	       evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+	     (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)]
+	and f2 i =
+          let appr1 = evar_apprec ts env i l1 (subst1 b1 c'1)
+          and appr2 = evar_apprec ts env i l2 (subst1 b2 c'2)
+	  in evar_eqappr_x ts env i pbty appr1 appr2
+	in
+	ise_try evd [f1; f2]
 
-    | MaybeFlexible flex1, MaybeFlexible flex2 ->
+	| _, _ ->
 	let f1 i =
-	  if flex1 = flex2 then
-	    ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2
+	  if eq_constr flex1 flex2 then
+	    ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2
 	  else
 	     (i,false)
 	and f2 i =
-	  (try conv_record env i
+	  (try conv_record ts env i
              (try check_conv_record appr1 appr2
 	      with Not_found -> check_conv_record appr2 appr1)
            with Not_found -> (i,false))
@@ -299,186 +325,204 @@ 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 i appr2
-	  then
-	    match eval_flexible_term env flex1 with
+          let rhs_is_stuck_proj =
+            rhs_is_stuck_proj || is_open_canonical_projection env i appr2 in
+	  if isLambda flex1 || rhs_is_stuck_proj then
+	    match eval_flexible_term ts env flex1 with
 	    | Some v1 ->
-		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		evar_eqappr_x ~rhs_is_stuck_proj 
+                  ts env i pbty (evar_apprec ts env i l1 v1) appr2
 	    | None ->
-		match eval_flexible_term env flex2 with
+		match eval_flexible_term ts env flex2 with
 		| Some v2 ->
-		    evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+		    evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
 		| None -> (i,false)
 	  else
-	    match eval_flexible_term env flex2 with
+	    match eval_flexible_term ts env flex2 with
 	    | Some v2 ->
-		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
 	    | None ->
-		match eval_flexible_term env flex1 with
+		match eval_flexible_term ts env flex1 with
 		| Some v1 ->
-		    evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		    evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
 		| None -> (i,false)
 	in
 	ise_try evd [f1; f2; f3]
-
-    | Flexible ev1, Rigid _ ->
-	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) *)
+      end
+
+    | Rigid c1, Rigid c2 when isLambda c1 & isLambda c2 ->
+        let (na,c1,c'1) = destLambda c1 in
+        let (_,c2,c'2) = destLambda c2 in
+        assert (l1=[] & l2=[]);
+        ise_and evd
+          [(fun i -> evar_conv_x ts env i CONV c1 c2);
+           (fun i ->
+	     let c = nf_evar i c1 in
+	     evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
+
+    | Flexible ev1, (Rigid _ | PseudoRigid _) ->
+	(match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with
+        | Some l1 ->
+	  (* Miller-Pfenning's pattern unification *)
+	  (* Preserve generality thanks to eta-conversion) *)
 	  let t2 = nf_evar evd (applist appr2) in
 	  let t2 = solve_pattern_eqn env l1 t2 in
-	  solve_simple_eqn evar_conv_x env evd
+	  solve_simple_eqn (evar_conv_x ts) env evd
 	    (position_problem true pbty,ev1,t2)
-	else
+        | None ->
 	  (* Postpone the use of an heuristic *)
 	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
-	  true
-
-    | Rigid _, Flexible ev2 ->
-	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) *)
+	  true)
+
+    | (Rigid _ | PseudoRigid _), Flexible ev2 ->
+	(match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with
+        | Some l2 ->
+	  (* Miller-Pfenning's pattern unification *)
+	  (* Preserve generality thanks to eta-conversion) *)
 	  let t1 = nf_evar evd (applist appr1) in
 	  let t1 = solve_pattern_eqn env l2 t1 in
-	  solve_simple_eqn evar_conv_x env evd
+	  solve_simple_eqn (evar_conv_x ts) env evd
 	    (position_problem false pbty,ev2,t1)
-	else
+        | None ->
 	  (* Postpone the use of an heuristic *)
 	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
-	  true
+	  true)
 
-    | MaybeFlexible flex1, Rigid _ ->
+    | MaybeFlexible flex1, (Rigid _ | PseudoRigid _) ->
 	let f3 i =
-	  (try conv_record env i (check_conv_record appr1 appr2)
+	  (try conv_record ts env i (check_conv_record appr1 appr2)
            with Not_found -> (i,false))
 	and f4 i =
-	  match eval_flexible_term env flex1 with
+	  match eval_flexible_term ts env flex1 with
 	    | Some v1 ->
- 		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
 	    | None -> (i,false)
 	in
 	ise_try evd [f3; f4]
 
-    | Rigid _ , MaybeFlexible flex2 ->
+    | (Rigid _ | PseudoRigid _), MaybeFlexible flex2 ->
 	let f3 i =
-	  (try conv_record env i (check_conv_record appr2 appr1)
+	  (try conv_record ts env i (check_conv_record appr2 appr1)
            with Not_found -> (i,false))
 	and f4 i =
-	  match eval_flexible_term env flex2 with
+	  match eval_flexible_term ts env flex2 with
 	    | Some v2 ->
- 		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
 	    | None -> (i,false)
 	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)
+    (* Eta-expansion *)
+    | Rigid c1, _ when isLambda c1 ->
+	assert (l1 = []);
+	let (na,c1,c'1) = destLambda c1 in
+        let c = nf_evar evd c1 in
+	let env' = push_rel (na,None,c) env in
+        let appr1 = evar_apprec ts env' evd [] c'1 in
+	let appr2 = (lift 1 term2, List.map (lift 1) l2 @ [mkRel 1]) in
+	evar_eqappr_x ts env' evd CONV appr1 appr2
+
+    | _, Rigid c2 when isLambda c2 ->
+	assert (l2 = []);
+	let (na,c2,c'2) = destLambda c2 in
+        let c = nf_evar evd c2 in
+	let env' = push_rel (na,None,c) env in
+	let appr1 = (lift 1 term1, List.map (lift 1) l1 @ [mkRel 1]) in
+        let appr2 = evar_apprec ts env' evd [] c'2 in
+	evar_eqappr_x ts env' evd CONV appr1 appr2
+
+    | Rigid c1, Rigid c2 -> begin
+        match kind_of_term c1, kind_of_term c2 with
 
 	| 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=[] ->
-            ise_and evd
-              [(fun i -> evar_conv_x env i CONV c1 c2);
-               (fun i ->
-                 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) ->
-	    let f1 i =
-              ise_and i
-                [(fun i -> evar_conv_x env i CONV b1 b2);
-                 (fun i ->
-                   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)]
-	    and f2 i =
-              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
-	    ise_try evd [f1; f2]
-
-	| LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *)
-	     let appr1 = evar_apprec env evd l1 (subst1 b1 c'1)
-             in evar_eqappr_x env evd pbty appr1 appr2
-
-	| _, LetIn (_,b2,_,c'2) ->
-	    let appr2 = evar_apprec env evd l2 (subst1 b2 c'2)
-            in evar_eqappr_x env evd pbty appr1 appr2
+	    (try 
+	       let evd' = 
+		 if pbty = CONV 
+		 then Evd.set_eq_sort evd s1 s2 
+		 else Evd.set_leq_sort evd s1 s2 
+	       in (evd', true)
+	     with Univ.UniverseInconsistency _ -> (evd, false)
+	     | _ -> (evd, false))
 
 	| 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 -> evar_conv_x ts env i CONV c1 c2);
                (fun i ->
  	         let c = nf_evar i c1 in
-	         evar_conv_x (push_rel (n,None,c) env) i pbty c'1 c'2)]
+	         evar_conv_x ts (push_rel (n,None,c) env) i pbty c'1 c'2)]
 
 	| Ind sp1, Ind sp2 ->
 	    if eq_ind sp1 sp2 then
-              ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
+              ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2
             else (evd, false)
 
 	| Construct sp1, Construct sp2 ->
 	    if eq_constructor sp1 sp2 then
-              ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
+              ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2
             else (evd, false)
 
+	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
+            if i1=i2  then
+              ise_and evd
+                [(fun i -> ise_array2 i
+                    (fun i -> evar_conv_x ts env i CONV) tys1 tys2);
+                 (fun i -> ise_array2 i
+		     (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV)
+		     bds1 bds2);
+                 (fun i -> ise_list2 i
+                     (fun i -> evar_conv_x ts env i CONV) l1 l2)]
+            else (evd,false)
+
+	| (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _), _ -> (evd,false)
+	| _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _) -> (evd,false)
+
+	| (App _ | Meta _ | Cast _ | Case _ | Fix _), _ -> assert false
+	| (LetIn _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false
+	| (Lambda _), _ -> assert false
+
+      end
+
+    | PseudoRigid c1, PseudoRigid c2 -> begin
+        match kind_of_term c1, kind_of_term c2 with
+
 	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
             ise_and evd
-              [(fun i -> evar_conv_x env i CONV p1 p2);
-               (fun i -> evar_conv_x env i CONV c1 c2);
+              [(fun i -> evar_conv_x ts env i CONV p1 p2);
+               (fun i -> evar_conv_x ts env i CONV c1 c2);
 	       (fun i -> ise_array2 i
-                   (fun i -> evar_conv_x env i CONV) cl1 cl2);
-               (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2)]
+                   (fun i -> evar_conv_x ts env i CONV) cl1 cl2);
+               (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)]
 
 	| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
             if li1=li2 then
               ise_and evd
                 [(fun i -> ise_array2 i
-                    (fun i -> evar_conv_x env i CONV) tys1 tys2);
+                    (fun i -> evar_conv_x ts env i CONV) tys1 tys2);
                  (fun i -> ise_array2 i
-		     (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
+		     (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV)
 		     bds1 bds2);
 	         (fun i -> ise_list2 i
-                     (fun i -> evar_conv_x env i CONV) l1 l2)]
+                     (fun i -> evar_conv_x ts env i CONV) l1 l2)]
 	    else (evd,false)
-	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
-            if i1=i2  then
-              ise_and evd
-                [(fun i -> ise_array2 i
-                    (fun i -> evar_conv_x env i CONV) tys1 tys2);
-                 (fun i -> ise_array2 i
-		     (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
-		     bds1 bds2);
-                 (fun i -> ise_list2 i
-                     (fun i -> evar_conv_x env i CONV) l1 l2)]
-            else (evd,false)
 
-	| (Meta _ | Lambda _), _ -> (evd,false)
-	| _, (Meta _ | Lambda _) -> (evd,false)
+	| (Meta _ | Case _ | Fix _ | CoFix _),
+	  (Meta _ | Case _ | Fix _ | CoFix _) -> (evd,false)
+
+	| (App _ | Ind _ | Construct _ | Sort _ | Prod _), _ -> assert false
+	| _, (App _ | Ind _ | Construct _ | Sort _ | Prod _) -> assert false
 
-	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (evd,false)
-	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (evd,false)
+	| (LetIn _ | Cast _), _ -> assert false
+	| _, (LetIn _ | Cast _) -> assert false
 
-	| (App _ | Case _ | Fix _ | CoFix _),
-	  (App _ | Case _ | Fix _ | CoFix _) -> (evd,false)
+	| (Lambda _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false
+	| _, (Lambda _ | Rel _ | Var _ | Const _ | Evar _) -> assert false
+      end
 
-	| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
-	| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
+    | PseudoRigid _, Rigid _ ->  (evd,false)
 
-and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
+    | Rigid _, PseudoRigid _ ->  (evd,false)
+
+and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
   let (evd',ks,_) =
     List.fold_left
       (fun (i,ks,m) b ->
@@ -491,89 +535,259 @@ and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
   ise_and evd'
     [(fun i ->
        ise_list2 i
-         (fun i x1 x -> evar_conv_x env i CONV x1 (substl ks x))
+         (fun i x1 x -> evar_conv_x trs env i CONV x1 (substl ks x))
          params1 params);
     (fun i ->
       ise_list2 i
-        (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
+        (fun i u1 u -> evar_conv_x trs 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)]
+    (fun i -> evar_conv_x trs env i CONV c1 (applist (c,(List.rev ks))));
+    (fun i -> ise_list2 i (fun i -> evar_conv_x trs env i CONV) ts ts1)]
+
+(* getting rid of the optional argument rhs_is_stuck_proj *)
+let evar_eqappr_x ts env evd pbty appr1 appr2 =
+  evar_eqappr_x ts env evd pbty appr1 appr2
 
 (* We assume here |l1| <= |l2| *)
 
-let first_order_unification env evd (ev1,l1) (term2,l2) =
+let first_order_unification ts env evd (ev1,l1) (term2,l2) =
   let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
   ise_and evd
     (* First compare extra args for better failure message *)
-    [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest2 l1);
+    [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1);
     (fun i ->
       (* Then instantiate evar unless already done by unifying args *)
       let t2 = applist(term2,deb2) in
       if is_defined_evar i ev1 then
-	evar_conv_x env i CONV t2 (mkEvar ev1)
+	evar_conv_x ts env i CONV t2 (mkEvar ev1)
       else
-	solve_simple_eqn ~choose:true evar_conv_x env i (None,ev1,t2))]
+	solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))]
 
 let choose_less_dependent_instance evk evd term args =
-  let evi = Evd.find evd evk in
+  let evi = Evd.find_undefined evd evk in
   let subst = make_pure_subst evi args in
-  let subst' = List.filter (fun (id,c) -> c = term) subst in
+  let subst' = List.filter (fun (id,c) -> eq_constr c term) subst in
   if subst' = [] then error "Too complex unification problem." else
   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_head_evar evd t1) in
-  let t2 = apprec_nohdbeta env evd (whd_head_evar evd t2) in
+let apply_on_subterm f c t =
+  let rec applyrec (k,c as kc) t =
+    (* By using eq_constr, we make an approximation, for instance, we *)
+    (* could also be interested in finding a term u convertible to t *)
+    (* such that c occurs in u *)
+    if eq_constr c t then f k
+    else
+      map_constr_with_binders_left_to_right (fun d (k,c) -> (k+1,lift 1 c))
+	applyrec kc t
+  in
+  applyrec (0,c) t
+
+let filter_possible_projections c args =
+  let fv1 = free_rels c in
+  let fv2 = collect_vars c in
+  List.map (fun a ->
+    a == c ||
+    (* Here we make an approximation, for instance, we could also be *)
+    (* interested in finding a term u convertible to c such that a occurs *)
+    (* in u *)
+    isRel a && Intset.mem (destRel a) fv1 ||
+    isVar a && Idset.mem (destVar a) fv2)
+    args
+
+let initial_evar_data evi =
+  let ids = List.map pi1 (evar_context evi) in
+  (evar_filter evi, List.map mkVar ids)
+
+let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
+let set_solve_evars f = solve_evars := f
+
+(* We solve the problem env_rhs |- ?e[u1..un] = rhs knowing
+ * x1:T1 .. xn:Tn |- ev : ty
+ * by looking for a maximal well-typed abtraction over u1..un in rhs
+ *
+ * We first build C[e11..e1p1,..,en1..enpn] obtained from rhs by replacing
+ * all occurrences of u1..un by evars eij of type Ti' where itself Ti' has
+ * been obtained from the type of ui by also replacing all occurrences of
+ * u1..ui-1 by evars.
+ *
+ * Then, we use typing to infer the relations between the different
+ * occurrences. If some occurrence is still unconstrained after typing,
+ * we instantiate successively the unresolved occurrences of un by xn,
+ * of un-1 by xn-1, etc [the idea comes from Chung-Kil Hur, that he
+ * used for his Heq plugin; extensions to several arguments based on a
+ * proposition from Dan Grayson]
+ *)
+
+let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
+  try
+  let args = Array.to_list args in
+  let evi = Evd.find_undefined evd evk in
+  let env_evar = evar_env evi in
+  let sign = named_context_val env_evar in
+  let ctxt = evar_filtered_context evi in
+  let filter = evar_filter evi in
+  let instance = List.map mkVar (List.map pi1 ctxt) in
+
+  let rec make_subst = function
+  | (id,_,t)::ctxt, c::l, occs::occsl when isVarId id c ->
+      if occs<>None then
+        error "Cannot force abstraction on identity instance."
+      else
+        make_subst (ctxt,l,occsl)
+  | (id,_,t)::ctxt, c::l, occs::occsl ->
+      let evs = ref [] in
+      let filter = List.map2 (&&) filter (filter_possible_projections c args) in
+      let ty = Retyping.get_type_of env_rhs evd c in
+      (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt,l,occsl)
+  | [], [], [] -> []
+  | _ -> anomaly "Signature, instance and occurrences list do not match" in
+
+  let rec set_holes evdref rhs = function
+  | (id,_,c,cty,evsref,filter,occs)::subst ->
+      let set_var k =
+        match occs with
+        | Some (false,[]) -> mkVar id
+        | Some _ -> error "Selection of specific occurrences not supported"
+        | None ->
+        let evty = set_holes evdref cty subst in
+        let instance = snd (list_filter2 (fun b c -> b) (filter,instance)) in
+        let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
+        evdref := evd;
+        evsref := (fst (destEvar ev),evty)::!evsref;
+        ev in
+      set_holes evdref (apply_on_subterm set_var c rhs) subst
+  | [] -> rhs in
+
+  let subst = make_subst (ctxt,args,argoccs) in
+
+  let evdref = ref evd in
+  let rhs = set_holes evdref rhs subst in
+  let evd = !evdref in
+
+  (* We instantiate the evars of which the value is forced by typing *)
+  let evd,rhs =
+    try !solve_evars env_evar evd rhs
+    with e when Pretype_errors.precatchable_exception e ->
+      (* Could not revert all subterms *)
+      raise Exit in
+
+  let rec abstract_free_holes evd = function
+  | (id,idty,c,_,evsref,_,_)::l ->
+      let rec force_instantiation evd = function
+      | (evk,evty)::evs ->
+          let evd =
+            if is_undefined evd evk then
+              (* We force abstraction over this unconstrained occurrence *)
+              (* and we use typing to propagate this instantiation *)
+              (* This is an arbitrary choice *)
+              let evd = Evd.define evk (mkVar id) evd in
+              let evd,b = evar_conv_x ts env_evar evd CUMUL idty evty in
+              if not b then error "Cannot find an instance";
+              let evd,b = reconsider_conv_pbs (evar_conv_x ts) evd in
+              if not b then error "Cannot find an instance";
+              evd
+            else
+              evd
+          in
+          force_instantiation evd evs
+      | [] ->
+          abstract_free_holes evd l
+      in
+      force_instantiation evd !evsref
+  | [] ->
+      Evd.define evk rhs evd in
+
+  abstract_free_holes evd subst, true
+  with Exit -> evd, false
+
+let second_order_matching_with_args ts env evd ev l t =
+(*
+  let evd,ev = evar_absorb_arguments env evd ev l in
+  let argoccs = array_map_to_list (fun _ -> None) (snd ev) in
+  second_order_matching ts env evd ev argoccs t
+*)
+  (evd,false)
+
+let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
+  let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in
+  let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in
   let (term1,l1 as appr1) = decompose_app t1 in
   let (term2,l2 as appr2) = decompose_app t2 in
   match kind_of_term term1, kind_of_term term2 with
   | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = []
-      & array_for_all (fun a -> a = term2 or isEvar a) args1 ->
+      & array_for_all (fun a -> eq_constr a term2 or isEvar a) args1 ->
       (* 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 = []
-      & array_for_all (fun a -> a = term1 or isEvar a) args2 ->
+      & array_for_all (fun a -> eq_constr a term1 or isEvar a) args2 ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
       choose_less_dependent_instance evk2 evd term1 args2, true
   | Evar ev1,_ when List.length l1 <= List.length l2 ->
       (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *)
-      first_order_unification env evd (ev1,l1) appr2
+      (* and otherwise second-order matching *)
+      ise_try evd
+        [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2);
+         (fun evd ->
+           second_order_matching_with_args ts env evd ev1 l1 (applist appr2))]
   | _,Evar ev2 when List.length l2 <= List.length l1 ->
       (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *)
-      first_order_unification env evd (ev2,l2) appr1
+      (* and otherwise second-order matching *)
+      ise_try evd
+        [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1);
+         (fun evd ->
+           second_order_matching_with_args ts env evd ev2 l2 (applist appr1))]
+  | Evar ev1,_ ->
+      (* Try second-order pattern-matching *)
+      second_order_matching_with_args ts env evd ev1 l1 (applist appr2)
+  | _,Evar ev2 ->
+      (* Try second-order pattern-matching *)
+      second_order_matching_with_args ts env evd ev2 l2 (applist appr1)
   | _ ->
       (* Some head evar have been instantiated, or unknown kind of problem *)
-      evar_conv_x env evd pbty t1 t2
+      evar_conv_x ts env evd pbty t1 t2
+
+let check_problems_are_solved env evd =
+  match snd (extract_all_conv_pbs evd) with
+  | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2)
+  | _ -> ()
 
-let consider_remaining_unif_problems env evd =
+let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd =
   let (evd,pbs) = extract_all_conv_pbs evd in
-  List.fold_left
+  let heuristic_solved_evd = List.fold_left
     (fun evd (pbty,env,t1,t2) ->
-      let evd', b = apply_conversion_problem_heuristic env evd pbty t1 t2 in
+      let evd', b = apply_conversion_problem_heuristic ts env evd pbty t1 t2 in
 	if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2))
-    evd pbs
+    evd pbs in
+  check_problems_are_solved env heuristic_solved_evd;
+  Evd.fold_undefined (fun ev ev_info evd' -> match ev_info.evar_source with
+			  |_,ImpossibleCase -> 
+			     Evd.define ev (j_type (coq_unit_judge ())) evd'
+			  |_ ->
+                             match ev_info.evar_candidates with
+                             | Some (a::l) -> Evd.define ev a evd'
+                             | Some [] -> error "Unsolvable existential variables"
+                             | None -> evd') heuristic_solved_evd heuristic_solved_evd
 
 (* Main entry points *)
 
-let the_conv_x     env t1 t2 evd =
-  match evar_conv_x env evd CONV  t1 t2 with
+let the_conv_x ?(ts=full_transparent_state) env t1 t2 evd =
+  match evar_conv_x ts env evd CONV  t1 t2 with
       (evd',true) -> evd'
     | _ -> raise Reduction.NotConvertible
 
-let the_conv_x_leq env t1 t2 evd =
-  match evar_conv_x env evd CUMUL t1 t2 with
+let the_conv_x_leq ?(ts=full_transparent_state) env t1 t2 evd =
+  match evar_conv_x ts 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
+let e_conv ?(ts=full_transparent_state) env evd t1 t2 =
+  match evar_conv_x ts env !evd CONV t1 t2 with
       (evd',true) -> evd := evd'; true
     | _ -> false
 
-let e_cumul env evd t1 t2 =
-  match evar_conv_x env !evd CUMUL t1 t2 with
+let e_cumul ?(ts=full_transparent_state) env evd t1 t2 =
+  match evar_conv_x ts env !evd CUMUL t1 t2 with
       (evd',true) -> evd := evd'; true
     | _ -> false
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 50228d4e..3e2ca7ae 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -1,43 +1,47 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarconv.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
+open Names
 open Term
 open Sign
 open Environ
+open Termops
 open Reductionops
 open Evd
-(*i*)
 
-(* returns exception Reduction.NotConvertible if not unifiable *)
-val the_conv_x     : env -> constr -> constr -> evar_map -> evar_map
-val the_conv_x_leq : env -> constr -> constr -> evar_map -> evar_map
+(** returns exception Reduction.NotConvertible if not unifiable *)
+val the_conv_x     : ?ts:transparent_state -> env -> constr -> constr -> evar_map -> evar_map
+val the_conv_x_leq : ?ts:transparent_state -> env -> constr -> constr -> evar_map -> evar_map
 
-(* 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_map ref -> constr -> constr -> bool
-val e_cumul : env -> evar_map ref -> constr -> constr -> bool
+val e_conv  : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool
+val e_cumul : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool
 
-(*i For debugging *)
-val evar_conv_x :
+(**/**)
+(* For debugging *)
+val evar_conv_x : transparent_state ->
   env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool
-val evar_eqappr_x :
+val evar_eqappr_x : transparent_state ->
   env -> evar_map ->
     conv_pb -> constr * constr list -> constr * constr list ->
       evar_map * bool
-(*i*)
+(**/**)
 
-val consider_remaining_unif_problems : env -> evar_map -> evar_map
+val consider_remaining_unif_problems : ?ts:transparent_state -> env -> evar_map -> evar_map
 
 val check_conv_record : constr * types list -> constr * types list ->
   constr * constr list * (constr list * constr list) *
     (constr list * types list) *
     (constr list * types list) * constr *
     (int * constr)
+
+val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit
+
+val second_order_matching : transparent_state -> env -> evar_map -> 
+  existential -> occurrences option list -> constr -> evar_map * bool
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index b95b50b3..7d66bee0 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarutil.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Names
@@ -23,9 +21,6 @@ open Reductionops
 open Pretype_errors
 open Retyping
 
-open Pretype_errors
-open Retyping
-
 (* Expanding existential variables *)
 (* 1- flush_and_check_evars fails if an existential is undefined *)
 
@@ -63,11 +58,18 @@ let nf_evar_info evc info =
     evar_body = match info.evar_body with
       | Evar_empty -> Evar_empty
       | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) }
+let nf_evars evm =
+  Evd.fold
+    (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
+    evm Evd.empty
 
-let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
-		     evm Evd.empty
+let nf_evars_undefined evm =
+  Evd.fold_undefined
+    (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
+    evm (defined_evars evm)
 
 let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd
+let nf_evar_map_undefined evd = Evd.evars_reset_evd (nf_evars_undefined evd) evd
 
 (**********************)
 (* Creating new metas *)
@@ -76,6 +78,10 @@ let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd
 (* Generator of metavariables *)
 let new_meta =
   let meta_ctr = ref 0 in
+  Summary.declare_summary "meta counter"
+    { Summary.freeze_function = (fun () -> !meta_ctr);
+      Summary.unfreeze_function = (fun n -> meta_ctr := n);
+      Summary.init_function = (fun () -> meta_ctr := 0) };
   fun () -> incr meta_ctr; !meta_ctr
 
 let mk_new_meta () = mkMeta(new_meta())
@@ -84,14 +90,14 @@ let collect_evars emap c =
   let rec collrec acc c =
     match kind_of_term c with
       | Evar (evk,_) ->
-	  if Evd.mem emap evk & not (Evd.is_defined emap evk) then evk::acc
+	  if Evd.is_undefined emap evk then evk::acc
 	  else (* No recursion on the evar instantiation *) acc
       | _         ->
 	  fold_constr collrec acc c in
   list_uniquize (collrec [] c)
 
 let push_dependent_evars sigma emap =
-  Evd.fold (fun ev {evar_concl = ccl} (sigma',emap') ->
+  Evd.fold_undefined (fun ev {evar_concl = ccl} (sigma',emap') ->
     List.fold_left
       (fun (sigma',emap') ev ->
 	(Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev))
@@ -116,7 +122,7 @@ let push_duplicated_evars sigma emap c =
 (* replaces a mapping of existentials into a mapping of metas.
    Problem if an evar appears in the type of another one (pops anomaly) *)
 let evars_to_metas sigma (emap, c) =
-  let emap = nf_evars emap in
+  let emap = nf_evar_map_undefined emap in
   let sigma',emap' = push_dependent_evars sigma emap in
   let sigma',emap' = push_duplicated_evars sigma' emap' c in
   let change_exist evar =
@@ -129,15 +135,11 @@ let evars_to_metas sigma (emap, c) =
       | _ -> map_constr replace c in
   (sigma', replace c)
 
-(* The list of non-instantiated existential declarations *)
+(* The list of non-instantiated existential declarations (order is important) *)
 
 let non_instantiated sigma =
-  let listev = to_list sigma in
-  List.fold_left
-    (fun l (ev,evi) ->
-       if evi.evar_body = Evar_empty then
-	 ((ev,nf_evar_info sigma evi)::l) else l)
-    [] listev
+  let listev = Evd.undefined_list sigma in
+  List.map (fun (ev,evi) -> (ev,nf_evar_info sigma evi)) listev
 
 (**********************)
 (* Creating new evars *)
@@ -146,96 +148,148 @@ let non_instantiated sigma =
 (* Generator of existential names *)
 let new_untyped_evar =
   let evar_ctr = ref 0 in
+  Summary.declare_summary "evar counter"
+    { Summary.freeze_function = (fun () -> !evar_ctr);
+      Summary.unfreeze_function = (fun n -> evar_ctr := n);
+      Summary.init_function = (fun () -> evar_ctr := 0) };
   fun () -> incr evar_ctr; existential_of_int !evar_ctr
 
 (*------------------------------------*
  * functional operations on evar sets *
  *------------------------------------*)
 
-let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter instance =
-  let instance =
-    match filter with
-    | None -> instance
-    | Some filter -> snd (list_filter2 (fun b c -> b) (filter,instance)) in
+let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter ?candidates instance =
   assert
     (let ctxt = named_context_of_val sign in
      list_distinct (ids_of_named_context ctxt));
   let newevk = new_untyped_evar() in
-  let evd = evar_declare sign newevk typ ~src:src ?filter evd in
+  let evd = evar_declare sign newevk typ ~src:src ?filter ?candidates 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 =
+let compute_var_aliases sign =
   List.fold_right (fun (id,b,c) aliases ->
     match b with
     | Some t ->
-	(match kind_of_term t with
-	| Var id' ->
-	    let 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
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_id =
+              try Idmap.find id' aliases with Not_found -> [] in
+            Idmap.add id (aliases_of_id@[t]) aliases
+	| _ ->
+            Idmap.add id [t] aliases)
+    | None -> aliases)
+    sign Idmap.empty
+
+let compute_rel_aliases var_aliases rels =
+  snd (List.fold_right (fun (_,b,t) (n,aliases) ->
+    (n-1,
+     match b with
+     | Some t ->
+         (match kind_of_term t with
+         | Var id' ->
+             let aliases_of_n =
+               try Idmap.find id' var_aliases with Not_found -> [] in
+             Intmap.add n (aliases_of_n@[t]) aliases
+         | Rel p ->
+             let aliases_of_n =
+               try Intmap.find (p+n) aliases with Not_found -> [] in
+             Intmap.add n (aliases_of_n@[mkRel (p+n)]) aliases
+         | _ ->
+             Intmap.add n [lift n t] aliases)
+     | None -> aliases))
+         rels (List.length rels,Intmap.empty))
 
 let make_alias_map env =
-  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
+  (* We compute the chain of aliases for each var and rel *)
+  let var_aliases = compute_var_aliases (named_context env) in
+  let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in
   (var_aliases,rel_aliases)
 
-let 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 get_alias_chain_of aliases x = match kind_of_term x with
+  | Rel n -> (try Intmap.find n (snd aliases) with Not_found -> [])
+  | Var id -> (try Idmap.find id (fst aliases) with Not_found -> [])
+  | _ -> []
 
-let 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 normalize_alias_opt aliases x =
+  match get_alias_chain_of aliases x with
+  | []  -> None
+  | a::_ when isRel a or isVar a -> Some a
+  | [_] -> None
+  | _::a::_ -> Some a
 
-let expand_var aliases x =
-  try expand_var_at_least_once aliases x with Not_found -> x
+let normalize_alias aliases x =
+  match normalize_alias_opt aliases x with
+  | Some a -> a
+  | None -> x
 
-let expand_var_opt aliases x =
-  try Some (expand_var_at_least_once aliases x) with Not_found -> None
+let normalize_alias_var var_aliases id =
+  destVar (normalize_alias (var_aliases,Intmap.empty) (mkVar id))
 
 let extend_alias (_,b,_) (var_aliases,rel_aliases) =
   let rel_aliases =
-    Intmap.fold (fun n c -> Intmap.add (n+1) (lift 1 c))
+    Intmap.fold (fun n l -> Intmap.add (n+1) (List.map (lift 1) l))
       rel_aliases Intmap.empty in
   let rel_aliases =
     match b with
-    | Some t when isRel t or isVar t -> Intmap.add 1 (lift 1 t) rel_aliases
-    | _ -> rel_aliases in
+    | Some t ->
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_binder =
+              try Idmap.find id' var_aliases with Not_found -> [] in
+	    Intmap.add 1 (aliases_of_binder@[t]) rel_aliases
+        | Rel p ->
+            let aliases_of_binder =
+              try Intmap.find (p+1) rel_aliases with Not_found -> [] in
+	    Intmap.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
+        | _ ->
+            Intmap.add 1 [lift 1 t] rel_aliases)
+    | None -> rel_aliases in
   (var_aliases, rel_aliases)
 
+let rec expansions_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> [x]
+  | a::_ as l when isRel a || isVar a -> x :: List.rev l
+  | _::l -> x :: List.rev l
+
+let expansion_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> x
+  | a::_ -> a
+
 let rec expand_vars_in_term_using aliases t = match kind_of_term t with
   | Rel _ | Var _ ->
-      expand_var aliases t
+      normalize_alias aliases t
   | _ ->
       map_constr_with_full_binders
 	extend_alias expand_vars_in_term_using aliases t
 
 let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
 
-let 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
+let free_vars_and_rels_up_alias_expansion aliases c =
+  let acc1 = ref Intset.empty and acc2 = ref Idset.empty in
+  let rec frec (aliases,depth) c = match kind_of_term c with
+    | Rel _ | Var _ ->
+      let c = expansion_of_var aliases c in
+        (match kind_of_term c with
+        | Var id -> acc2 := Idset.add id !acc2
+        | Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1
+        | _ -> 
+            (* not optimal: would need sharing if alias occurs more than once *)
+            frec (aliases,depth) c)
+    | Const _ | Ind _ | Construct _ ->
+        acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2
+    | _ ->
+        iter_constr_with_full_binders
+          (fun d (aliases,depth) -> (extend_alias d aliases,depth+1))
+          frec (aliases,depth) c
+  in
+  frec (aliases,0) c;
+  (!acc1,!acc2)
 
 (* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
  * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
@@ -249,26 +303,38 @@ let expand_full_opt aliases y =
 
 let make_projectable_subst aliases sigma evi args =
   let sign = evar_filtered_context evi in
-  let evar_aliases = compute_aliases sign in
-  snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
-      match b,args with
+  let evar_aliases = compute_var_aliases sign in
+  let (_,full_subst,cstr_subst) =
+    List.fold_right
+      (fun (id,b,c) (args,all,cstrs) ->
+        match b,args with
 	| None, a::rest ->
 	    let a = whd_evar sigma a in
-	    (rest,Idmap.add id [a,expand_full_opt aliases a,id] l)
+	    let cstrs =
+	      let a',args = decompose_app_vect a in
+	      match kind_of_term a' with
+	      | Construct cstr ->
+		  let l = try Constrmap.find cstr cstrs with Not_found -> [] in
+		  Constrmap.add cstr ((args,id)::l) cstrs
+	      | _ -> cstrs in
+	    (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
 	| Some c, a::rest ->
 	    let a = whd_evar sigma a in
 	    (match kind_of_term c with
 	    | Var id' ->
-		let idc = 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)
+		let idc = normalize_alias_var evar_aliases id' in
+		let sub = try Idmap.find idc all with Not_found -> [] in
+		if List.exists (fun (c,_,_) -> eq_constr a c) sub then
+		  (rest,all,cstrs)
 		else
-		  (rest,Idmap.add idc ((a,expand_full_opt aliases a,id)::sub) l)
+		  (rest,
+		   Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all,
+		   cstrs)
 	    | _ ->
-		(rest,Idmap.add id [a,expand_full_opt aliases a,id] l))
+		(rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs))
 	| _ -> anomaly "Instance does not match its signature")
-    sign (array_rev_to_list args,Idmap.empty))
+      sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in
+  (full_subst,cstr_subst)
 
 let make_pure_subst evi args =
   snd (List.fold_right
@@ -322,127 +388,152 @@ let push_rel_context_to_named_context env typ =
 	let d = (id,Option.map (substl subst) c,substl subst t) in
 	(mkVar id :: subst, id::avoid, push_named d env))
       (rel_context env) ~init:([], ids, env) in
-  (named_context_val env, substl subst typ, inst_rels@inst_vars)
+  (named_context_val env, substl subst typ, inst_rels@inst_vars, subst)
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
 
-let new_evar evd env ?(src=(dummy_loc,InternalHole)) ?filter typ =
-  let sign,typ',instance = push_rel_context_to_named_context env typ in
-  new_evar_instance sign evd typ' ~src:src ?filter instance
+let new_evar evd env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates typ =
+  let sign,typ',instance,subst = push_rel_context_to_named_context env typ in
+  let candidates = Option.map (List.map (substl subst)) candidates in
+  let instance =
+    match filter with
+    | None -> instance
+    | Some filter -> snd (list_filter2 (fun b c -> b) (filter,instance)) in
+  new_evar_instance sign evd typ' ~src:src ?filter ?candidates instance
 
   (* The same using side-effect *)
-let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ty =
-  let (evd',ev) = new_evar !evdref env ~src:src ?filter ty in
+let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty =
+  let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in
   evdref := evd';
   ev
 
+(* This assumes an evar with identity instance and generalizes it over only
+   the de Bruijn part of the context *)
+let generalize_evar_over_rels sigma (ev,args) =
+  let evi = Evd.find sigma ev in
+  let sign = named_context_of_val evi.evar_hyps in
+  List.fold_left2
+    (fun (c,inst as x) a d ->
+      if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
+     (evi.evar_concl,[]) (Array.to_list args) sign
+
 (*------------------------------------*
  * operations on the evar constraints *
  *------------------------------------*)
 
-(* Pb: defined Rels and Vars should not be considered as a pattern... *)
-(*
-let is_pattern inst =
-  let rec is_hopat l = function
-      [] -> true
-    | t :: tl ->
-        (isRel t or isVar t) && not (List.mem t l) && is_hopat (t::l) tl in
-  is_hopat [] (Array.to_list inst)
-*)
+exception IllTypedFilter
+
+let check_restricted_occur evd refine env filter constr =
+  let filter = Array.of_list filter in
+  let rec aux k c =
+    let c = whd_evar evd c in
+    match kind_of_term c with
+    | Var id ->
+      let idx = list_try_find_i (fun i (id', _, _) -> if id' = id then i else raise (Failure "")) 0 env in
+	if not filter.(idx)
+	then if refine then
+	  (filter.(idx) <- true; c)
+	else raise IllTypedFilter
+	else c
+    | _ -> map_constr_with_binders succ aux k c
+  in
+  let res = aux 0 constr in
+    Array.to_list filter, res
+
+(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet
+ * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq.
+ * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)]
+ * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds.
+ *)
 
+let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env
+    inst_in_sign =
+  let ty_t_in_env = Retyping.get_type_of env evd t_in_env in
+  let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in
+  let t_in_env = whd_evar evd t_in_env in
+  let evd = define_fun env evd (destEvar evar_in_env) t_in_env in
+  let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in
+  (evd,whd_evar evd evar_in_sign)
 
-(* We have x1..xq |- ?e1 and had to solve something like
+(* 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
+ * 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,
- * but forbidding it to use the variables of Γ (otherwise said,
- * Γ is here only for ensuring the correct typing of ?e1').
+ * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends Σ with the declaration
+ * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension
+ * of the context of e1 so that e1 can be instantiated by
+ * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']),
+ * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation
+ * ?e1'[u1..uq y1..yk] = c can be registered
  *
- * 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
- * u1..up = x1'..xp'.
- *
- * 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.
- *
- * This is what [extend_evar Γ evd k (?e1[u1..uq]) c] does.
+ * Note that, because invert_definition does not check types, we need to
+ * guess the types of y1'..yn' by inverting the types of y1..yn along the
+ * substitution u1..uq.
  *)
 
-let shrink_context env subst ty =
-  let rev_named_sign = List.rev (named_context env) in
-  let rel_sign = rel_context env in
-  (* 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 ->
-	shrink_rel (i-1) subst (mkVar id::rel_subst) 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 =
-    match subst,rev_named_sign with
-    | (id,c)::subst,(id',b',t')::rev_named_sign when c = mkVar id' ->
-	shrink_named subst ((id',mkVar id)::named_subst) rev_named_sign
-    | _::_, [] ->
-	let nrel = List.length rel_sign in
-	let rel_sign, ty = shrink_rel nrel subst [] (List.rev rel_sign) in
-	[], map_rel_context (replace_vars named_subst) rel_sign,
-	replace_vars named_subst ty
-    | _ ->
-	map_named_context (replace_vars named_subst) (List.rev rev_named_sign),
-	rel_sign, ty
+let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+  let evi1 = Evd.find_undefined evd evk1 in
+  let env1,rel_sign = env_rel_context_chop k env in
+  let sign1 = evar_hyps evi1 in
+  let filter1 = evar_filter evi1 in
+  let ids1 = List.map pi1 (named_context_of_val sign1) in
+  let inst_in_sign =
+    List.map mkVar (snd (list_filter2 (fun b id -> b) (filter1,ids1))) in
+  let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
+    List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+      match b with
+      | None ->
+          let id = next_name_away na avoid in
+          let evd,t_in_sign =
+            define_evar_from_virtual_equation define_fun env evd t_in_env
+              sign filter inst_in_env inst_in_sign in
+          (push_named_context_val (id,None,t_in_sign) sign,true::filter,
+           (mkRel 1)::(List.map (lift 1) inst_in_env),(mkVar id)::inst_in_sign,
+           push_rel d env,evd,id::avoid)
+      | Some b ->
+          (sign,filter,inst_in_env,inst_in_sign,
+           push_rel d env,evd,avoid))
+      rel_sign
+      (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1)
   in
-  shrink_named subst [] rev_named_sign
-
-let extend_evar env evdref k (evk1,args1) c =
-  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 !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
-  let extenv =
-    List.fold_right push_rel rel_sign'
-      (List.fold_right push_named named_sign' (evar_unfiltered_env evi1)) in
-  let nb_to_hide = rel_context_length rel_sign' - k in
-  let rel_filter = list_map_i (fun i _ -> i > nb_to_hide) 1 rel_sign' in
-  let named_filter1 = List.map (fun _ -> true) (evar_context evi1) in
-  let named_filter2 = List.map (fun _ -> false) named_sign' in
-  let filter = rel_filter@named_filter2@named_filter1 in
-  let evar1' = e_new_evar evdref extenv ~filter:filter ty in
-  let evk1',args1'_in_env = destEvar evar1' in
-  let args1'_in_extenv = Array.map (lift k) (overwrite_first args1'_in_env args1) in
-  (evar1',(evk1',args1'_in_extenv))
-
-let subfilter p filter l =
-  let (filter,_,l) =
-    List.fold_left (fun (filter,l,newl) b ->
-      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))
-      ([],l,[]) filter in
-  (List.rev filter,List.rev l)
-
-let restrict_upon_filter evd evi evk p args =
+  let evd,ev2ty_in_sign =
+    define_evar_from_virtual_equation define_fun env evd ty_in_env
+      sign2 filter2 inst2_in_env inst2_in_sign in
+  let evd,ev2_in_sign =
+    new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in
+  let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
+  (evd, ev2_in_sign, ev2_in_env)
+
+let subfilter env ccl filter newfilter args =
+  let vars = collect_vars ccl in
+  let (filter, _, _, newargs) =
+    List.fold_left2
+      (fun (filter, newl, args, newargs) oldf (n, _, _) ->
+       if oldf then
+	 let a, oldargs = match args with hd :: tl -> hd, tl | _ -> assert false in
+	   if Idset.mem n vars then
+	     (oldf :: filter, List.tl newl, oldargs, a :: newargs)
+	   else if List.hd newl then (true :: filter, List.tl newl, oldargs, a :: newargs)
+	   else (false :: filter, List.tl newl, oldargs, newargs)
+       else (oldf :: filter, newl, args, newargs))
+    ([], newfilter, args, []) filter env
+  in List.rev filter, List.rev newargs
+
+let restrict_upon_filter ?(refine=false) evd evi evk p args =
   let filter = evar_filter evi in
-  let newfilter,newargs = subfilter p filter args in
+  let newfilter = List.map p args in
+  let env = evar_unfiltered_env evi in
+  let ccl = nf_evar evd evi.evar_concl in
+  let newfilter, newargs =
+    subfilter (named_context env) ccl filter newfilter args
+  in
   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,newev) = new_evar evd env ~src:(evar_source evk evd)
+	~filter:newfilter ccl in
     let evd = Evd.define evk newev evd in
-    evd,fst (destEvar newev),newargs
+      evd,fst (destEvar newev), newargs
   else
     evd,evk,args
 
@@ -460,6 +551,10 @@ type clear_dependency_error =
 
 exception ClearDependencyError of identifier * clear_dependency_error
 
+open Store.Field
+
+let cleared = Store.field ()
+
 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
@@ -477,7 +572,7 @@ let rec check_and_clear_in_constr evdref err ids c =
             List.iter check vars; c
 
       | Evar (evk,l as ev) ->
-	  if Evd.is_defined_evar !evdref ev then
+	  if Evd.is_defined !evdref evk then
 	    (* If evk is already defined we replace it by its definition *)
 	    let nc = whd_evar !evdref c in
 	      (check_and_clear_in_constr evdref err ids nc)
@@ -487,7 +582,7 @@ let rec check_and_clear_in_constr evdref err ids c =
 	       arguments. Concurrently, we build a new evar
 	       corresponding to e where hypotheses of ids have been
 	       removed *)
-	    let evi = Evd.find !evdref evk in
+	    let evi = Evd.find_undefined !evdref evk in
 	    let ctxt = Evd.evar_filtered_context evi in
 	    let (nhyps,nargs,rids) =
 	      List.fold_right2
@@ -521,6 +616,13 @@ let rec check_and_clear_in_constr evdref err ids c =
 	      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
+	    (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
+	      let evi = Evd.find !evdref evk in
+	      let extra = evi.evar_extra in
+	      let extra' = cleared.set true extra in
+	      let evi' = { evi with evar_extra = extra' } in
+	      evdref := Evd.add !evdref evk evi' ;
+	    (* spiwack: /hacking session *)
 	      mkEvar(evk', Array.of_list nargs)
             end
 
@@ -553,6 +655,20 @@ let clear_hyps_in_evi evdref hyps concl ids =
   in
   (nhyps,nconcl)
 
+(* Inverting constructors in instances (common when inferring type of match) *)
+
+let find_projectable_constructor env evd cstr k args cstr_subst =
+  try
+    let l = Constrmap.find cstr cstr_subst in
+    let args = Array.map (lift (-k)) args in
+    let l =
+      List.filter (fun (args',id) ->
+	(* is_conv is maybe too strong (and source of useless computation) *)
+	(* (at least expansion of aliases is needed) *)
+	array_for_all2 (is_conv env evd) args args') l in
+    List.map snd l
+  with Not_found ->
+    []
 
 (* [find_projectable_vars env sigma y subst] finds all vars of [subst]
  * that project on [y]. It is able to find solutions to the following
@@ -597,17 +713,17 @@ 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
+      if eq_constr y c' then id
       else
 	if l <> [] then assoc_up_to_alias sigma aliases y yc l
 	else
 	  (* Last chance, we reason up to alias conversion *)
-	  match (if c == c' then cc else expand_full_opt aliases c') with
-	  | Some cc when yc = cc -> id
-	  | _ -> raise Not_found
+	  match (if c == c' then cc else normalize_alias_opt aliases c') with
+	  | Some cc when eq_constr yc cc -> id
+	  | _ -> if eq_constr yc c then id else raise Not_found
 
 let rec find_projectable_vars with_evars aliases sigma y subst =
-  let yc = expand_var aliases y in
+  let yc = normalize_alias aliases y in
   let is_projectable idc idcl subst' =
     (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *)
     try
@@ -623,7 +739,7 @@ let rec find_projectable_vars with_evars aliases sigma y subst =
 	  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 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'
@@ -680,7 +796,7 @@ let rec do_projection_effects define_fun env ty evd = function
 	let subst = make_pure_subst evi argsv in
 	let ty' = replace_vars subst evi.evar_concl in
 	let ty' = whd_evar evd ty' in
-	if isEvar ty' then define_fun env (destEvar ty') ty evd else evd
+	if isEvar ty' then define_fun env evd (destEvar ty') ty else evd
       else
 	evd
 
@@ -741,7 +857,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 evd t) in
+  let ty = lazy (nf_evar evd (Retyping.get_type_of env evd t)) in
   match projs with
   | NoUniqueProjection -> raise NotUnique
   | UniqueProjection (c,effects) ->
@@ -767,7 +883,7 @@ let filter_along f projs v =
  * such that "hyps' |- ?e : T"
  *)
 
-let restrict_hyps evd evk filter =
+let restrict_hyps ?(refine=false) evd evk filter =
     (* What to do with dependencies?
        Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y.
        - If y is in a non-erasable position in C(x,y) (i.e. it is not below an
@@ -783,8 +899,9 @@ let restrict_hyps evd evk filter =
     let oldfilter = evar_filter evi in
     let filter,_ = List.fold_right (fun oldb (l,filter) ->
       if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
-      oldfilter ([],List.rev filter) in
-    (env,evar_source evk evd,filter,evi.evar_concl)
+      oldfilter ([], List.rev filter) in
+    let filter, ccl = check_restricted_occur evd refine (named_context env) filter evi.evar_concl in
+    (env,evar_source evk evd,filter,ccl)
 
 let do_restrict_hyps evd evk projs =
   let filter = List.map filter_of_projection projs in
@@ -792,14 +909,18 @@ let do_restrict_hyps evd evk projs =
     evd,evk
   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.define evk nc evd in
-    let evk',_ = destEvar nc in
-    evd,evk'
+      if List.for_all (fun x -> x) filter then
+	evd,evk
+      else
+	let evd,nc = new_evar evd env ~src ~filter ccl in
+	let evd = Evd.define evk nc evd in
+	let evk',_ = destEvar nc in
+	  evd,evk'
 
 (* [postpone_evar_term] postpones an equation of the form ?e[σ] = c *)
 
 let postpone_evar_term env evd (evk,argsv) rhs =
+  assert (isVar rhs or isRel rhs);
   let rhs = expand_vars_in_term env rhs in
   let evi = Evd.find evd evk in
   let evd,evk,args =
@@ -850,44 +971,71 @@ let are_canonical_instances args1 args2 env =
   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) ->
+	when n < n1 && isVar args1.(n) && destVar args1.(n) = id && eq_constr 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))
+	  (isRel args1.(n) && destRel args1.(n) = n1-n &&
+	   isRel args2.(n) && destRel args2.(n) = n1-n && aux2 (n+1))
 	in aux2 n
     | _ -> false in
   n1 = n2 & aux 0 (named_context env)
 
 exception CannotProject of projectibility_status list
 
+let is_variable_subst args =
+  array_for_all (fun c -> isRel c || isVar c) args
+
 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
+  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.define evk2 (mkEvar(evk1',Array.of_list args1')) evd
-  with NotUnique ->
-    raise (CannotProject proj1)
+    (* Only try pruning on variable substitutions, postpone otherwise. *)
+    if is_variable_subst args1 && is_variable_subst args2 then
+      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.
+	     Rules out non-linear instances. *)
+	  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.define evk2 (mkEvar(evk1',Array.of_list args1')) evd
+	with NotUnique -> raise (CannotProject proj1)
+    else raise IllTypedFilter
 
 let solve_evar_evar f env evd ev1 ev2 =
-  try solve_evar_evar_l2r f env evd ev1 ev2
-  with CannotProject projs1 ->
-  try solve_evar_evar_l2r f env evd ev2 ev1
-  with CannotProject projs2 ->
-  postpone_evar_evar env evd projs1 ev1 projs2 ev2
+  try
+    try solve_evar_evar_l2r f env evd ev1 ev2
+    with CannotProject projs1 ->
+    try solve_evar_evar_l2r f env evd ev2 ev1
+    with CannotProject projs2 ->
+    postpone_evar_evar env evd projs1 ev1 projs2 ev2
+  with IllTypedFilter ->
+    let pb = (Reduction.CONV,env,mkEvar(ev1),mkEvar (ev2)) in
+      add_conv_pb pb evd
+
+type conv_fun =
+  env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool
+
+let check_evar_instance evd evk1 body conv_algo =
+  let evi = Evd.find evd evk1 in
+  let evenv = evar_unfiltered_env evi in
+  (* FIXME: The body might be ill-typed when this is called from w_merge *)
+  let ty =
+    try Retyping.get_type_of evenv evd body
+    with _ -> error "Ill-typed evar instance"
+  in
+  let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in
+  if b then evd else
+    user_err_loc (fst (evar_source evk1 evd),"",
+		  str "Unable to find a well-typed instantiation")
 
 (* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
  * definitions. We try to unify the xi with the yi pairwise. The pairs
@@ -895,8 +1043,8 @@ let solve_evar_evar f env evd ev1 ev2 =
  * 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
+  if array_equal eq_constr argsv1 argsv2 then evd else
+  let evi = Evd.find_undefined evd evk in
   (* Filter and restrict if needed *)
   let evd,evk,args =
     restrict_upon_filter evd evi evk
@@ -906,7 +1054,37 @@ let solve_refl conv_algo env evd evk argsv1 argsv2 =
   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
+    Evd.add_conv_pb pb evd
+
+(* If the evar can be instantiated by a finite set of candidates known
+   in advance, we check which of them apply *)
+
+exception NoCandidates
+
+let solve_candidates conv_algo env evd (evk,argsv as ev) rhs =
+  let evi = Evd.find evd evk in
+  let args = Array.to_list argsv in
+  match evi.evar_candidates with
+  | None -> raise NoCandidates
+  | Some l ->
+      let l' = list_map_filter (fun c ->
+        let c' = instantiate_evar (evar_filtered_context evi) c args in
+        let evd, b = conv_algo env evd Reduction.CONV c' rhs in
+        if b then Some (c,evd) else None) l in
+      match l' with
+      | [] -> error_cannot_unify env evd (mkEvar ev, rhs)
+      | [c,evd] -> Evd.define evk c evd
+      | l when List.length l < List.length l' ->
+          let candidates = List.map fst l in
+          let filter = evar_filter evi in
+          let sign = evar_hyps evi in
+          let ids = List.map pi1 (named_context_of_val sign) in
+          let inst_in_sign =
+            List.map mkVar (snd (list_filter2 (fun b id -> b) (filter,ids))) in
+          let evd,evar = new_evar_instance (evar_hyps evi) evd (evar_concl evi)
+            ~filter ~candidates inst_in_sign in
+          Evd.define evk evar evd
+      | l -> evd
 
 (* We try to instantiate the evar assuming the body won't depend
  * on arguments that are not Rels or Vars, or appearing several times
@@ -925,7 +1103,7 @@ let solve_refl conv_algo env evd evk argsv1 argsv2 =
  * 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] c]
  * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
  * Postcondition: if φ(x1..xn) is returned then
  *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
@@ -935,12 +1113,12 @@ 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 rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs =
   let aliases = make_alias_map env in
   let evdref = ref evd in
   let progress = ref false in
   let evi = Evd.find evd evk in
-  let subst = make_projectable_subst aliases evd evi argsv in
+  let subst,cstr_subst = make_projectable_subst aliases evd evi argsv in
 
   (* Projection *)
   let project_variable t =
@@ -955,7 +1133,7 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	    else raise (NotUniqueInType(find_solution_type (evar_env evi) sols))
       in
       let ty = lazy (Retyping.get_type_of env !evdref t) in
-      let evd = do_projection_effects evar_define env ty !evdref p in
+      let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in
       evdref := evd;
       c
     with
@@ -963,11 +1141,16 @@ 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 *)
+          (* materializing is necessary, but is restricting useful? *)
+          let sign = evar_filtered_context evi in
+          let ty' = instantiate_evar sign ty (Array.to_list argsv) in
+	  let (evd,_,ev') =
+            materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in
 	  let ts = expansions_of_var aliases t in
 	  let test c = isEvar c or List.mem c ts in
 	  let filter = array_map_to_list test argsv in
+	  let evarenv,src,filter,_ = restrict_hyps ~refine:true evd (fst ev') filter in
 	  let args' = filter_along (fun x -> x) filter argsv in
-	  let evarenv,src,filter,_ = restrict_hyps !evdref evk filter in
 	  let evd,evar = new_evar !evdref evarenv ~src ~filter ty in
 	  let evk',_ = destEvar evar in
 	  let pb = (Reduction.CONV,env,mkEvar(evk',args'),t) in
@@ -986,32 +1169,52 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	  array_map_to_list
 	    (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' =
-	    list_fold_map (instance_of_projection evar_define env' t)
-	      !evdref eprojs' in
-	  let evd,evk' = do_restrict_hyps evd evk' projs' in
-	  evdref := evd;
-	  mkEvar (evk',Array.of_list args')
-	with NotUnique ->
-	  assert !progress;
-	  (* Make the virtual left evar real *)
-	  let (evar'',ev'') = extend_evar env' evdref k ev t in
-	  let evd =
-	    (* Try to project (a restriction of) the left evar ... *)
-	    try solve_evar_evar_l2r evar_define env' !evdref ev'' ev'
-	    with CannotProject projs'' ->
-	    (* ... or postpone the problem *)
-	    postpone_evar_evar env' !evdref projs'' ev'' projs' ev' in
-	  evdref := evd;
-	  evar'')
+	  (try
+	     (* Try to project (a restriction of) the right evar *)
+	     let eprojs' = effective_projections projs' in
+	     let evd,args' =
+	       list_fold_map (instance_of_projection (evar_define conv_algo) env' t)
+	         !evdref eprojs' in
+	     let evd,evk' = do_restrict_hyps evd evk' projs' in
+	       evdref := evd;
+	       mkEvar (evk',Array.of_list args')
+	   with NotUnique | IllTypedFilter ->
+	   assert !progress;
+	   (* Make the virtual left evar real *)
+	   let ty = get_type_of env' !evdref t in
+	   let (evd,evar'',ev'') =
+             materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
+	     (try
+		let evd =
+		  (* Try to project (a restriction of) the left evar ... *)
+		  try solve_evar_evar_l2r (evar_define conv_algo) env' evd ev'' ev'
+		  with CannotProject projs'' ->
+		    (* ... or postpone the problem *)
+		    postpone_evar_evar env' evd projs'' ev'' projs' ev'
+		in
+	          evdref := evd;
+		  evar''
+	      with IllTypedFilter -> raise (NotInvertibleUsingOurAlgorithm t)))
     | _ ->
-	progress := true;
-	(* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
-	map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
-	  imitate envk t in
+	match
+	  let c,args = decompose_app_vect t in
+	  match kind_of_term c with
+	  | Construct cstr when noccur_between 1 k t ->
+	    (* This is common case when inferring the return clause of match *)
+	    (* (currently rudimentary: we do not treat the case of multiple *)
+            (*  possible inversions; we do not treat overlap with a possible *)
+            (*  alternative inversion of the subterms of the constructor, etc)*)
+	    (match find_projectable_constructor env evd cstr k args cstr_subst with
+	     | [id] -> Some (mkVar id)
+	     | _ -> None)
+	  | _ -> None
+	with
+	| Some c -> c
+	| None ->
+	  progress := true;
+	  (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
+	  map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+	    imitate envk t in
 
   let rhs = whd_beta evd rhs (* heuristic *) in
   let body = imitate (env,0) rhs in
@@ -1024,15 +1227,16 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
  * context "hyps" and not referring to itself.
  *)
 
-and occur_existential evm c =
-  let rec occrec c = match kind_of_term c with
-    | Evar (e, _) -> if not (is_defined evm e) then raise Occur
-    | _ -> iter_constr occrec c
-  in try occrec c; false with Occur -> true
-
-and evar_define ?(choose=false) env (evk,argsv as ev) rhs evd =
+and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs =
+  match kind_of_term rhs with
+  | Evar (evk2,argsv2 as ev2) ->
+      if evk = evk2 then solve_refl conv_algo env evd evk argsv argsv2
+      else solve_evar_evar (evar_define conv_algo) env evd ev ev2
+  | _ ->
+  try solve_candidates conv_algo env evd ev rhs
+  with NoCandidates ->
   try
-    let (evd',body) = invert_definition choose env evd ev rhs in
+    let (evd',body) = invert_definition conv_algo choose env evd ev rhs in
     if occur_meta body then error "Meta cannot occur in evar body.";
     (* invert_definition may have instantiate some evars of rhs with evk *)
     (* so we recheck acyclicity *)
@@ -1055,7 +1259,8 @@ and evar_define ?(choose=false) env (evk,argsv as ev) rhs evd =
            str "----> " ++ int ev ++ str " := " ++
            print_constr body);
         raise e in*)
-    Evd.define evk body evd'
+    let evd' = Evd.define evk body evd' in
+    check_evar_instance evd' evk body conv_algo
   with
     | NotEnoughInformationToProgress ->
 	postpone_evar_term env evd ev rhs
@@ -1133,73 +1338,108 @@ let whd_head_evar_stack sigma 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
-   distinct from the ones in l *)
-
-let rec expand_and_check_vars env = function
+let rec expand_and_check_vars aliases = function
   | [] -> []
-  | a::l ->
-      if isRel a or isVar a then
-	let l = expand_and_check_vars env l in
-	match expand_var_opt env a with
-	| None -> a :: l
-	| Some a' when isRel a' or isVar a' -> list_add_set a' l
-	| _ -> raise Exit
-      else
-	raise Exit
+  | a::l when isRel a or isVar a ->
+      let a = expansion_of_var aliases a in
+      if isRel a or isVar a then a :: expand_and_check_vars aliases l
+      else raise Exit
+  | _ ->
+      raise Exit
+
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+
+let rec constr_list_distinct l =
+  let visited = Constrhash.create 23 in
+  let rec loop = function
+    | h::t ->
+	if Constrhash.mem visited h then false
+	else (Constrhash.add visited h h; loop t)
+    | [] -> true
+  in loop l
+
+let get_actual_deps aliases l t =
+  if occur_meta_or_existential t then
+    (* Probably no restrictions on allowed vars in presence of evars *)
+    l
+  else
+    (* Probably strong restrictions coming from t being evar-closed *)
+    let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
+    List.filter (fun c ->
+      match kind_of_term c with
+      | Var id -> Idset.mem id fv_ids
+      | Rel n -> Intset.mem n fv_rels
+      | _ -> assert false) l
+
+let remove_instance_local_defs evd evk args =
+  let evi = Evd.find evd evk in
+  let rec aux = function
+  | (_,Some _,_)::sign, a::args -> aux (sign,args)
+  | (_,None,_)::sign, a::args -> a::aux (sign,args)
+  | [], [] -> []
+  | _ -> assert false in
+  aux (evar_filtered_context evi, args)
+
+(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
 
-let is_unification_pattern_evar env (_,args) l t =
-  List.for_all (fun x -> isRel x || isVar x) l (* common failure case *)
-  &&
+let find_unification_pattern_args env l t =
+  if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then
     let aliases = make_alias_map env in
-    let l' = Array.to_list args @ l in
-    let l'' = try Some (expand_and_check_vars aliases l') with Exit -> None in
-    match l'' with
-    | Some l ->
-	let deps =
-	  if occur_meta_or_existential t then
-	    (* Probably no restrictions on allowed vars in presence of evars *)
-	    l
-	  else
-	    (* Probably strong restrictions coming from t being evar-closed *)
-	    let 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 ->
-	      match kind_of_term c with
-	      | Var id -> List.mem id fv_ids
-	      | Rel n -> Intset.mem n fv_rels
-	      | _ -> assert false) l in
-	list_distinct deps
-    | None -> false
-
-let is_unification_pattern (env,nb) f l t =
-  match kind_of_term f with
-    | Meta _ ->
-	array_for_all (fun c -> isRel c && destRel c <= nb) l
-	&& array_distinct l
-    | Evar ev ->
-	is_unification_pattern_evar env ev (Array.to_list l) t
-    | _ ->
-	false
+    match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
+    | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_meta env nb m l t =
+  (* Variables from context and rels > nb are implicitly all there *)
+  (* so we need to be a rel <= nb *)
+  if List.for_all (fun x -> isRel x && destRel x <= nb) l then
+    match find_unification_pattern_args env l t with
+    | Some _ as x when not (dependent (mkMeta m) t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_evar env evd (evk,args) l t =
+  if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then
+    let args = remove_instance_local_defs evd evk (Array.to_list args) in
+    let n = List.length args in
+    match find_unification_pattern_args env (args @ l) t with
+    | Some l when not (occur_evar evk t) -> Some (list_skipn n l)
+    | _ -> None
+  else
+    None
 
-(* 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
+let is_unification_pattern (env,nb) evd f l t =
+  match kind_of_term f with
+  | Meta m -> is_unification_pattern_meta env nb m l t
+  | Evar ev -> is_unification_pattern_evar env evd ev l t
+  | _ -> None
+
+(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
+   (pattern unification). It is assumed that l is made of rel's that
+   are distinct and not bound to aliases. *)
+(* It is also assumed that c does not contain metas because metas
    *implicitly* depend on Vars but lambda abstraction will not reflect this
    dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
    return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
-let solve_pattern_eqn env l1 c =
-  let l1 = List.map (expand_var (make_alias_map env)) l1 in
+let solve_pattern_eqn env l c =
   let c' = List.fold_right (fun a c ->
     let c' = subst_term (lift 1 a) (lift 1 c) in
     match kind_of_term a with
       (* Rem: if [a] links to a let-in, do as if it were an assumption *)
-      | Rel n -> let (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'
+      | Rel n ->
+          let d = map_rel_declaration (lift n) (lookup_rel n env) in
+          mkLambda_or_LetIn d c'
+      | Var id ->
+          let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
       | _ -> assert false)
-    l1 c in
+    l c in
   (* Warning: we may miss some opportunity to eta-reduce more since c'
      is not in normal form *)
   whd_eta c'
@@ -1234,23 +1474,12 @@ let status_changed lev (pbty,_,t1,t2) =
   (try ExistentialSet.mem (head_evar t1) lev with NoHeadEvar -> false) or
   (try ExistentialSet.mem (head_evar t2) lev with NoHeadEvar -> false)
 
-(* Util *)
-
-let check_instance_type conv_algo env evd ev1 t2 =
-  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 evd (refresh_universes t2) in
-    if isEvar typ2 then (* Don't want to commit too early too *) evd
-    else
-      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),"",
-	  str "Unable to find a well-typed instantiation")
+let reconsider_conv_pbs conv_algo evd =
+  let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
+  List.fold_left
+    (fun (evd,b as p) (pbty,env,t1,t2) ->
+      if b then conv_algo env evd pbty t1 t2 else p) (evd,true)
+    pbs
 
 (* Tries to solve problem t1 = t2.
  * Precondition: t1 is an uninstantiated evar
@@ -1261,51 +1490,69 @@ let check_instance_type conv_algo env evd ev1 t2 =
 let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) =
   try
     let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
-    let evd = match kind_of_term t2 with
-      | Evar (evk2,args2 as ev2) ->
-	  if evk1 = evk2 then
-	    solve_refl conv_algo env evd evk1 args1 args2
-	  else
-	    if pbty = None
-	    then solve_evar_evar evar_define env evd ev1 ev2
-	    else if pbty = Some true then
-	      add_conv_pb (Reduction.CUMUL,env,mkEvar ev1,t2) evd
-	    else
-	      add_conv_pb (Reduction.CUMUL,env,t2,mkEvar ev1) evd
+    let evd =
+      match pbty with
+      | Some true when isEvar t2 ->
+          add_conv_pb (Reduction.CUMUL,env,mkEvar ev1,t2) evd
+      | Some false when isEvar t2 ->
+          add_conv_pb (Reduction.CUMUL,env,t2,mkEvar ev1) evd
       | _ ->
-	  let evd =
-	    if pbty = Some false then
-	      check_instance_type conv_algo env evd ev1 t2
-	    else
-	      evd in
-	  let evd = evar_define ~choose env ev1 t2 evd in
-	  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_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 *)
-		    evd
-	    else evd
-    in
-    let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
-      List.fold_left
-	(fun (evd,b as p) (pbty,env,t1,t2) ->
-	  if b then conv_algo env evd pbty t1 t2 else p) (evd,true)
-	pbs
+          evar_define conv_algo ~choose env evd ev1 t2 in
+    reconsider_conv_pbs conv_algo evd
   with e when precatchable_exception e ->
     (evd,false)
 
+(** The following functions return the set of evars immediately
+    contained in the object, including defined evars *)
+
 let evars_of_term c =
   let rec evrec acc c =
     match kind_of_term c with
-    | Evar (n, _) -> Intset.add n acc
+    | Evar (n, l) -> Intset.add n (Array.fold_left evrec acc l)
     | _ -> fold_constr evrec acc c
   in
-    evrec Intset.empty c
+  evrec Intset.empty c
+
+(* spiwack: a few functions to gather the existential variables
+   that occur in the types of goals present or past. *)
+let add_evars_of_evars_of_term acc evm c =
+  let evars = evars_of_term c in
+  Intset.fold begin fun e r ->
+    let body = (Evd.find evm e).evar_body in
+    let subevars =
+      match body with
+      | Evar_empty -> None
+      | Evar_defined c' -> Some (evars_of_term c')
+    in
+    Intmap.add e subevars r
+  end evars acc
+
+let evars_of_evars_of_term = add_evars_of_evars_of_term Intmap.empty
+
+let add_evars_of_evars_in_type acc evm e =
+  let evi = Evd.find evm e in
+  let acc_with_concl = add_evars_of_evars_of_term acc evm evi.evar_concl in
+  let hyps = Environ.named_context_of_val evi.evar_hyps in
+  List.fold_left begin fun r (_,b,t) ->
+    let r = add_evars_of_evars_of_term r evm t in
+    match b with
+    | None -> r
+    | Some b -> add_evars_of_evars_of_term r evm b
+  end acc_with_concl hyps
+
+let rec add_evars_of_evars_in_types_of_set acc evm s =
+  Intset.fold begin fun e r ->
+    let r = add_evars_of_evars_in_type r evm e in
+    match (Evd.find evm e).evar_body with
+    | Evar_empty -> r
+    | Evar_defined b -> add_evars_of_evars_in_types_of_set r evm (evars_of_term b)
+  end s acc
+
+let evars_of_evars_in_types_of_list evm l =
+  let set_of_l = List.fold_left (fun x y -> Intset.add y x) Intset.empty l in
+  add_evars_of_evars_in_types_of_set Intmap.empty evm set_of_l
+
+(* /spiwack *)
 
 let evars_of_named_context nc =
   List.fold_right (fun (_, b, t) s ->
@@ -1322,34 +1569,60 @@ let evars_of_evar_info evi =
 	| Evar_defined b -> evars_of_term b)
 	(evars_of_named_context (named_context_of_val evi.evar_hyps)))
 
+(** The following functions return the set of undefined evars
+    contained in the object, the defined evars being traversed.
+    This is roughly a combination of the previous functions and
+    [nf_evar]. *)
+
+let undefined_evars_of_term evd t =
+  let rec evrec acc c =
+    match kind_of_term c with
+      | Evar (n, l) ->
+	let acc = Array.fold_left evrec acc l in
+	(try match (Evd.find evd n).evar_body with
+	  | Evar_empty -> Intset.add n acc
+	  | Evar_defined c -> evrec acc c
+	 with Not_found -> anomaly "undefined_evars_of_term: evar not found")
+      | _ -> fold_constr evrec acc c
+  in
+  evrec Intset.empty t
+
+let undefined_evars_of_named_context evd nc =
+  List.fold_right (fun (_, b, t) s ->
+    Option.fold_left (fun s t ->
+      Intset.union s (undefined_evars_of_term evd t))
+      (Intset.union s (undefined_evars_of_term evd t)) b)
+    nc Intset.empty
+
+let undefined_evars_of_evar_info evd evi =
+  Intset.union (undefined_evars_of_term evd evi.evar_concl)
+    (Intset.union
+       (match evi.evar_body with
+	 | Evar_empty -> Intset.empty
+	 | Evar_defined b -> undefined_evars_of_term evd b)
+       (undefined_evars_of_named_context evd
+	  (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 =  evd in
-  let c = nf_evar sigma c in
+let check_evars env initial_sigma sigma c =
   let rec proc_rec c =
     match kind_of_term c with
-      | Evar (evk,args) ->
-          assert (Evd.mem sigma evk);
+    | Evar (evk,_ as ev) ->
+        (match existential_opt_value sigma ev with
+        | Some c -> proc_rec c
+        | None ->
 	  if not (Evd.mem initial_sigma evk) then
             let (loc,k) = evar_source evk sigma in
-	      (match k with
+	      match k with
 	      | ImplicitArg (gr, (i, id), false) -> ()
 	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
+		  let evi = nf_evar_info sigma (Evd.find_undefined 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)
+open Glob_term
 
 (* Operations on value/type constraints *)
 
@@ -1390,44 +1663,96 @@ let empty_valcon = None
 (* Builds a value constraint *)
 let mk_valcon c = Some c
 
-(* Refining an evar to a product or a sort *)
 
-(* Declaring any type to be in the sort Type shouldn't be harmful since
-   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 evd ev in
+let new_type_evar ?src ?filter evd env =
+  let evd', s = new_sort_variable evd in
+    new_evar evd' env ?src ?filter (mkSort s)
+
+let idx = id_of_string "x"
+
+(* Refining an evar to a product *)
+
+let define_pure_evar_as_product evd evk =
+  let evi = Evd.find_undefined evd evk in
   let evenv = evar_unfiltered_env evi in
-  let (evd1,dom) = new_evar evd evenv (new_Type()) ~filter:(evar_filter evi) in
-  let nvar =
-    next_ident_away (id_of_string "x")
-      (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())
-      ~filter:(true::evar_filter evi) in
-  let prod = abs (Name nvar, dom, subst_var nvar rng) 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)
-
-let define_evar_as_lambda evd (ev,args) =
-  define_evar_as_abstraction (fun t -> mkLambda t) evd (ev,args)
+  let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
+  let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in
+  let evd2,rng =
+    let newenv = push_named (id, None, dom) evenv in
+    let src = evar_source evk evd1 in
+    let filter = true::evar_filter evi in
+    new_type_evar evd1 newenv ~src ~filter in
+  let prod = mkProd (Name id, dom, subst_var id rng) in
+  let evd3 = Evd.define evk prod evd2 in
+  evd3,prod
+
+(* Refine an applied evar to a product and returns its instantiation *)
+
+let define_evar_as_product evd (evk,args) =
+  let evd,prod = define_pure_evar_as_product evd evk in
+  (* Quick way to compute the instantiation of evk with args *)
+  let na,dom,rng = destProd prod in
+  let evdom = mkEvar (fst (destEvar dom), args) in
+  let evrngargs = array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let evrng =  mkEvar (fst (destEvar rng), evrngargs) in
+  evd,mkProd (na, evdom, evrng)
+
+(* Refine an evar with an abstraction
+
+   I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
+   - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
+     or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
+        with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
+   - x1..xq,y:A |- ?e':B
+*)
+
+let define_pure_evar_as_lambda env evd evk =
+  let evi = Evd.find_undefined evd evk in
+  let evenv = evar_unfiltered_env evi in
+  let typ = whd_betadeltaiota env evd (evar_concl evi) in
+  let evd1,(na,dom,rng) = match kind_of_term typ with
+  | Prod (na,dom,rng) -> (evd,(na,dom,rng))
+  | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
+  | _ -> error_not_product_loc dummy_loc env evd typ in
+  let avoid = ids_of_named_context (evar_context evi) in
+  let id =
+    next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
+  let newenv = push_named (id, None, dom) evenv in
+  let filter = true::evar_filter evi in
+  let src = evar_source evk evd1 in
+  let evd2,body = new_evar evd1 newenv ~src (subst1 (mkVar id) rng) ~filter in
+  let lam = mkLambda (Name id, dom, subst_var id body) in
+  Evd.define evk lam evd2, lam
+
+let define_evar_as_lambda env evd (evk,args) =
+  let evd,lam = define_pure_evar_as_lambda env evd evk in
+  (* Quick way to compute the instantiation of evk with args *)
+  let na,dom,body = destLambda lam in
+  let evbodyargs = array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let evbody = mkEvar (fst (destEvar body), evbodyargs) in
+  evd,mkLambda (na, dom, evbody)
+
+let rec evar_absorb_arguments env evd (evk,args as ev) = function
+  | [] -> evd,ev
+  | a::l ->
+      (* TODO: optimize and avoid introducing intermediate evars *)
+      let evd,lam = define_pure_evar_as_lambda env evd evk in
+      let _,_,body = destLambda lam in
+      let evk = fst (destEvar body) in
+      evar_absorb_arguments env evd (evk, array_cons a args) l
+
+(* Refining an evar to a sort *)
 
 let define_evar_as_sort evd (ev,args) =
-  let s = new_Type () in
-  Evd.define ev s evd, destSort s
+  let evd, s = new_sort_variable evd in
+    Evd.define ev (mkSort s) evd, s
 
 (* We don't try to guess in which sort the type should be defined, since
    any type has type Type. May cause some trouble, but not so far... *)
 
-let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
+let judge_of_new_Type evd =
+  let evd', s = new_univ_variable evd in
+    evd', Typeops.judge_of_type s
 
 (* Propagation of constraints through application and abstraction:
    Given a type constraint on a functional term, returns the type
@@ -1443,10 +1768,13 @@ let split_tycon loc env evd tycon =
     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) ->
+	| Evar ev (* ev is undefined because of whd_betadeltaiota *) ->
 	    let (evd',prod) = define_evar_as_product evd ev in
 	    let (_,dom,rng) = destProd prod in
 	      evd',(Anonymous, dom, rng)
+	| App (c,args) when isEvar c ->
+	    let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
+	    real_split evd' (mkApp (lam,args))
 	| _ -> error_not_product_loc loc env evd c
   in
     match tycon with
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index e29effc2..61f503c7 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -1,117 +1,148 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarutil.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
-open Rawterm
+open Glob_term
 open Term
 open Sign
 open Evd
 open Environ
 open Reductionops
-(*i*)
 
-(*s This modules provides useful functions for unification modulo evars *)
+(** {5 This modules provides useful functions for unification modulo evars } *)
 
-(***********************************************************)
-(* Metas *)
+(** {6 Metas} *)
 
-(* [new_meta] is a generator of unique meta variables *)
+(** [new_meta] is a generator of unique meta variables *)
 val new_meta : unit -> metavariable
 val mk_new_meta : unit -> constr
 
-(* [new_untyped_evar] is a generator of unique evar keys *)
+(** [new_untyped_evar] is a generator of unique evar keys *)
 val new_untyped_evar : unit -> existential_key
 
-(***********************************************************)
-(* Creating a fresh evar given their type and context *)
+(** {6 Creating a fresh evar given their type and context} *)
 val new_evar :
-  evar_map -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> evar_map * constr
-(* the same with side-effects *)
+  evar_map -> env -> ?src:loc * hole_kind -> ?filter:bool list ->
+  ?candidates:constr list -> types -> evar_map * constr
+
+(** the same with side-effects *)
 val e_new_evar :
-  evar_map ref -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> constr
+  evar_map ref -> env -> ?src:loc * hole_kind -> ?filter:bool list ->
+  ?candidates:constr list -> types -> constr
 
-(* Create a fresh evar in a context different from its definition context:
+(** Create a new Type existential variable, as we keep track of 
+    them during type-checking and unification. *)
+val new_type_evar :
+  ?src:loc * hole_kind -> ?filter:bool list -> evar_map -> env -> evar_map * constr
+
+(** 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
    of [inst] are typed in the occurrence context and their type (seen
    as a telescope) is [sign] *)
 val new_evar_instance :
- named_context_val -> evar_map -> types -> ?src:loc * hole_kind -> ?filter:bool list -> constr list -> evar_map * constr
+ named_context_val -> evar_map -> types -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> constr list -> evar_map * constr
 
 val make_pure_subst : evar_info -> constr array -> (identifier * constr) list
 
-(***********************************************************)
-(* Instantiate evars *)
+(** {6 Instantiate evars} *)
+
+type conv_fun =
+  env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool
 
-(* [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]),
+(** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]),
    possibly solving related unification problems, possibly leaving open
    some problems that cannot be solved in a unique way (except if choose is
    true); fails if the instance is not valid for the given [ev] *)
-val evar_define : ?choose:bool -> env -> existential -> constr -> evar_map -> evar_map
+val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> 
+  existential -> constr -> evar_map
 
-(***********************************************************)
-(* Evars/Metas switching... *)
+(** {6 Evars/Metas switching...} *)
 
-(* [evars_to_metas] generates new metavariables for each non dependent
+(** [evars_to_metas] generates new metavariables for each non dependent
    existential and performs the replacement in the given constr; it also
    returns the evar_map extended with dependent evars *)
 val evars_to_metas : evar_map -> open_constr -> (evar_map * constr)
 
 val non_instantiated : evar_map -> (evar * evar_info) list
 
-(***********************************************************)
-(* Unification utils *)
+(** {6 Unification utils} *)
 
+(** [head_evar c] returns the head evar of [c] if any *)
 exception NoHeadEvar
-val head_evar : constr -> existential_key (* may raise 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_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
+val solve_refl : conv_fun -> env ->  evar_map -> 
+  existential_key -> constr array -> constr array -> evar_map
+val solve_simple_eqn : conv_fun -> ?choose:bool -> env ->  evar_map ->
+  bool option * existential * constr -> evar_map * bool
+val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool
+
+(** [check_evars env initial_sigma extended_sigma c] fails if some
    new unresolved evar remains in [c] *)
 val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
-val 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_lambda : env -> evar_map -> existential -> evar_map * types
 val define_evar_as_sort : evar_map -> existential -> evar_map * sorts
 
-val is_unification_pattern_evar : env -> existential -> constr list ->
-  constr -> bool
-val is_unification_pattern : env * int -> constr -> constr array ->
-  constr -> bool
+val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
+  constr -> constr list option
+
+val is_unification_pattern : env * int -> evar_map -> constr -> constr list ->
+  constr -> constr list option
+
+val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
+  evar_map * existential
+
 val solve_pattern_eqn : env -> constr list -> constr -> constr
 
+(** The following functions return the set of evars immediately
+    contained in the object, including defined evars *)
+
+
 val evars_of_term : constr -> Intset.t
+
+(** returns the evars contained in the term associated with
+    the evars they contain themselves in their body, if any.
+    If the evar has no body, [None] is associated to it. *)
+val evars_of_evars_of_term : evar_map -> constr -> (Intset.t option) Intmap.t
 val evars_of_named_context : named_context -> Intset.t
 val evars_of_evar_info : evar_info -> Intset.t
 
-(***********************************************************)
-(* Value/Type constraints *)
+(** returns the evars which can be found in the typing context of the argument evars,
+    in the same format as {!evars_of_evars_of_term}.
+    It explores recursively the evars in the body of the argument evars -- but does
+    not return them. *)
+(* spiwack: tongue in cheek: it should have been called
+    [evars_of_evars_in_types_of_list_and_recursively_in_bodies] *)
+val evars_of_evars_in_types_of_list : evar_map -> evar list -> (Intset.t option) Intmap.t
+
+
+(** The following functions return the set of undefined evars
+    contained in the object, the defined evars being traversed.
+    This is roughly a combination of the previous functions and
+    [nf_evar]. *)
+
+val undefined_evars_of_term : evar_map -> constr -> Intset.t
+val undefined_evars_of_named_context : evar_map -> named_context -> Intset.t
+val undefined_evars_of_evar_info : evar_map -> evar_info -> Intset.t
+
+(** {6 Value/Type constraints} *)
 
-val judge_of_new_Type : unit -> unsafe_judgment
+val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment
 
 type type_constraint_type = (int * int) option * constr
 type type_constraint = type_constraint_type option
@@ -139,8 +170,8 @@ val lift_tycon : int -> type_constraint -> type_constraint
 
 (***********************************************************)
 
-(* [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains *)
-(* uninstantiated; [nf_evar] leave uninstantiated evars as is *)
+(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
+    uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
 
 val nf_evar :  evar_map -> constr -> constr
 val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
@@ -151,34 +182,30 @@ val jv_nf_evar :
 val tj_nf_evar :
    evar_map -> unsafe_type_judgment -> unsafe_type_judgment
 
-val nf_evar_info : evar_map -> evar_info -> evar_info
-val nf_evars : evar_map -> evar_map
-
 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
 
+val nf_evar_info : evar_map -> evar_info -> evar_info
 val nf_evar_map : evar_map -> evar_map
+val nf_evar_map_undefined : evar_map -> evar_map
 
-(* Replacing all evars, possibly raising [Uninstantiated_evar] *)
-(* exception Uninstantiated_evar of existential_key *)
+(** Replacing all evars, possibly raising [Uninstantiated_evar] *)
 exception Uninstantiated_evar of existential_key
 val flush_and_check_evars :  evar_map -> constr -> constr
 
-(* Replace the vars and rels that are aliases to other vars and rels by *)
-(* their representative that is most ancient in the context *)
+(** 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
 
-(*********************************************************************)
-(* debug pretty-printer: *)
+(** {6 debug pretty-printer:} *)
 
 val pr_tycon_type : env -> type_constraint_type -> Pp.std_ppcmds
 val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
 
 
-(*********************************************************************)
-(* Removing hyps in evars'context;                                   *)
-(* raise OccurHypInSimpleClause if the removal breaks dependencies   *)
+(** {6 Removing hyps in evars'context}
+raise OccurHypInSimpleClause if the removal breaks dependencies *)
 
 type clear_dependency_error =
 | OccurHypInSimpleClause of identifier option
@@ -186,8 +213,18 @@ type clear_dependency_error =
 
 exception ClearDependencyError of identifier * clear_dependency_error
 
+(* spiwack: marks an evar that has been "defined" by clear.
+    used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
+val cleared : bool Store.Field.t
+
 val 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
+val push_rel_context_to_named_context : Environ.env -> types ->
+  named_context_val * types * constr list * constr list
+
+val generalize_evar_over_rels : evar_map -> existential -> types * constr list
+
+val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun ->
+  evar_map
+
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 2db77837..5d6ca2ca 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evd.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -51,7 +49,8 @@ type evar_info = {
   evar_body : evar_body;
   evar_filter : bool list;
   evar_source : hole_kind located;
-  evar_extra : Dyn.t option}
+  evar_candidates : constr list option; (* if not None, list of allowed instances *)
+  evar_extra : Store.t }
 
 let make_evar hyps ccl = {
   evar_concl = ccl;
@@ -59,7 +58,8 @@ let make_evar hyps ccl = {
   evar_body = Evar_empty;
   evar_filter = List.map (fun _ -> true) (named_context_of_val hyps);
   evar_source = (dummy_loc,InternalHole);
-  evar_extra = None
+  evar_candidates = None;
+  evar_extra = Store.empty
 }
 
 let evar_concl evi = evi.evar_concl
@@ -81,10 +81,10 @@ let eq_evar_info ei1 ei2 =
     ei1.evar_body = ei2.evar_body
 
 (* spiwack: Revised hierarchy :
-      - ExistentialMap ( Maps of existential_keys )
-      - EvarInfoMap ( .t = evar_info ExistentialMap.t )
-      - EvarMap ( .t = EvarInfoMap.t * sort_constraints )
-      - evar_map (exported)
+   - ExistentialMap ( Maps of existential_keys )
+   - EvarInfoMap ( .t = evar_info ExistentialMap.t * evar_info ExistentialMap )
+   - EvarMap ( .t = EvarInfoMap.t * sort_constraints )
+   - evar_map (exported)
 *)
 
 module ExistentialMap = Intmap
@@ -93,72 +93,95 @@ module ExistentialSet = Intset
 (* This exception is raised by *.existential_value *)
 exception NotInstantiatedEvar
 
+(* Note: let-in contributes to the instance *)
+let make_evar_instance sign args =
+  let rec instrec = function
+    | (id,_,_) :: sign, c::args when isVarId id c -> instrec (sign,args)
+    | (id,_,_) :: sign, c::args -> (id,c) :: instrec (sign,args)
+    | [],[] -> []
+    | [],_ | _,[] -> anomaly "Signature and its instance do not match"
+  in
+    instrec (sign,args)
+
+let instantiate_evar sign c args =
+  let inst = make_evar_instance sign args in
+  if inst = [] then c else replace_vars inst c
+
 module EvarInfoMap = struct
-  type t = evar_info ExistentialMap.t
+  type t = evar_info ExistentialMap.t * evar_info ExistentialMap.t
 
-  let empty = ExistentialMap.empty
+  let empty = ExistentialMap.empty, ExistentialMap.empty
 
-  let to_list evc = (* Workaround for change in Map.fold behavior *)
+  let is_empty (d,u) = ExistentialMap.is_empty d && ExistentialMap.is_empty u
+
+  let has_undefined (_,u) = not (ExistentialMap.is_empty u)
+
+  let to_list (def,undef) =
+    (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *)
     let l = ref [] in
-    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) evc;
+    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) def;
+    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) undef;
     !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 undefined_list (def,undef) =
+    (* Order is important: needs ocaml >= 3.08.4 from which "fold" is a
+       "fold_left" *)
+    ExistentialMap.fold (fun evk evi l -> (evk,evi)::l) undef []
+
+  let undefined_evars (def,undef) = (ExistentialMap.empty,undef)
+  let defined_evars (def,undef) = (def,ExistentialMap.empty)
+
+  let find (def,undef) k =
+    try ExistentialMap.find k def
+    with Not_found -> ExistentialMap.find k undef
+  let find_undefined (def,undef) k = ExistentialMap.find k undef
+  let remove (def,undef) k =
+    (ExistentialMap.remove k def,ExistentialMap.remove k undef)
+  let mem (def,undef) k =
+    ExistentialMap.mem k def || ExistentialMap.mem k undef
+  let fold (def,undef) f a =
+    ExistentialMap.fold f def (ExistentialMap.fold f undef a)
+  let fold_undefined (def,undef) f a =
+    ExistentialMap.fold f undef a
+  let exists_undefined (def,undef) f =
+    ExistentialMap.fold (fun k v b -> b || f k v) undef false
+
+  let add (def,undef) evk newinfo =
+    if newinfo.evar_body = Evar_empty then
+      (def,ExistentialMap.add evk newinfo undef)
+    else
+      (ExistentialMap.add evk newinfo def,undef)
 
-  let add evd evk newinfo =  ExistentialMap.add evk newinfo evd
+  let add_undefined (def,undef) evk newinfo =
+    assert (newinfo.evar_body = Evar_empty);
+    (def,ExistentialMap.add evk newinfo undef)
 
-  let equal = ExistentialMap.equal
+  let map f (def,undef) = (ExistentialMap.map f def, ExistentialMap.map f undef)
 
-  let define evd evk body =
+  let define (def,undef) evk body =
     let oldinfo =
-      try find evd evk
-      with Not_found -> error "Evd.define: cannot define undeclared evar" in
+      try ExistentialMap.find evk undef
+      with Not_found -> 
+	try ExistentialMap.find evk def
+	with Not_found -> 
+	  anomaly "Evd.define: cannot define undeclared evar" in
     let newinfo =
       { oldinfo with
 	  evar_body = Evar_defined body } in
       match oldinfo.evar_body with
-	| Evar_empty -> ExistentialMap.add evk newinfo evd
-	| _ -> anomaly "Evd.define: cannot define an evar twice"
-
-  let is_evar sigma evk = mem sigma evk
+	| Evar_empty ->
+	    (ExistentialMap.add evk newinfo def,ExistentialMap.remove evk undef)
+	| _ ->
+	    anomaly "Evd.define: cannot define an evar twice"
 
-  let is_defined sigma evk =
-    let info = find sigma evk in
-      not (info.evar_body = Evar_empty)
+  let is_evar = mem
 
+  let is_defined (def,undef) evk = ExistentialMap.mem evk def
+  let is_undefined (def,undef) evk = ExistentialMap.mem evk undef
 
   (*******************************************************************)
   (* Formerly Instantiate module *)
 
-  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) =
@@ -184,160 +207,38 @@ module EvarInfoMap = struct
 
 end
 
-(*******************************************************************)
-(*                Constraints for sort variables                   *)
-(*******************************************************************)
-
-type sort_var = Univ.universe
-
-type sort_constraint =
-  | DefinedSort of sorts (* instantiated sort var *)
-  | SortVar of sort_var list * sort_var list (* (leq,geq) *)
-  | EqSort of sort_var
-
-module UniverseMap =
-  Map.Make (struct type t = Univ.universe let compare = compare end)
-
-type sort_constraints = sort_constraint UniverseMap.t
-
-let rec canonical_find u scstr =
-  match UniverseMap.find u scstr with
-      EqSort u' -> canonical_find u' scstr
-    | c -> (u,c)
-
-let whd_sort_var scstr t =
-  match kind_of_term t with
-      Sort(Type u) ->
-        (try
-          match canonical_find u scstr with
-              _, DefinedSort s -> mkSort s
-            | _ -> t
-        with Not_found -> t)
-    | _ -> t
-
-let rec set_impredicative u s scstr =
-  match UniverseMap.find u scstr with
-    | DefinedSort s' ->
-        if family_of_sort s = family_of_sort s' then scstr
-        else failwith "sort constraint inconsistency"
-    | EqSort u' ->
-        UniverseMap.add u (DefinedSort s) (set_impredicative u' s scstr)
-    | SortVar(_,ul) ->
-        (* also set sorts lower than u as impredicative *)
-        UniverseMap.add u (DefinedSort s)
-          (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
-
-let rec set_predicative u s scstr =
-  match UniverseMap.find u scstr with
-    | DefinedSort s' ->
-        if family_of_sort s = family_of_sort s' then scstr
-        else failwith "sort constraint inconsistency"
-    | EqSort u' ->
-        UniverseMap.add u (DefinedSort s) (set_predicative u' s scstr)
-    | SortVar(ul,_) ->
-        UniverseMap.add u (DefinedSort s)
-          (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
-
-let var_of_sort = function
-    Type u -> u
-  | _ -> assert false
-
-let is_sort_var s scstr =
-  match s with
-      Type u ->
-        (try
-          match canonical_find u scstr with
-              _, DefinedSort _ -> false
-            | _ -> true
-        with Not_found -> false)
-    | _ -> false
-
-let new_sort_var cstr =
-  let u = Termops.new_univ() in
-  (u, UniverseMap.add u (SortVar([],[])) cstr)
-
-
-let set_leq_sort (u1,(leq1,geq1)) (u2,(leq2,geq2)) scstr =
-  let rec search_rec (is_b, betw, not_betw) u1 =
-    if List.mem u1 betw then (true, betw, not_betw)
-    else if List.mem u1 not_betw then (is_b, betw, not_betw)
-    else if u1 = u2 then (true, u1::betw,not_betw) else
-      match UniverseMap.find u1 scstr with
-          EqSort u1' -> search_rec (is_b,betw,not_betw) u1'
-        | SortVar(leq,_) ->
-            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')
-        | DefinedSort _ -> (false,betw,u1::not_betw) in
-  let (is_betw,betw,_) = search_rec (false, [], []) u1 in
-  if is_betw then
-    UniverseMap.add u1 (SortVar(leq1@leq2,geq1@geq2))
-      (List.fold_left
-        (fun g u -> UniverseMap.add u (EqSort u1) g) scstr betw)
-  else
-    UniverseMap.add u1 (SortVar(u2::leq1,geq1))
-      (UniverseMap.add u2 (SortVar(leq2, u1::geq2)) scstr)
-
-let set_leq s1 s2 scstr =
-  let u1 = var_of_sort s1 in
-  let u2 = var_of_sort s2 in
-  let (cu1,c1) = canonical_find u1 scstr in
-  let (cu2,c2) = canonical_find u2 scstr in
-  if cu1=cu2 then scstr
-  else
-    match c1,c2 with
-        (EqSort _, _ | _, EqSort _) -> assert false
-      | SortVar(leq1,geq1), SortVar(leq2,geq2) ->
-          set_leq_sort (cu1,(leq1,geq1)) (cu2,(leq2,geq2)) scstr
-      | _, DefinedSort(Prop _ as s) -> set_impredicative u1 s scstr
-      | _, DefinedSort(Type _) -> scstr
-      | DefinedSort(Type _ as s), _ -> set_predicative u2 s scstr
-      | DefinedSort(Prop _), _ -> scstr
-
-let set_sort_variable s1 s2 scstr =
-  let u = var_of_sort s1 in
-  match s2 with
-      Prop _ -> set_impredicative u s2 scstr
-    | Type _ -> set_predicative u s2 scstr
-
-let pr_sort_cstrs g =
-  let l = UniverseMap.fold (fun u c l -> (u,c)::l) g [] in
-  str "SORT CONSTRAINTS:" ++ fnl() ++
-  prlist_with_sep fnl (fun (u,c) ->
-    match c with
-        EqSort u' -> Univ.pr_uni u ++ str" == " ++ Univ.pr_uni u'
-      | DefinedSort s -> Univ.pr_uni u ++ str " := " ++ print_sort s
-      | SortVar(leq,geq) ->
-          str"[" ++ hov 0 (prlist_with_sep spc Univ.pr_uni geq) ++
-          str"] <= "++ Univ.pr_uni u ++ brk(0,0) ++ str"<= [" ++
-          hov 0 (prlist_with_sep spc Univ.pr_uni leq) ++ str"]")
-    l
-
 module EvarMap = struct
-  type t = EvarInfoMap.t * sort_constraints
-  let empty = EvarInfoMap.empty, UniverseMap.empty
+  type t = EvarInfoMap.t * (Univ.UniverseLSet.t * Univ.universes)
+  let empty = EvarInfoMap.empty, (Univ.UniverseLSet.empty, Univ.initial_universes)
+  let is_empty (sigma,_) = EvarInfoMap.is_empty sigma
+  let has_undefined (sigma,_) = EvarInfoMap.has_undefined sigma
   let add (sigma,sm) k v = (EvarInfoMap.add sigma k v, sm)
-  let dom (sigma,_) = EvarInfoMap.dom sigma
+  let add_undefined (sigma,sm) k v = (EvarInfoMap.add_undefined sigma k v, sm)
   let find (sigma,_) = EvarInfoMap.find sigma
+  let find_undefined (sigma,_) = EvarInfoMap.find_undefined sigma
   let remove (sigma,sm) k = (EvarInfoMap.remove sigma k, sm)
   let mem (sigma,_) = EvarInfoMap.mem sigma
   let to_list (sigma,_) = EvarInfoMap.to_list sigma
-  let fold f (sigma,_) = EvarInfoMap.fold f sigma
+  let undefined_list (sigma,_) = EvarInfoMap.undefined_list sigma
+  let undefined_evars (sigma,sm) = (EvarInfoMap.undefined_evars sigma, sm)
+  let defined_evars (sigma,sm) = (EvarInfoMap.defined_evars sigma, sm)
+  let fold (sigma,_) = EvarInfoMap.fold sigma
+  let fold_undefined (sigma,_) = EvarInfoMap.fold_undefined sigma
   let define (sigma,sm) k v = (EvarInfoMap.define sigma k v, sm)
   let is_evar (sigma,_) = EvarInfoMap.is_evar sigma
   let is_defined (sigma,_) = EvarInfoMap.is_defined sigma
+  let is_undefined (sigma,_) = EvarInfoMap.is_undefined sigma
   let existential_value (sigma,_) = EvarInfoMap.existential_value sigma
   let existential_type (sigma,_) = EvarInfoMap.existential_type sigma
   let existential_opt_value (sigma,_) = EvarInfoMap.existential_opt_value sigma
   let progress_evar_map (sigma1,sm1 as x) (sigma2,sm2 as y) = not (x == y) &&
-    (EvarInfoMap.exists 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
+    (EvarInfoMap.exists_undefined sigma1
+      (fun k v -> assert (v.evar_body = Evar_empty);
+        EvarInfoMap.is_defined sigma2 k))
 
+  let merge e e' = fold e' (fun n v sigma -> add sigma n v) e
+  let add_constraints (sigma, (us, sm)) cstrs =
+    (sigma, (us, Univ.merge_constraints cstrs sm))
 end
 
 (*******************************************************************)
@@ -372,8 +273,7 @@ let map_fl f cfl = { cfl with rebus=f cfl.rebus }
     (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
 *)
 
-type instance_constraint =
-    IsSuperType | IsSubType | ConvUpToEta of int | UserGiven
+type instance_constraint = IsSuperType | IsSubType | Conv
 
 (* Status of the unification of the type of an instance against the type of
      the meta it instantiates:
@@ -441,7 +341,6 @@ let progress_evar_map d1 d2 =
 (* 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 ;
@@ -449,27 +348,34 @@ let merge d1 d2 = {
 }
 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 find_undefined d e = EvarMap.find_undefined 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
+let undefined_list d = EvarMap.undefined_list d.evars
+let undefined_evars d = { d with evars=EvarMap.undefined_evars d.evars }
+let defined_evars d = { d with evars=EvarMap.defined_evars d.evars }
 (* 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 fold f d a = EvarMap.fold d.evars f a
+let fold_undefined f d a = EvarMap.fold_undefined d.evars f a
 let is_evar d e = EvarMap.is_evar d.evars e
 let is_defined d e = EvarMap.is_defined d.evars e
+let is_undefined d e = EvarMap.is_undefined d.evars e
 
 let existential_value d e = EvarMap.existential_value d.evars e
 let existential_type d e = EvarMap.existential_type d.evars e
 let existential_opt_value d e = EvarMap.existential_opt_value d.evars e
 
+let add_constraints d e = {d with evars= EvarMap.add_constraints d.evars e}
+
 (*** /Lifting... ***)
 
 (* evar_map are considered empty disregarding histories *)
 let is_empty d =
-  d.evars = EvarMap.empty &&
+  EvarMap.is_empty d.evars &&
   d.conv_pbs = [] &&
   Metamap.is_empty d.metas
 
@@ -484,11 +390,11 @@ let subst_evar_info s evi =
       evar_body = subst_evb evi.evar_body }
 
 let subst_evar_defs_light sub evd =
-  assert (UniverseMap.is_empty (snd evd.evars));
+  assert (Univ.is_initial_universes (snd (snd evd.evars)));
   assert (evd.conv_pbs = []);
   { evd with
       metas = Metamap.map (map_clb (subst_mps sub)) evd.metas;
-      evars = ExistentialMap.map (subst_evar_info sub)  (fst evd.evars), snd evd.evars
+      evars = EvarInfoMap.map (subst_evar_info sub)  (fst evd.evars), (snd evd.evars)
   }
 
 let subst_evar_map = subst_evar_defs_light
@@ -507,9 +413,12 @@ let empty =  {
   metas=Metamap.empty
 }
 
-let evars_reset_evd ?(with_conv_pbs=false) evd d =
+let has_undefined evd =
+  EvarMap.has_undefined evd.evars
+
+let evars_reset_evd ?(with_conv_pbs=false) evd d = 
   {d with evars = evd.evars; 
-     conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs}
+     conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs }
 let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs}
 let evar_source evk d = (EvarMap.find d.evars evk).evar_source
 
@@ -522,7 +431,7 @@ let define evk body evd =
 	| [] ->  evd.last_mods
         | _ -> ExistentialSet.add evk evd.last_mods }
 
-let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd =
+let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter ?candidates evd =
   let filter =
     if filter = None then
       List.map (fun _ -> true) (named_context_of_val hyps)
@@ -532,13 +441,14 @@ let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd =
       filter)
   in
   { evd with
-    evars = EvarMap.add evd.evars evk
+    evars = EvarMap.add_undefined evd.evars evk
       {evar_hyps = hyps;
        evar_concl = ty;
        evar_body = Evar_empty;
        evar_filter = filter;
        evar_source = src;
-       evar_extra = None} }
+       evar_candidates = candidates;
+       evar_extra = Store.empty } }
 
 let is_defined_evar evd (evk,_) = EvarMap.is_defined evd.evars evk
 
@@ -547,14 +457,6 @@ 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 =
-    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 =
@@ -588,21 +490,84 @@ let evar_list evd c =
     | _ -> fold_constr evrec acc c in
   evrec [] c
 
+let collect_evars c =
+  let rec collrec acc c =
+    match kind_of_term c with
+      | Evar (evk,_) -> ExistentialSet.add evk acc
+      | _       -> fold_constr collrec acc c
+  in
+  collrec ExistentialSet.empty c
+
 (**********************************************************)
 (* Sort variables *)
 
-let new_sort_variable ({ evars = (sigma,sm) } as d)=
-  let (u,scstr) = new_sort_var sm in
-  (Type u,{ d with evars = (sigma,scstr) } )
-let is_sort_variable {evars=(_,sm)} s =
-  is_sort_var s 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
-
+let new_univ_variable ({ evars = (sigma,(us,sm)) } as d) =
+  let u = Termops.new_univ_level () in
+  let us' = Univ.UniverseLSet.add u us in
+    ({d with evars = (sigma, (us', sm))}, Univ.make_universe u)
+  
+let new_sort_variable d =
+  let (d', u) = new_univ_variable d in
+    (d', Type u)
+
+let is_sort_variable {evars=(_,(us,_))} s = match s with Type u -> true | _ -> false 
+let whd_sort_variable {evars=(_,sm)} t = t
+
+let univ_of_sort = function
+  | Type u -> u
+  | Prop Pos -> Univ.type0_univ
+  | Prop Null -> Univ.type0m_univ
+
+let is_eq_sort s1 s2 =
+  if s1 = s2 then None
+  else 
+    let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in
+      if u1 = u2 then None
+      else Some (u1, u2)
+
+let is_univ_var_or_set u =   
+  Univ.is_univ_variable u || u = Univ.type0_univ
+
+let set_leq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 =
+  match is_eq_sort s1 s2 with
+  | None -> d
+  | Some (u1, u2) ->
+      match s1, s2 with
+      | Prop c, Prop c' -> 
+	  if c = Null && c' = Pos then d
+	  else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)))
+     | Type u, Prop c -> 
+	  if c = Pos then 
+	    add_constraints d (Univ.enforce_geq Univ.type0_univ u Univ.empty_constraint)
+	  else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))
+      | _, Type u ->
+	  if is_univ_var_or_set u then
+	    add_constraints d (Univ.enforce_geq u2 u1 Univ.empty_constraint)
+	  else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))
+
+let is_univ_level_var us u =
+  match Univ.universe_level u with
+  | Some u -> Univ.UniverseLSet.mem u us
+  | None -> false
+
+let set_eq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 =
+  match is_eq_sort s1 s2 with
+  | None -> d
+  | Some (u1, u2) ->
+      match s1, s2 with
+      | Prop c, Type u when is_univ_level_var us u ->
+	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
+      | Type u, Prop c when is_univ_level_var us u ->
+	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
+      | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) ->
+	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
+      | Prop c, Type u when is_univ_var_or_set u &&
+	  Univ.check_eq sm u1 u2 -> d
+      | Type u, Prop c when is_univ_var_or_set u && Univ.check_eq sm u1 u2 -> d
+      | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v ->
+	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
+      | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2))
+	    
 (**********************************************************)
 (* Accessing metas *)
 
@@ -700,7 +665,6 @@ let meta_with_name evd 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)
@@ -712,7 +676,7 @@ let retract_coercible_metas evd =
   let mc,ml =
     Metamap.fold (fun n v (mc,ml) ->
       match v with
-	| Clval (na,(b,(UserGiven,CoerceToType as s)),typ) ->
+	| Clval (na,(b,(Conv,CoerceToType as s)),typ) ->
 	    (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml
 	| v ->
 	    mc, Metamap.add n v ml)
@@ -725,7 +689,7 @@ let rec list_assoc_in_triple x = function
 
 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)
+    | Meta i -> substrec (list_assoc_snd_in_triple i bl)
     | _ -> map_constr substrec c
   in try Some (substrec c) with Not_found -> None
 
@@ -754,9 +718,7 @@ let pr_instance_status (sc,typ) =
   begin match sc with
   | IsSubType -> str " [or a subtype of it]"
   | IsSuperType -> str " [or a supertype of it]"
-  | ConvUpToEta 0 -> mt ()
-  | UserGiven -> mt ()
-  | ConvUpToEta n -> str" [or an eta-expansion up to " ++ int n ++ str" of it]"
+  | Conv -> mt ()
   end ++
   begin match typ with
   | CoerceToType -> str " [up to coercion]"
@@ -788,49 +750,126 @@ let pr_decl ((id,b,_),ok) =
   | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
       print_constr c ++ str (if ok then ")" else "}")
 
+let pr_evar_source = function
+  | QuestionMark _ -> str "underscore"
+  | CasesType -> str "pattern-matching return predicate"
+  | BinderType (Name id) -> str "type of " ++ Nameops.pr_id id
+  | BinderType Anonymous -> str "type of anonymous binder"
+  | ImplicitArg (c,(n,ido),b) ->
+      let id = Option.get ido in
+      str "parameter " ++ pr_id id ++ spc () ++ str "of" ++
+      spc () ++ print_constr (constr_of_global c)
+  | InternalHole -> str "internal placeholder"
+  | TomatchTypeParameter (ind,n) ->
+      nth n ++ str " argument of type " ++ print_constr (mkInd ind)
+  | GoalEvar -> str "goal evar"
+  | ImpossibleCase -> str "type of impossible pattern-matching clause"
+  | MatchingVar _ -> str "matching variable"
+
 let pr_evar_info evi =
-  let decls = List.combine (evar_context evi) (evar_filter evi) in
-  let phyps = prlist_with_sep pr_spc pr_decl (List.rev decls) in
+  let phyps =
+    try
+      let decls = List.combine (evar_context evi) (evar_filter evi) in
+      prlist_with_sep pr_spc pr_decl (List.rev decls)
+    with Invalid_argument _ -> str "Ill-formed filtered context" in
   let pty = print_constr evi.evar_concl in
   let pb =
     match evi.evar_body with
       | Evar_empty -> mt ()
       | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
   in
-  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
-
-let pr_evar_map_t (evars,cstrs as sigma) =
+  let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in
+  hov 2
+    (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]" ++
+       spc() ++ src)
+
+let compute_evar_dependency_graph (sigma:evar_map) =
+  (* Compute the map binding ev to the evars whose body depends on ev *)
+  fold (fun evk evi acc ->
+    let deps =
+      match evar_body evi with
+      | Evar_empty -> ExistentialSet.empty
+      | Evar_defined c -> collect_evars c in
+    ExistentialSet.fold (fun evk' acc ->
+      let tab = try ExistentialMap.find evk' acc with Not_found -> [] in
+      ExistentialMap.add evk' ((evk,evi)::tab) acc) deps acc)
+    sigma ExistentialMap.empty
+
+let evar_dependency_closure n sigma =
+  let graph = compute_evar_dependency_graph sigma in
+  let order a b = fst a < fst b in
+  let rec aux n l =
+    if n=0 then l
+    else
+      let l' =
+        list_map_append (fun (evk,_) ->
+          try ExistentialMap.find evk graph with Not_found -> []) l in
+      aux (n-1) (list_uniquize (Sort.list order (l@l'))) in
+  aux n (undefined_list sigma)
+
+let pr_evar_map_t depth sigma =
+  let (evars,(uvs,univs)) = sigma.evars in
+  let pr_evar_list l =
+    h 0 (prlist_with_sep pr_fnl
+	   (fun (ev,evi) ->
+	     h 0 (str(string_of_existential ev) ++
+                    str"==" ++ pr_evar_info evi)) l) in
   let evs =
-    if evars = EvarInfoMap.empty then mt ()
+    if EvarInfoMap.is_empty evars 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()
+      match depth with
+      | None ->
+          (* Print all evars *)
+          str"EVARS:"++brk(0,1)++pr_evar_list (to_list sigma)++fnl()
+      | Some n ->
+          (* Print all evars *)
+          str"UNDEFINED EVARS"++
+          (if n=0 then mt() else str" (+level "++int n++str" closure):")++
+          brk(0,1)++
+          pr_evar_list (evar_dependency_closure n sigma)++fnl()
+  and svs =
+    if Univ.UniverseLSet.is_empty uvs then mt ()
+    else str"UNIVERSE VARIABLES:"++brk(0,1)++
+      h 0 (prlist_with_sep pr_fnl 
+	     (fun u -> Univ.pr_uni_level u) (Univ.UniverseLSet.elements uvs))++fnl()
   and cs =
-    if cstrs = UniverseMap.empty then mt ()
-    else pr_sort_cstrs cstrs++fnl()
-  in evs ++ cs
+    if Univ.is_initial_universes univs then mt ()
+    else str"UNIVERSES:"++brk(0,1)++
+      h 0 (Univ.pr_universes univs)++fnl()
+  in evs ++ svs ++ cs
+
+let print_env_short env =
+  let pr_body n = function None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
+  let pr_named_decl (n, b, _) = pr_body (Name n) b in
+  let pr_rel_decl (n, b, _) = pr_body n b in
+  let nc = List.rev (named_context env) in
+  let rc = List.rev (rel_context env) in
+    str "[" ++ prlist_with_sep pr_spc pr_named_decl nc ++ str "]" ++ spc () ++
+    str "[" ++ prlist_with_sep pr_spc pr_rel_decl rc ++ str "]"
 
 let pr_constraints pbs =
   h 0
-    (prlist_with_sep pr_fnl (fun (pbty,_,t1,t2) ->
-      print_constr t1 ++ spc() ++
-      str (match pbty with
-	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++
-      spc() ++ print_constr t2) pbs)
-
-let pr_evar_map evd =
+    (prlist_with_sep pr_fnl 
+       (fun (pbty,env,t1,t2) ->
+	  print_env_short env ++ spc () ++ str "|-" ++ spc () ++
+	    print_constr t1 ++ spc() ++
+	    str (match pbty with
+		 | Reduction.CONV -> "=="
+		 | Reduction.CUMUL -> "<=") ++
+	    spc() ++ print_constr t2) pbs)
+
+let pr_evar_map_constraints evd =
+  if evd.conv_pbs = [] then mt() 
+  else pr_constraints evd.conv_pbs++fnl()
+
+let pr_evar_map allevars evd =
   let pp_evm =
-    if evd.evars = EvarMap.empty then mt() else
-      pr_evar_map_t evd.evars++fnl() in
-  let cstrs =
-    if evd.conv_pbs = [] then mt() else
+    if EvarMap.is_empty evd.evars then mt() else
+      pr_evar_map_t allevars evd++fnl() in
+  let cstrs = if evd.conv_pbs = [] then mt() else
     str"CONSTRAINTS:"++brk(0,1)++pr_constraints evd.conv_pbs++fnl() in
   let pp_met =
-    if evd.metas = Metamap.empty then mt() else
+    if Metamap.is_empty evd.metas then mt() else
       str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
   v 0 (pp_evm ++ cstrs ++ pp_met)
 
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index 8a903f1b..55c54f2c 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evd.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -17,10 +14,9 @@ open Environ
 open Libnames
 open Mod_subst
 open Termops
-(*i*)
 
-(*********************************************************************)
-(* Meta map *)
+(********************************************************************
+   Meta map *)
 
 module Metamap : Map.S with type key = metavariable
 
@@ -36,17 +32,16 @@ val metavars_of : constr -> Metaset.t
 val mk_freelisted : constr -> constr freelisted
 val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
 
-(* Status of an instance found by unification wrt to the meta it solves:
+(** Status of an instance found by unification wrt to the meta it solves:
   - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
   - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
   - a term that can be eta-expanded n times while still being a solution
     (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
 *)
 
-type instance_constraint =
-    IsSuperType | IsSubType | ConvUpToEta of int | UserGiven
+type instance_constraint = IsSuperType | IsSubType | Conv
 
-(* Status of the unification of the type of an instance against the type of
+(** Status of the unification of the type of an instance against the type of
      the meta it instantiates:
    - CoerceToType means that the unification of types has not been done
      and that a coercion can still be inserted: the meta should not be
@@ -62,11 +57,11 @@ type instance_constraint =
 type instance_typing_status =
     CoerceToType | TypeNotProcessed | TypeProcessed
 
-(* Status of an instance together with the status of its type unification *)
+(** Status of an instance together with the status of its type unification *)
 
 type instance_status = instance_constraint * instance_typing_status
 
-(* Clausal environments *)
+(** Clausal environments *)
 
 type clbinding =
   | Cltyp of name * constr freelisted
@@ -75,17 +70,17 @@ type clbinding =
 val map_clb : (constr -> constr) -> clbinding -> clbinding
 
 
-(*********************************************************************)
-(*** Kinds of existential variables ***)
+(********************************************************************
+  ** Kinds of existential variables ***)
 
-(* Should the obligation be defined (opaque or transparent (default)) or
+(** Should the obligation be defined (opaque or transparent (default)) or
    defined transparent and expanded in the term? *)
 
 type obligation_definition_status = Define of bool | Expand
 
-(* Evars *)
+(** Evars *)
 type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option) * bool (* Force inference *)
+  | ImplicitArg of global_reference * (int * identifier option) * bool (** Force inference *)
   | BinderType of name
   | QuestionMark of obligation_definition_status
   | CasesType
@@ -95,10 +90,10 @@ type hole_kind =
   | ImpossibleCase
   | MatchingVar of bool * identifier
 
-(*********************************************************************)
-(*** Existential variables and unification states ***)
+(********************************************************************
+  ** Existential variables and unification states ***)
 
-(* A unification state (of type [evar_map]) is primarily a finite mapping
+(** 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
@@ -106,7 +101,7 @@ type hole_kind =
    It also contains conversion constraints, debugging information and
    information about meta variables. *)
 
-(* Information about existential variables. *)
+(** Information about existential variables. *)
 type evar = existential_key
 
 val string_of_existential : evar -> string
@@ -122,7 +117,8 @@ type evar_info = {
   evar_body : evar_body;
   evar_filter : bool list;
   evar_source : hole_kind located;
-  evar_extra : Dyn.t option}
+  evar_candidates : constr list option;
+  evar_extra : Store.t }
 
 val eq_evar_info : evar_info -> evar_info -> bool
 
@@ -139,33 +135,40 @@ val evar_env :  evar_info -> env
 (*** Unification state ***)
 type evar_map
 
-(* Unification state and existential variables *)
+(** Unification state and existential variables *)
 
-(* Assuming that the second map extends the first one, this says if
+(** 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
+(** [has_undefined sigma] is [true] if and only if
+    there are uninstantiated evars in [sigma]. *)
+val has_undefined : evar_map -> bool
 
 val add : evar_map -> evar -> evar_info -> evar_map
 
-val dom : evar_map -> evar list
 val find : evar_map -> evar -> evar_info
+val find_undefined : evar_map -> evar -> evar_info
 val remove : evar_map -> evar -> evar_map
 val mem : evar_map -> evar -> bool
+val undefined_list : evar_map -> (evar * evar_info) list
 val to_list : evar_map -> (evar * evar_info) list
 val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-
+val fold_undefined : (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
+val is_undefined : evar_map -> evar -> bool
 
-(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+val add_constraints : evar_map -> Univ.constraints -> evar_map
+
+(** {6 ... } *)
+(** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
     no body and [Not_found] if it does not exist in [sigma] *)
 
 exception NotInstantiatedEvar
@@ -173,10 +176,12 @@ 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 instantiate_evar : named_context -> constr -> constr list -> constr
+
+(** 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. *)
+(** spiwack: this function seems to somewhat break the abstraction. *)
 val evars_reset_evd  : ?with_conv_pbs:bool -> evar_map ->  evar_map -> evar_map
 
 
@@ -184,34 +189,41 @@ val evars_reset_evd  : ?with_conv_pbs:bool -> evar_map ->  evar_map -> evar_map
                    for moving to evarutils *)
 val is_undefined_evar :  evar_map -> constr -> bool
 val undefined_evars : evar_map -> evar_map
+val defined_evars : evar_map -> evar_map
+(* [fold_undefined f m] iterates ("folds") function [f] over the undefined
+    evars (that is, whose value is [Evar_empty]) of map [m].
+    It optimizes the call of {!Evd.fold} to [f] and [undefined_evars m] *)
+val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
 val evar_declare :
   named_context_val -> evar -> types -> ?src:loc * hole_kind ->
-      ?filter:bool list -> evar_map -> evar_map
-val evar_source : existential_key -> evar_map -> loc * hole_kind
+      ?filter:bool list -> ?candidates:constr list -> evar_map -> evar_map
+val evar_source : existential_key -> evar_map -> hole_kind located
 
-(* spiwack: this function seems to somewhat break the abstraction. *)
-(* [evar_merge evd ev1] extends the evars of [evd] with [evd1] *)
+(* 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
 
-val evar_list : evar_map -> constr -> existential list
-
-(* Unification constraints *)
+(** Unification constraints *)
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * env * constr * constr
 val add_conv_pb :  evar_constraint -> evar_map -> evar_map
 
+module ExistentialMap : Map.S with type key = existential_key
 module ExistentialSet : Set.S with type elt = existential_key
 val extract_changed_conv_pbs : evar_map ->
       (ExistentialSet.t -> evar_constraint -> bool) ->
       evar_map * evar_constraint list
 val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list
 
+val evar_list : evar_map -> constr -> existential list
+val collect_evars : constr -> ExistentialSet.t
 
-(* Metas *)
+(** Metas *)
 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_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
    meta has no value *)
 val meta_value     : evar_map -> metavariable -> constr
 val meta_fvalue    : evar_map -> metavariable -> constr freelisted * instance_status
@@ -225,7 +237,7 @@ val meta_declare   :
 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] *)
+(** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
 val meta_merge : evar_map -> evar_map -> evar_map
 
 val undefined_metas : evar_map -> metavariable list
@@ -237,21 +249,22 @@ type metabinding = metavariable * constr * instance_status
 val retract_coercible_metas : evar_map -> metabinding list * evar_map
 val subst_defined_metas : metabinding list -> constr -> constr option
 
-(**********************************************************)
-(* Sort variables *)
+(*********************************************************
+   Sort variables *)
 
-val new_sort_variable : evar_map -> sorts * evar_map
+val new_univ_variable : evar_map -> evar_map * Univ.universe
+val new_sort_variable : evar_map -> evar_map * sorts
 val is_sort_variable : evar_map -> sorts -> bool
 val whd_sort_variable : evar_map -> constr -> constr
-val set_leq_sort_variable : evar_map -> sorts -> sorts -> evar_map
-val define_sort_variable : evar_map -> sorts -> sorts -> evar_map
+val set_leq_sort : evar_map -> sorts -> sorts -> evar_map
+val set_eq_sort : evar_map -> sorts -> sorts -> evar_map
 
-(*********************************************************************)
-(* constr with holes *)
+(********************************************************************
+   constr with holes *)
 type open_constr = evar_map * constr
 
-(*********************************************************************)
-(* The type constructor ['a sigma] adds an evar map to an object of
+(********************************************************************
+   The type constructor ['a sigma] adds an evar map to an object of
   type ['a] *)
 type 'a sigma = {
   it : 'a ;
@@ -260,22 +273,22 @@ type 'a sigma = {
 val sig_it  : 'a sigma -> 'a
 val sig_sig : 'a sigma -> evar_map
 
-(**********************************************************)
-(* Failure explanation *)
+(*********************************************************
+   Failure explanation *)
 
 type unsolvability_explanation = SeveralInstancesFound of int
 
-(*********************************************************************)
-(* debug pretty-printer: *)
+(********************************************************************
+   debug pretty-printer: *)
 
 val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_map : evar_map -> Pp.std_ppcmds
-val pr_sort_constraints : evar_map -> Pp.std_ppcmds
+val pr_evar_map_constraints : evar_map -> Pp.std_ppcmds
+val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds
 val pr_metaset : Metaset.t -> Pp.std_ppcmds
 
 
-(*** /!\Deprecated /!\ ***)
-(* create an [evar_map] with empty meta map: *)
+(*** /!\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
diff --git a/pretyping/rawterm.ml b/pretyping/glob_term.ml
index 978dbeef..a4113671 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/glob_term.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rawterm.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Util
 open Names
@@ -32,7 +30,7 @@ let cases_pattern_loc = function
 
 type patvar = identifier
 
-type rawsort = RProp of Term.contents | RType of Univ.universe option
+type glob_sort = GProp of Term.contents | GType of Univ.universe option
 
 type binding_kind = Lib.binding_kind = Explicit | Implicit
 
@@ -51,42 +49,41 @@ type 'a cast_type =
   | CastConv of cast_kind * 'a
   | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
 
-type rawconstr =
-  | RRef of (loc * global_reference)
-  | RVar of (loc * identifier)
-  | REvar of loc * existential_key * rawconstr list option
-  | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
-  | RApp of loc * rawconstr * rawconstr list
-  | RLambda of loc * name * binding_kind * rawconstr * 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) *
-      rawconstr * rawconstr
-  | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
-  | RRec of loc * fix_kind * identifier array * rawdecl list array *
-      rawconstr array * rawconstr array
-  | RSort of loc * rawsort
-  | RHole of (loc * hole_kind)
-  | RCast of loc * rawconstr * rawconstr cast_type
-  | RDynamic of loc * Dyn.t
-
-and rawdecl = name * binding_kind * rawconstr option * rawconstr
-
-and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr * rawconstr option
+type glob_constr =
+  | GRef of (loc * global_reference)
+  | GVar of (loc * identifier)
+  | GEvar of loc * existential_key * glob_constr list option
+  | GPatVar of loc * (bool * patvar) (* Used for patterns only *)
+  | GApp of loc * glob_constr * glob_constr list
+  | GLambda of loc * name * binding_kind * glob_constr * glob_constr
+  | GProd of loc * name * binding_kind * glob_constr * glob_constr
+  | GLetIn of loc * name * glob_constr * glob_constr
+  | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses
+  | GLetTuple of loc * name list * (name * glob_constr option) *
+      glob_constr * glob_constr
+  | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr
+  | GRec of loc * fix_kind * identifier array * glob_decl list array *
+      glob_constr array * glob_constr array
+  | GSort of loc * glob_sort
+  | GHole of (loc * hole_kind)
+  | GCast of loc * glob_constr * glob_constr cast_type
+
+and glob_decl = name * binding_kind * glob_constr option * glob_constr
+
+and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option
 
 and fix_kind =
-  | RFix of ((int option * fix_recursion_order) array * int)
-  | RCoFix of int
+  | GFix of ((int option * fix_recursion_order) array * int)
+  | GCoFix of int
 
 and predicate_pattern =
     name * (loc * inductive * int * name list) option
 
-and tomatch_tuple = (rawconstr * predicate_pattern)
+and tomatch_tuple = (glob_constr * predicate_pattern)
 
 and tomatch_tuples = tomatch_tuple list
 
-and cases_clause = (loc * identifier list * cases_pattern list * rawconstr)
+and cases_clause = (loc * identifier list * cases_pattern list * glob_constr)
 
 and cases_clauses = cases_clause list
 
@@ -95,55 +92,60 @@ let cases_predicate_names tml =
     | (tm,(na,None)) -> [na]
     | (tm,(na,Some (_,_,_,nal))) -> na::nal) tml)
 
-let map_rawdecl_left_to_right f (na,k,obd,ty) = 
+let mkGApp loc p t =
+  match p with
+  | GApp (loc,f,l) -> GApp (loc,f,l@[t])
+  | _ -> GApp (loc,p,[t])
+
+let map_glob_decl_left_to_right f (na,k,obd,ty) = 
   let comp1 = Option.map f obd in
   let comp2 = f ty in
   (na,k,comp1,comp2)
 
-let map_rawconstr_left_to_right f = function
-  | RApp (loc,g,args) -> 
+let map_glob_constr_left_to_right f = function
+  | GApp (loc,g,args) -> 
       let comp1 = f g in 
       let comp2 = Util.list_map_left f args in 
-      RApp (loc,comp1,comp2)
-  | RLambda (loc,na,bk,ty,c) -> 
+      GApp (loc,comp1,comp2)
+  | GLambda (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) -> 
+      GLambda (loc,na,bk,comp1,comp2)
+  | GProd (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) -> 
+      GProd (loc,na,bk,comp1,comp2)
+  | GLetIn (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) ->
+      GLetIn (loc,na,comp1,comp2)
+  | GCases (loc,sty,rtntypopt,tml,pl) ->
       let comp1 = Option.map f rtntypopt in 
       let comp2 = Util.list_map_left (fun (tm,x) -> (f tm,x)) tml in
       let comp3 = Util.list_map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in
-      RCases (loc,sty,comp1,comp2,comp3)
-  | RLetTuple (loc,nal,(na,po),b,c) ->
+      GCases (loc,sty,comp1,comp2,comp3)
+  | GLetTuple (loc,nal,(na,po),b,c) ->
       let comp1 = Option.map f po in
       let comp2 = f b in
       let comp3 = f c in 
-      RLetTuple (loc,nal,(na,comp1),comp2,comp3)
-  | RIf (loc,c,(na,po),b1,b2) ->
+      GLetTuple (loc,nal,(na,comp1),comp2,comp3)
+  | GIf (loc,c,(na,po),b1,b2) ->
       let comp1 = Option.map f po in
       let comp2 = f b1 in
       let comp3 = f b2 in
-      RIf (loc,f c,(na,comp1),comp2,comp3)
-  | RRec (loc,fk,idl,bl,tyl,bv) ->
-      let comp1 = Array.map (Util.list_map_left (map_rawdecl_left_to_right f)) bl in
+      GIf (loc,f c,(na,comp1),comp2,comp3)
+  | GRec (loc,fk,idl,bl,tyl,bv) ->
+      let comp1 = Array.map (Util.list_map_left (map_glob_decl_left_to_right f)) bl in
       let comp2 = Array.map f tyl in
       let comp3 = Array.map f bv in
-      RRec (loc,fk,idl,comp1,comp2,comp3)
-  | RCast (loc,c,k) -> 
+      GRec (loc,fk,idl,comp1,comp2,comp3)
+  | GCast (loc,c,k) -> 
       let comp1 = f c in
       let comp2 = match k with CastConv (k,t) -> CastConv (k, f t) | x -> x in
-      RCast (loc,comp1,comp2)
-  | (RVar _ | RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
+      GCast (loc,comp1,comp2)
+  | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x
 
-let map_rawconstr = map_rawconstr_left_to_right
+let map_glob_constr = map_glob_constr_left_to_right
 
 (*
 let name_app f e = function
@@ -156,54 +158,53 @@ let fold_ident g idl e =
       (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e)
   in (Array.of_list idl,e)
 
-let map_rawconstr_with_binders_loc loc g f e = function
-  | RVar (_,id) -> RVar (loc,id)
-  | RApp (_,a,args) -> RApp (loc,f e a, List.map (f e) args)
-  | RLambda (_,na,ty,c) ->
-      let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c)
-  | RProd (_,na,ty,c) ->
-      let na,e = name_app g e na in RProd (loc,na,f e ty,f e c)
-  | RLetIn (_,na,b,c) ->
-      let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c)
-  | RCases (_,tyopt,tml,pl) ->
+let map_glob_constr_with_binders_loc loc g f e = function
+  | GVar (_,id) -> GVar (loc,id)
+  | GApp (_,a,args) -> GApp (loc,f e a, List.map (f e) args)
+  | GLambda (_,na,ty,c) ->
+      let na,e = name_app g e na in GLambda (loc,na,f e ty,f e c)
+  | GProd (_,na,ty,c) ->
+      let na,e = name_app g e na in GProd (loc,na,f e ty,f e c)
+  | GLetIn (_,na,b,c) ->
+      let na,e = name_app g e na in GLetIn (loc,na,f e b,f e c)
+  | GCases (_,tyopt,tml,pl) ->
       (* We don't modify pattern variable since we don't traverse patterns *)
       let g' id e = snd (g id e) in
       let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in
-      RCases
+      GCases
 	(loc,Option.map (f e) tyopt,List.map (f e) tml, List.map h pl)
-  | RRec (_,fk,idl,tyl,bv) ->
+  | GRec (_,fk,idl,tyl,bv) ->
       let idl',e' = fold_ident g idl e in
-      RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
-  | RCast (_,c,t) -> RCast (loc,f e c,f e t)
-  | RSort (_,x) -> RSort (loc,x)
-  | RHole (_,x)  -> RHole (loc,x)
-  | RRef (_,x) -> RRef (loc,x)
-  | REvar (_,x,l) -> REvar (loc,x,l)
-  | RPatVar (_,x) -> RPatVar (loc,x)
-  | RDynamic (_,x) -> RDynamic (loc,x)
+      GRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
+  | GCast (_,c,t) -> GCast (loc,f e c,f e t)
+  | GSort (_,x) -> GSort (loc,x)
+  | GHole (_,x)  -> GHole (loc,x)
+  | GRef (_,x) -> GRef (loc,x)
+  | GEvar (_,x,l) -> GEvar (loc,x,l)
+  | GPatVar (_,x) -> GPatVar (loc,x)
 *)
 
-let fold_rawconstr f acc =
+let fold_glob_constr f acc =
   let rec fold acc = function
-  | RVar _ -> acc
-  | RApp (_,c,args) -> List.fold_left fold (fold acc c) args
-  | RLambda (_,_,_,b,c) | RProd (_,_,_,b,c) | RLetIn (_,_,b,c) ->
+  | GVar _ -> acc
+  | GApp (_,c,args) -> List.fold_left fold (fold acc c) args
+  | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) ->
       fold (fold acc b) c
-  | RCases (_,_,rtntypopt,tml,pl) ->
+  | GCases (_,_,rtntypopt,tml,pl) ->
       List.fold_left fold_pattern
 	(List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml))
 	pl
-    | RLetTuple (_,_,rtntyp,b,c) ->
+    | GLetTuple (_,_,rtntyp,b,c) ->
 	fold (fold (fold_return_type acc rtntyp) b) c
-    | RIf (_,c,rtntyp,b1,b2) ->
+    | GIf (_,c,rtntyp,b1,b2) ->
 	fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2
-    | RRec (_,_,_,bl,tyl,bv) ->
+    | GRec (_,_,_,bl,tyl,bv) ->
 	let acc = Array.fold_left
 	  (List.fold_left (fun acc (na,k,bbd,bty) ->
 	    fold (Option.fold_left fold acc bbd) bty)) acc bl in
 	Array.fold_left fold (Array.fold_left fold acc tyl) bv
-    | RCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c
-    | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> acc
+    | GCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
 
   and fold_pattern acc (_,idl,p,c) = fold acc c
 
@@ -211,25 +212,25 @@ let fold_rawconstr f acc =
 
   in fold acc
 
-let iter_rawconstr f = fold_rawconstr (fun () -> f) ()
+let iter_glob_constr f = fold_glob_constr (fun () -> f) ()
 
-let occur_rawconstr id =
+let occur_glob_constr id =
   let rec occur = function
-    | RVar (loc,id') -> id = id'
-    | RApp (loc,f,args) -> (occur f) or (List.exists occur args)
-    | RLambda (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
-    | RProd (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
-    | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
-    | RCases (loc,sty,rtntypopt,tml,pl) ->
+    | GVar (loc,id') -> id = id'
+    | GApp (loc,f,args) -> (occur f) or (List.exists occur args)
+    | GLambda (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
+    | GProd (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
+    | GLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
+    | GCases (loc,sty,rtntypopt,tml,pl) ->
 	(occur_option rtntypopt)
         or (List.exists (fun (tm,_) -> occur tm) tml)
 	or (List.exists occur_pattern pl)
-    | RLetTuple (loc,nal,rtntyp,b,c) ->
+    | GLetTuple (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) ->
+    | GIf (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) ->
+    | GRec (loc,fk,idl,bl,tyl,bv) ->
         not (array_for_all4 (fun fid bl ty bd ->
           let rec occur_fix = function
               [] -> not (occur ty) && (fid=id or not(occur bd))
@@ -241,8 +242,8 @@ let occur_rawconstr id =
                 (na=Name id or not(occur_fix bl)) in
           occur_fix bl)
           idl bl tyl bv)
-    | RCast (loc,c,k) -> (occur c) or (match k with CastConv (_, t) -> occur t | CastCoerce -> false)
-    | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false
+    | GCast (loc,c,k) -> (occur c) or (match k with CastConv (_, t) -> occur t | CastCoerce -> false)
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> false
 
   and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
 
@@ -258,29 +259,29 @@ let add_name_to_ids set na =
     | Anonymous -> set
     | Name id -> Idset.add id set
 
-let free_rawvars  =
+let free_glob_vars  =
   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) ->
+    | GVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs
+    | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
+    | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) ->
 	let vs' = vars bounded vs ty in
 	let bounded' = add_name_to_ids bounded na in
        vars bounded' vs' c
-    | RCases (loc,sty,rtntypopt,tml,pl) ->
+    | GCases (loc,sty,rtntypopt,tml,pl) ->
 	let vs1 = vars_option bounded vs rtntypopt in
 	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in
 	List.fold_left (vars_pattern bounded) vs2 pl
-    | RLetTuple (loc,nal,rtntyp,b,c) ->
+    | GLetTuple (loc,nal,rtntyp,b,c) ->
 	let vs1 = vars_return_type bounded vs rtntyp in
 	let vs2 = vars bounded vs1 b in
 	let bounded' = List.fold_left add_name_to_ids bounded nal in
 	vars bounded' vs2 c
-    | RIf (loc,c,rtntyp,b1,b2) ->
+    | GIf (loc,c,rtntyp,b1,b2) ->
 	let vs1 = vars_return_type bounded vs rtntyp in
 	let vs2 = vars bounded vs1 c in
 	let vs3 = vars bounded vs2 b1 in
 	vars bounded vs3 b2
-    | RRec (loc,fk,idl,bl,tyl,bv) ->
+    | GRec (loc,fk,idl,bl,tyl,bv) ->
 	let bounded' = Array.fold_right Idset.add idl bounded in
 	let vars_fix i vs fid =
 	  let vs1,bounded1 =
@@ -298,9 +299,9 @@ let free_rawvars  =
 	  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
+    | GCast (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
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs
 
   and vars_pattern bounded vs (loc,idl,p,c) =
     let bounded' = List.fold_right Idset.add idl bounded  in
@@ -317,58 +318,57 @@ let free_rawvars  =
     Idset.elements vs
 
 
-let loc_of_rawconstr = function
-  | RRef (loc,_) -> loc
-  | RVar (loc,_) -> loc
-  | REvar (loc,_,_) -> loc
-  | RPatVar (loc,_) -> loc
-  | RApp (loc,_,_) -> loc
-  | RLambda (loc,_,_,_,_) -> loc
-  | RProd (loc,_,_,_,_) -> loc
-  | RLetIn (loc,_,_,_) -> loc
-  | RCases (loc,_,_,_,_) -> loc
-  | RLetTuple (loc,_,_,_,_) -> loc
-  | RIf (loc,_,_,_,_) -> loc
-  | RRec (loc,_,_,_,_,_) -> loc
-  | RSort (loc,_) -> loc
-  | RHole (loc,_) -> loc
-  | RCast (loc,_,_) -> loc
-  | RDynamic (loc,_) -> loc
+let loc_of_glob_constr = function
+  | GRef (loc,_) -> loc
+  | GVar (loc,_) -> loc
+  | GEvar (loc,_,_) -> loc
+  | GPatVar (loc,_) -> loc
+  | GApp (loc,_,_) -> loc
+  | GLambda (loc,_,_,_,_) -> loc
+  | GProd (loc,_,_,_,_) -> loc
+  | GLetIn (loc,_,_,_) -> loc
+  | GCases (loc,_,_,_,_) -> loc
+  | GLetTuple (loc,_,_,_,_) -> loc
+  | GIf (loc,_,_,_,_) -> loc
+  | GRec (loc,_,_,_,_,_) -> loc
+  | GSort (loc,_) -> loc
+  | GHole (loc,_) -> loc
+  | GCast (loc,_,_) -> loc
 
 (**********************************************************************)
-(* Conversion from rawconstr to cases pattern, if possible            *)
+(* Conversion from glob_constr to cases pattern, if possible            *)
 
-let rec cases_pattern_of_rawconstr na = function
-  | RVar (loc,id) when na<>Anonymous ->
+let rec cases_pattern_of_glob_constr na = function
+  | GVar (loc,id) when na<>Anonymous ->
       (* Unable to manage the presence of both an alias and a variable *)
       raise Not_found
-  | RVar (loc,id) -> PatVar (loc,Name id)
-  | RHole (loc,_) -> PatVar (loc,na)
-  | RRef (loc,ConstructRef cstr) ->
+  | GVar (loc,id) -> PatVar (loc,Name id)
+  | GHole (loc,_) -> PatVar (loc,na)
+  | GRef (loc,ConstructRef cstr) ->
       PatCstr (loc,cstr,[],na)
-  | RApp (loc,RRef (_,ConstructRef cstr),l) ->
-      PatCstr (loc,cstr,List.map (cases_pattern_of_rawconstr Anonymous) l,na)
+  | GApp (loc,GRef (_,ConstructRef cstr),l) ->
+      PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na)
   | _ -> raise Not_found
 
-(* Turn a closed cases pattern into a rawconstr *)
-let rec rawconstr_of_closed_cases_pattern_aux = function
+(* Turn a closed cases pattern into a glob_constr *)
+let rec glob_constr_of_closed_cases_pattern_aux = function
   | PatCstr (loc,cstr,[],Anonymous) ->
-      RRef (loc,ConstructRef cstr)
+      GRef (loc,ConstructRef cstr)
   | PatCstr (loc,cstr,l,Anonymous) ->
-      let ref = RRef (loc,ConstructRef cstr) in
-      RApp (loc,ref, List.map rawconstr_of_closed_cases_pattern_aux l)
+      let ref = GRef (loc,ConstructRef cstr) in
+      GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l)
   | _ -> raise Not_found
 
-let rawconstr_of_closed_cases_pattern = function
+let glob_constr_of_closed_cases_pattern = function
   | PatCstr (loc,cstr,l,na) ->
-      na,rawconstr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
+      na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
   | _ ->
       raise Not_found
 
 (**********************************************************************)
 (* Reduction expressions                                              *)
 
-type 'a raw_red_flag = {
+type 'a glob_red_flag = {
   rBeta : bool;
   rIota : bool;
   rZeta : bool;
@@ -394,8 +394,8 @@ type ('a,'b,'c) red_expr_gen =
   | Red of bool
   | Hnf
   | Simpl of 'c with_occurrences option
-  | Cbv of 'b raw_red_flag
-  | Lazy of 'b raw_red_flag
+  | Cbv of 'b glob_red_flag
+  | Lazy of 'b glob_red_flag
   | Unfold of 'b with_occurrences list
   | Fold of 'a list
   | Pattern of 'a with_occurrences list
diff --git a/pretyping/glob_term.mli b/pretyping/glob_term.mli
new file mode 100644
index 00000000..7fb995a8
--- /dev/null
+++ b/pretyping/glob_term.mli
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(**Untyped intermediate terms, after constr_expr and before constr
+
+   Resolution of names, insertion of implicit arguments placeholder,
+   and notations are done, but coercions, inference of implicit
+   arguments and pattern-matching compilation are not. *)
+
+open Util
+open Names
+open Sign
+open Term
+open Libnames
+open Nametab
+
+(**  The kind of patterns that occurs in "match ... with ... end"
+
+     locs here refers to the ident's location, not whole pat *)
+type cases_pattern =
+  | PatVar of loc * name
+  | PatCstr of loc * constructor * cases_pattern list * name 
+      (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *)
+
+val cases_pattern_loc : cases_pattern -> loc
+
+type patvar = identifier
+
+type glob_sort = GProp of Term.contents | GType of Univ.universe option
+
+type binding_kind = Lib.binding_kind = Explicit | Implicit
+
+type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
+
+type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
+
+type 'a bindings =
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+type 'a cast_type =
+  | CastConv of cast_kind * 'a
+  | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *)
+
+type glob_constr =
+  | GRef of (loc * global_reference)
+  | GVar of (loc * identifier)
+  | GEvar of loc * existential_key * glob_constr list option
+  | GPatVar of loc * (bool * patvar) (** Used for patterns only *)
+  | GApp of loc * glob_constr * glob_constr list
+  | GLambda of loc * name * binding_kind *  glob_constr * glob_constr
+  | GProd of loc * name * binding_kind * glob_constr * glob_constr
+  | GLetIn of loc * name * glob_constr * glob_constr
+  | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses
+      (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in 
+	  [MatchStyle]) *)
+
+  | GLetTuple of loc * name list * (name * glob_constr option) *
+      glob_constr * glob_constr
+  | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr
+  | GRec of loc * fix_kind * identifier array * glob_decl list array *
+      glob_constr array * glob_constr array
+  | GSort of loc * glob_sort
+  | GHole of (loc * Evd.hole_kind)
+  | GCast of loc * glob_constr * glob_constr cast_type
+
+and glob_decl = name * binding_kind * glob_constr option * glob_constr
+
+and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option
+
+and fix_kind =
+  | GFix of ((int option * fix_recursion_order) array * int)
+  | GCoFix of int
+
+and predicate_pattern =
+    name * (loc * inductive * int * name list) option
+      (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)], [k]
+	  is the number of parameter of [I]. *)
+
+and tomatch_tuple = (glob_constr * predicate_pattern)
+
+and tomatch_tuples = tomatch_tuple list
+
+and cases_clause = (loc * identifier list * cases_pattern list * glob_constr)
+(** [(p,il,cl,t)] = "|'cl' as 'il' => 't'" *)
+
+and cases_clauses = cases_clause list
+
+val cases_predicate_names : tomatch_tuples -> name list
+
+(* Apply one argument to a glob_constr *)
+val mkGApp : loc -> glob_constr -> glob_constr -> glob_constr
+
+val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr
+
+(* Ensure traversal from left to right *)
+val map_glob_constr_left_to_right :
+  (glob_constr -> glob_constr) -> glob_constr -> glob_constr
+
+(*
+val map_glob_constr_with_binders_loc : loc ->
+  (identifier -> 'a -> identifier * 'a) ->
+  ('a -> glob_constr -> glob_constr) -> 'a -> glob_constr -> glob_constr
+*)
+
+val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
+val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
+val occur_glob_constr : identifier -> glob_constr -> bool
+val free_glob_vars : glob_constr -> identifier list
+val loc_of_glob_constr : glob_constr -> loc
+
+(** Conversion from glob_constr to cases pattern, if possible
+    
+    Take the current alias as parameter, 
+    @raise Not_found if translation is impossible *)
+val cases_pattern_of_glob_constr : name -> glob_constr -> cases_pattern
+
+val glob_constr_of_closed_cases_pattern : cases_pattern -> name * glob_constr
+
+(** {6 Reduction expressions} *)
+
+type 'a glob_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+val all_flags : 'a glob_red_flag
+
+type 'a or_var = ArgArg of 'a | ArgVar of identifier located
+
+type occurrences_expr = bool * int or_var list
+
+val all_occurrences_expr_but : int or_var list -> occurrences_expr
+val no_occurrences_expr_but : int or_var list -> occurrences_expr
+val all_occurrences_expr : occurrences_expr
+val no_occurrences_expr : occurrences_expr
+
+type 'a with_occurrences = occurrences_expr * 'a
+
+type ('a,'b,'c) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'c with_occurrences option
+  | Cbv of 'b glob_red_flag
+  | Lazy of 'b glob_red_flag
+  | Unfold of 'b with_occurrences list
+  | Fold of 'a list
+  | Pattern of 'a with_occurrences list
+  | ExtraRedExpr of string
+  | CbvVm
+
+type ('a,'b,'c) may_eval =
+  | ConstrTerm of 'a
+  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
+  | ConstrContext of (loc * identifier) * 'a
+  | ConstrTypeOf of 'a
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index edbab0a7..a0976029 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indrec.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* File initially created by Christine Paulin, 1996 *)
 
 (* This file builds various inductive schemes *)
@@ -18,7 +16,6 @@ open Names
 open Libnames
 open Nameops
 open Term
-open Termops
 open Namegen
 open Declarations
 open Entries
@@ -53,11 +50,15 @@ let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
 (* Christine Paulin, 1996 *)
 
 let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
-  let lnamespar = mib.mind_params_ctxt in
+  let lnamespar = List.map
+    (fun (n, c, t) -> (n, c, Termops.refresh_universes t))
+    mib.mind_params_ctxt
+  in
+
   if not (List.mem kind (elim_sorts specif)) then
     raise
       (RecursionSchemeError
-	 (NotAllowedCaseAnalysis (false,new_sort_in_family kind,ind)));
+	 (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind)));
 
   let ndepar = mip.mind_nrealargs_ctxt + 1 in
 
@@ -65,7 +66,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
   (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
   let env' = push_rel_context lnamespar env in
 
-  let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in
+  let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in
   let constrs = get_constructors env indf in
 
   let rec add_branch env k =
@@ -81,8 +82,8 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
-           if dep then extended_rel_vect 0 deparsign
-           else extended_rel_vect 1 arsign) in
+           if dep then Termops.extended_rel_vect 0 deparsign
+           else Termops.extended_rel_vect 1 arsign) in
       let p =
 	it_mkLambda_or_LetIn_name env'
 	  ((if dep then mkLambda_name env' else mkLambda)
@@ -92,7 +93,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
       it_mkLambda_or_LetIn_name env'
        	(mkCase (ci, lift ndepar p,
 		     mkRel 1,
-		     rel_vect ndepar k))
+		     Termops.rel_vect ndepar k))
        	deparsign
     else
       let cs = lift_constructor (k+1) constrs.(k) in
@@ -100,7 +101,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
       mkLambda_string "f" t
 	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
   in
-  let typP = make_arity env' dep indf (new_sort_in_family kind) in
+  let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in
   it_mkLambda_or_LetIn_name env
     (mkLambda_string "P" typP
        (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
@@ -140,7 +141,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	    let base = applist (lift i pk,realargs) in
             if depK then
 	      Reduction.beta_appvect
-                base [|applist (mkRel (i+1),extended_rel_list 0 sign)|]
+                base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
             else
 	      base
       	| _ -> assert false
@@ -155,9 +156,9 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	      | [] -> None,[]
               | ra::rest ->
                   (match dest_recarg ra with
-	            | Mrec j when is_rec -> (depPvect.(j),rest)
+	            | Mrec (_,j) when is_rec -> (depPvect.(j),rest)
 	            | Imbr _  ->
-		        Flags.if_verbose warning "Ignoring recursive call";
+		        Flags.if_warn msg_warning (str "Ignoring recursive call");
 		        (None,rest)
                     | _ -> (None, rest))
 	  in
@@ -212,7 +213,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
             let realargs = list_skipn nparrec largs
-            and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in
+            and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
     in
@@ -225,7 +226,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	  match dest_recarg recarg with
             | Norec   -> None
             | Imbr _  -> None
-            | Mrec i  -> fvect.(i)
+            | Mrec (_,i)  -> fvect.(i)
 	in
         (match optionpos with
            | None ->
@@ -298,7 +299,7 @@ let mis_make_indrec env sigma listdepkind mib =
 
             (* arity in the context of the fixpoint, i.e.
                P1..P_nrec f1..f_nbconstruct *)
-	    let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in
+	    let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family(indi,args) in
 
 	    let arsign,_ = get_arity env indf in
@@ -312,15 +313,15 @@ let mis_make_indrec env sigma listdepkind mib =
 
             (* 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 args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in
+	    let args'' = Termops.extended_rel_list ndepar lnonparrec in
             let indf' = make_ind_family(indi,args'@args'') in
 
 	    let branches =
 	      let constrs = get_constructors env indf' in
-	      let fi = rel_vect (dect-i-nctyi) nctyi in
+	      let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
 	      let vecfi = Array.map
-		(fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
+		(fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
 		fi
 	      in
 		array_map3
@@ -341,9 +342,9 @@ let mis_make_indrec env sigma listdepkind mib =
 	    let deparsign' = (Anonymous,None,depind')::arsign' in
 
 	    let pargs =
-	      let nrpar = extended_rel_list (2*ndepar) lnonparrec
-	      and nrar = if dep then extended_rel_list 0 deparsign'
-		else extended_rel_list 1 arsign'
+	      let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec
+	      and nrar = if dep then Termops.extended_rel_list 0 deparsign'
+		else Termops.extended_rel_list 1 arsign'
 	      in nrpar@nrar
 
 	    in
@@ -362,15 +363,15 @@ let mis_make_indrec env sigma listdepkind mib =
 		  (mkCase (ci, pred,
 		          mkRel 1,
 			  branches))
-		  (lift_rel_context nrec deparsign)
+		  (Termops.lift_rel_context nrec deparsign)
 	    in
 
 	    (* type of i-th component of the mutual fixpoint *)
 
 	    let typtyi =
 	      let concl =
-		let pargs = if dep then extended_rel_vect 0 deparsign
-		  else extended_rel_vect 1 arsign
+		let pargs = if dep then Termops.extended_rel_vect 0 deparsign
+		  else Termops.extended_rel_vect 1 arsign
 		in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
 	      in it_mkProd_or_LetIn_name env
 		concl
@@ -397,7 +398,7 @@ let mis_make_indrec env sigma listdepkind mib =
 	    else
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
 	      let recarg = recargpar@recarg in
-	      let vargs = extended_rel_list (nrec+i+j) lnamesparrec in
+	      let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in
 	      let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
@@ -411,8 +412,8 @@ let mis_make_indrec env sigma listdepkind mib =
     in
     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
+	  let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in
+	  let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in
 	    mkLambda_string "P" typP
 	      (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
       | [] ->
@@ -506,7 +507,7 @@ let check_arities listdepkind =
        let kelim = elim_sorts (mibi,mipi) in
        if not (List.exists ((=) kind) kelim) then raise
 	 (RecursionSchemeError
-	   (NotAllowedCaseAnalysis (true,new_sort_in_family kind,mind)))
+	   (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind)))
        else if List.mem ni ln then raise
 	 (RecursionSchemeError (NotMutualInScheme (mind,mind)))
        else ni::ln)
@@ -558,8 +559,7 @@ let lookup_eliminator ind_sp s =
   (* Try first to get an eliminator defined in the same section as the *)
   (* inductive type *)
   try
-    let cst =Global.constant_of_delta
-      (make_con mp dp (label_of_id id)) in
+    let cst =Global.constant_of_delta_kn (make_kn mp dp (label_of_id id)) in
     let _ = Global.lookup_constant cst in
       mkConst cst
   with Not_found ->
@@ -571,5 +571,5 @@ let lookup_eliminator ind_sp s =
       (strbrk "Cannot find the elimination combinator " ++
        pr_id id ++ strbrk ", the elimination of the inductive definition " ++
        pr_global_env Idset.empty (IndRef ind_sp) ++
-       strbrk " on sort " ++ pr_sort_family s ++
+       strbrk " on sort " ++ Termops.pr_sort_family s ++
        strbrk " is probably not allowed.")
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index b2375c8f..a421ae7d 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indrec.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Declarations
 open Inductiveops
 open Environ
 open Evd
-(*i*)
 
-(* Errors related to recursors building *)
+(** Errors related to recursors building *)
 
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive
@@ -29,35 +25,35 @@ exception RecursionSchemeError of recursion_scheme_error
 
 type dep_flag = bool
 
-(* Build a case analysis elimination scheme in some sort family *)
+(** Build a case analysis elimination scheme in some sort family *)
 
 val build_case_analysis_scheme : env -> evar_map -> inductive ->
       dep_flag -> sorts_family -> constr
 
-(* Build a dependent case elimination predicate unless type is in Prop *)
+(** Build a dependent case elimination predicate unless type is in Prop *)
 
 val build_case_analysis_scheme_default : env -> evar_map -> inductive ->
       sorts_family -> constr
 
-(* Builds a recursive induction scheme (Peano-induction style) in the same
+(** Builds a recursive induction scheme (Peano-induction style) in the same
    sort family as the inductive family; it is dependent if not in Prop *)
 
 val build_induction_scheme : env -> evar_map -> inductive ->
       dep_flag -> sorts_family -> constr
 
-(* Builds mutual (recursive) induction schemes *)
+(** 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
+(** [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]
+(** [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] *)
 
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 6e54c170..15fd226f 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductiveops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Univ
@@ -78,7 +76,7 @@ let mis_is_recursive_subset listind rarg =
     List.exists
       (fun ra ->
         match dest_recarg ra with
-	  | Mrec i -> List.mem i listind
+	  | Mrec (_,i) -> List.mem i listind
           | _ -> false) rvec
   in
   array_exists one_is_rec (dest_subterms rarg)
@@ -145,12 +143,9 @@ let make_case_info env ind style =
   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;
+    ci_cstr_ndecls = mip.mind_consnrealdecls;
     ci_pp_info = print_info }
 
-let make_default_case_info env style ind =
-  make_case_info env ind style
-
 (*s Useful functions *)
 
 type constructor_summary = {
@@ -202,12 +197,6 @@ let get_constructors env (ind,params) =
   Array.init (Array.length mip.mind_consnames)
     (fun j -> get_constructor (ind,mib,mip,params) (j+1))
 
-let rec instantiate args c = match kind_of_term c, args with
-  | Prod (_,_,c), a::args -> instantiate args (subst1 a c)
-  | LetIn (_,b,_,c), args -> instantiate args (subst1 b c)
-  | _, [] -> c
-  | _ -> anomaly "too short arity"
-
 (* substitution in a signature *)
 
 let substnl_rel_context subst n sign =
@@ -413,7 +402,7 @@ let is_constrained is u =
     let _ =
       merge_constraints
         (enforce_geq u (super u')
-          (enforce_geq u' is Constraint.empty))
+          (enforce_geq u' is empty_constraint))
         initial_universes in
     false
   with UniverseInconsistency _ -> true
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index e5759864..f361e8b8 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductiveops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Declarations
@@ -15,19 +13,19 @@ open Environ
 open Evd
 open Sign
 
-(* The following three functions are similar to the ones defined in
+(** The following three functions are similar to the ones defined in
    Inductive, but they expect an env *)
 
 val type_of_inductive    : env -> inductive -> types
 
-(* Return type as quoted by the user *)
+(** Return type as quoted by the user *)
 val type_of_constructor  : env -> constructor -> types
 val type_of_constructors : env -> inductive -> types array
 
-(* Return constructor types in normal form *)
+(** Return constructor types in normal form *)
 val arities_of_constructors : env -> inductive -> types array
 
-(* An inductive type with its parameters *)
+(** An inductive type with its parameters *)
 type inductive_family
 val make_ind_family : inductive * constr list -> inductive_family
 val dest_ind_family : inductive_family -> inductive * constr list
@@ -37,7 +35,7 @@ val lift_inductive_family  : int -> inductive_family -> inductive_family
 val substnl_ind_family :
   constr list -> int -> inductive_family -> inductive_family
 
-(* An inductive type with its parameters and real arguments *)
+(** An inductive type with its parameters and real arguments *)
 type inductive_type = IndType of inductive_family * constr list
 val make_ind_type : inductive_family * constr list -> inductive_type
 val dest_ind_type : inductive_type -> inductive_family * constr list
@@ -53,14 +51,15 @@ val mis_is_recursive :
 val mis_nf_constructor_type :
   inductive * mutual_inductive_body * one_inductive_body -> int -> constr
 
-(* Extract information from an inductive name *)
+(** Extract information from an inductive name *)
 
+(** Arity of constructors excluding parameters and local defs *)
 val mis_constr_nargs : inductive -> int array
 val mis_constr_nargs_env : env -> inductive -> int array
 
 val nconstructors : inductive -> int
 
-(* Return the lengths of parameters signature and real arguments signature *)
+(** 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
@@ -71,14 +70,14 @@ val get_full_arity_sign : env -> inductive -> rel_context
 
 val allowed_sorts : env -> inductive -> sorts_family list
 
-(* Extract information from an inductive family *)
+(** Extract information from an inductive family *)
 
 type constructor_summary = {
-  cs_cstr : constructor;
-  cs_params : constr list;
-  cs_nargs : int;
-  cs_args : rel_context;
-  cs_concl_realargs : constr array;
+  cs_cstr : constructor;    (* internal name of the constructor *)
+  cs_params : constr list;  (* parameters of the constructor in current ctx *)
+  cs_nargs : int;           (* length of arguments signature (letin included) *)
+  cs_args : rel_context;    (* signature of the arguments (letin included) *)
+  cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *)
 }
 val lift_constructor : int -> constructor_summary -> constructor_summary
 val get_constructor :
@@ -92,22 +91,24 @@ val make_arity_signature : env -> bool -> inductive_family -> rel_context
 val make_arity : env -> bool -> inductive_family -> sorts -> types
 val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 
-(* Raise [Not_found] if not given an valid inductive type *)
+(** Raise [Not_found] if not given an valid inductive type *)
 val extract_mrectype : constr -> inductive * constr list
-val find_mrectype    : env -> evar_map -> constr -> inductive * constr list
-val find_rectype     : env -> evar_map -> constr -> inductive_type
-val find_inductive   : env -> evar_map -> constr -> inductive * constr list
-val find_coinductive : env -> evar_map -> constr -> inductive * constr list
+val find_mrectype    : env -> evar_map -> types -> inductive * constr list
+val find_rectype     : env -> evar_map -> types -> inductive_type
+val find_inductive   : env -> evar_map -> types -> inductive * constr list
+val find_coinductive : env -> evar_map -> types -> inductive * constr list
 
 (********************)
 
-(* Builds the case predicate arity (dependent or not) *)
+(** Builds the case predicate arity (dependent or not) *)
 val arity_of_case_predicate :
   env -> inductive_family -> bool -> sorts -> types
 
 val type_case_branches_with_names :
   env -> inductive * constr list -> constr -> constr ->
     types array * types
+
+(** Annotation for cases *)
 val make_case_info : env -> inductive -> case_style -> case_info
 
 (*i Compatibility
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index f0536f22..7a745118 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -1,14 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: matching.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
+open Pp
 open Util
 open Names
 open Libnames
@@ -16,7 +15,7 @@ open Nameops
 open Termops
 open Reductionops
 open Term
-open Rawterm
+open Glob_term
 open Sign
 open Environ
 open Pattern
@@ -56,23 +55,23 @@ let constrain (n,(ids,m as x)) (names,terms as subst) =
   with
       Not_found ->
         if List.mem_assoc n names then
-          Flags.if_verbose Pp.warning
-              ("Collision between bound variable "^string_of_id n^
-                 " and a metavariable of same name.");
+          Flags.if_warn Pp.msg_warning
+              (str "Collision between bound variable " ++ pr_id n ++
+               str " and a metavariable of same name.");
         (names,(n,x)::terms)
 
 let add_binders na1 na2 (names,terms as subst) =
   match na1, na2 with
   | Name id1, Name id2 ->
       if List.mem_assoc id1 names then
-        (Flags.if_verbose Pp.warning
-          ("Collision between bound variables of name "^string_of_id id1);
+        (Flags.if_warn Pp.msg_warning
+          (str "Collision between bound variables of name " ++ pr_id id1);
          (names,terms))
       else
         (if List.mem_assoc id1 terms then
-            Flags.if_verbose Pp.warning
-              ("Collision between bound variable "^string_of_id id1^
-                  " and another bound variable of same name.");
+            Flags.if_warn Pp.msg_warning
+              (str "Collision between bound variable " ++ pr_id id1 ++
+               str " and another bound variable of same name.");
          ((id1,id2)::names,terms));
   | _ -> subst
 
@@ -87,18 +86,6 @@ let build_lambda toabstract stk (m : constr) =
   in
   buildrec m 1 stk
 
-let memb_metavars m n =
-  match (m,n) with
-    | (None, _)     -> true
-    | (Some mvs, n) -> List.mem n mvs
-
-let eq_context ctxt1 ctxt2 = array_for_all2 eq_constr ctxt1 ctxt2
-
-let same_case_structure (_,cs1,ind,_) ci2 br1 br2 =
-  match ind with
-  | Some ind -> ind = ci2.ci_ind
-  | None -> cs1 = ci2.ci_cstr_nargs
-
 let rec list_insert f a = function
   | [] -> [a]
   | b::l when f a b -> a::b::l
@@ -182,9 +169,9 @@ let matches_core convert allow_partial_app allow_bound_rels pat c =
 
       | PRel n1, Rel n2 when n1 = n2 -> subst
 
-      | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> subst
+      | PSort (GProp c1), Sort (Prop c2) when c1 = c2 -> subst
 
-      | PSort (RType _), Sort (Type _) -> subst
+      | PSort (GType _), Sort (Type _) -> subst
 
       | PApp (p, [||]), _ -> sorec stk subst p t
 
@@ -217,8 +204,8 @@ let matches_core convert allow_partial_app allow_bound_rels pat c =
             (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
-	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_nargs.(0) b2 in
-	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_nargs.(1) b2' in
+	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
+	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
 	  let n = rel_context_length ctx in
           let n' = rel_context_length ctx' in
 	  if noccur_between 1 n b2 & noccur_between 1 n' b2' then
@@ -232,11 +219,18 @@ let matches_core convert allow_partial_app allow_bound_rels pat c =
             raise PatternMatchingFailure
 
       | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) ->
-	  if same_case_structure ci1 ci2 br1 br2 then
-  	    array_fold_left2 (sorec stk)
-	      (sorec stk (sorec stk subst a1 a2) p1 p2) br1 br2
-          else
-            raise PatternMatchingFailure
+	  let n2 = Array.length br2 in
+	  if (ci1.cip_ind <> None && ci1.cip_ind <> Some ci2.ci_ind) ||
+	     (not ci1.cip_extensible && List.length br1 <> n2)
+	  then raise PatternMatchingFailure;
+	  let chk_branch subst (j,n,c) =
+	    (* (ind,j+1) is normally known to be a correct constructor
+	       and br2 a correct match over the same inductive *)
+	    assert (j < n2);
+	    sorec stk subst c br2.(j)
+	  in
+	  let chk_head = sorec stk (sorec stk subst a1 a2) p1 p2 in
+	  List.fold_left chk_branch chk_head br1
 
       |	PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst
       |	PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
index fc0e3feb..49033286 100644
--- a/pretyping/matching.mli
+++ b/pretyping/matching.mli
@@ -1,79 +1,82 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: matching.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** This module implements pattern-matching on terms *)
 
-(*i*)
 open Names
 open Term
 open Environ
 open Pattern
 open Termops
-(*i*)
-
-(*s This modules implements pattern-matching on terms *)
 
+(** [PatternMatchingFailure] is the exception raised when pattern
+  matching fails *)
 exception PatternMatchingFailure
 
+(** [special_meta] is the default name of the meta holding the
+   surrounding context in subterm matching *)
 val special_meta : metavariable
 
+(** [bound_ident_map] represents the result of matching binding
+   identifiers of the pattern with the binding identifiers of the term
+   matched *)
 type bound_ident_map = (identifier * identifier) list
 
-(* [matches pat c] matches [c] against [pat] and returns the resulting
+(** [matches pat c] matches [c] against [pat] and returns the resulting
    assignment of metavariables; it raises [PatternMatchingFailure] if
    not matchable; bindings are given in increasing order based on the
    numbers given in the pattern *)
 val matches : constr_pattern -> constr -> patvar_map
 
-(* [extended_matches pat c] also returns the names of bound variables
+(** [extended_matches pat c] also returns the names of bound variables
    in [c] that matches the bound variables in [pat]; if several bound
    variables or metavariables have the same name, the metavariable,
    or else the rightmost bound variable, takes precedence *)
 val extended_matches :
   constr_pattern -> constr -> bound_ident_map * extended_patvar_map
 
-(* [is_matching pat c] just tells if [c] matches against [pat] *)
+(** [is_matching pat c] just tells if [c] matches against [pat] *)
 val is_matching : constr_pattern -> constr -> bool
 
-(* [matches_conv env sigma] matches up to conversion in environment
+(** [matches_conv env sigma] matches up to conversion in environment
    [(env,sigma)] when constants in pattern are concerned; it raises
    [PatternMatchingFailure] if not matchable; bindings are given in
    increasing order based on the numbers given in the pattern *)
 val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
 
-(* The type of subterm matching results: a substitution + a context
+(** The type of subterm matching results: a substitution + a context
    (whose hole is denoted with [special_meta]) + a continuation that
    either returns the next matching subterm or raise PatternMatchingFailure *)
 type subterm_matching_result =
     (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result)
 
-(* [match_subterm n pat c] returns the substitution and the context
+(** [match_subterm n pat c] returns the substitution and the context
    corresponding to the first **closed** subterm of [c] matching [pat], and
    a continuation that looks for the next matching subterm.
    It raises PatternMatchingFailure if no subterm matches the pattern *)
 val match_subterm : constr_pattern -> constr -> subterm_matching_result
 
-(* [match_appsubterm pat c] returns the substitution and the context
+(** [match_appsubterm pat c] returns the substitution and the context
    corresponding to the first **closed** subterm of [c] matching [pat],
    considering application contexts as well. It also returns a
    continuation that looks for the next matching subterm.
    It raises PatternMatchingFailure if no subterm matches the pattern *)
 val match_appsubterm : constr_pattern -> constr -> subterm_matching_result
 
-(* [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : bool (* true = with app context *) ->
+(** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
+val match_subterm_gen : bool (** true = with app context *) ->
    constr_pattern -> constr -> subterm_matching_result
 
-(* [is_matching_appsubterm pat c] tells if a subterm of [c] matches
+(** [is_matching_appsubterm pat c] tells if a subterm of [c] matches
    against [pat] taking partial subterms into consideration *)
 val is_matching_appsubterm : ?closed:bool -> constr_pattern -> constr -> bool
 
-(* [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
+(** [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
    up to conversion for constants in patterns *)
 val is_matching_conv :
   env -> Evd.evar_map -> constr_pattern -> constr -> bool
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
index 45060511..2ad2f351 100644
--- a/pretyping/namegen.ml
+++ b/pretyping/namegen.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: namegen.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Created from contents that was formerly in termops.ml and
    nameops.ml, Nov 2009 *)
 
@@ -133,9 +131,9 @@ 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)
+  it_mkProd_or_LetIn b (name_context env hyps)
 let it_mkLambda_or_LetIn_name env b hyps =
-  it_mkLambda_or_LetIn ~init:b (name_context env hyps)
+  it_mkLambda_or_LetIn b (name_context env hyps)
 
 (**********************************************************************)
 (* Fresh names *)
@@ -207,6 +205,17 @@ 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 reserved_type_name = ref (fun t -> Anonymous)
+let set_reserved_typed_name f = reserved_type_name := f
+
+let next_name_away_with_default_using_types default na avoid t =
+  let id = match na with
+    | Name id -> id
+    | Anonymous -> match !reserved_type_name t 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 =
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
index f99ee3f6..637cbf64 100644
--- a/pretyping/namegen.mli
+++ b/pretyping/namegen.mli
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: namegen.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Term
 open Environ
 
-(**********************************************************************)
-(* Generating "intuitive" names from their type *)
+(*********************************************************************
+   Generating "intuitive" names from their type *)
 
 val lowercase_first_char : identifier -> string
 val sort_hdchar : sorts -> string
@@ -24,7 +22,7 @@ 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] *)
+(** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
 val prod_name : env -> name * types * types -> types
 val lambda_name : env -> name * types * constr -> constr
 
@@ -38,32 +36,40 @@ 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 *)
+(*********************************************************************
+   Fresh names *)
+
+(** Avoid clashing with a name satisfying some predicate *)
+val next_ident_away_from : identifier -> (identifier -> bool) -> identifier
 
-(* Avoid clashing with a name of the given list *)
+(** 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 *)
+(** 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 *)
+(** 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 *)
+(** 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  : name -> identifier list -> identifier (** default is "H" *)
 val next_name_away_with_default : string -> name -> identifier list ->
   identifier
 
-(**********************************************************************)
-(* Making name distinct for displaying *)
+val next_name_away_with_default_using_types : string -> name ->
+  identifier list -> types -> identifier
+
+val set_reserved_typed_name : (types -> name) -> unit
+
+(*********************************************************************
+   Making name distinct for displaying *)
 
 type renaming_flags =
-  | RenamingForCasesPattern (* avoid only global constructors *)
-  | RenamingForGoal (* avoid all globals (as in intro) *)
+  | RenamingForCasesPattern (** avoid only global constructors *)
+  | RenamingForGoal (** avoid all globals (as in intro) *)
   | RenamingElsewhereFor of constr
 
 val make_all_name_different : env -> env
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index 83bfe9ea..65f342d8 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pattern.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Libnames
 open Nameops
 open Term
-open Rawterm
+open Glob_term
 open Environ
 open Nametab
 open Pp
@@ -28,6 +26,12 @@ type extended_patvar_map = (patvar * constr_under_binders) list
 
 (* Patterns *)
 
+type case_info_pattern =
+    { cip_style : case_style;
+      cip_ind : inductive option;
+      cip_ind_args : (int * int) option; (** number of params and args *)
+      cip_extensible : bool (** does this match end with _ => _ ? *) }
+
 type constr_pattern =
   | PRef of global_reference
   | PVar of identifier
@@ -38,11 +42,11 @@ type constr_pattern =
   | PLambda of name * constr_pattern * constr_pattern
   | PProd of name * constr_pattern * constr_pattern
   | PLetIn of name * constr_pattern * constr_pattern
-  | PSort of rawsort
+  | PSort of glob_sort
   | PMeta of patvar option
   | PIf of constr_pattern * constr_pattern * constr_pattern
-  | PCase of (case_style * int array * inductive option * (int * int) option)
-      * constr_pattern * constr_pattern * constr_pattern array
+  | PCase of case_info_pattern * constr_pattern * constr_pattern *
+      (int * int * constr_pattern) list (** constructor index, nb of args *)
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
@@ -57,16 +61,11 @@ let rec occur_meta_pattern = function
       (occur_meta_pattern c1) or (occur_meta_pattern c2)
   | PCase(_,p,c,br) ->
       (occur_meta_pattern p) or
-      (occur_meta_pattern c) or (array_exists occur_meta_pattern br)
+      (occur_meta_pattern c) or
+      (List.exists (fun (_,_,p) -> occur_meta_pattern p) br)
   | PMeta _ | PSoApp _ -> true
   | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false
 
-type constr_label =
-  | ConstNode of constant
-  | IndNode of inductive
-  | CstrNode of constructor
-  | VarNode of identifier
-
 exception BoundPattern;;
 
 let rec head_pattern_bound t =
@@ -100,8 +99,8 @@ let pattern_of_constr sigma t =
     | Rel n  -> PRel n
     | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n)))
     | Var id -> PVar id
-    | Sort (Prop c) -> PSort (RProp c)
-    | Sort (Type _) -> PSort (RType None)
+    | Sort (Prop c) -> PSort (GProp c)
+    | Sort (Type _) -> PSort (GType None)
     | Cast (c,_,_)      -> pattern_of_constr c
     | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
     | Prod (na,c,b)   -> PProd (na,pattern_of_constr c,pattern_of_constr b)
@@ -130,11 +129,17 @@ let pattern_of_constr sigma t =
           | 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
-	PCase ((cip.style,ci.ci_cstr_nargs,Some ci.ci_ind,no),
-	       pattern_of_constr p,pattern_of_constr a,
-	       Array.map pattern_of_constr br)
+        let cip =
+	  { cip_style = ci.ci_pp_info.style;
+	    cip_ind = Some ci.ci_ind;
+	    cip_ind_args = Some (ci.ci_npar, ci.ci_pp_info.ind_nargs);
+	    cip_extensible = false }
+	in
+	let branch_of_constr i c =
+	  (i, ci.ci_cstr_ndecls.(i), pattern_of_constr c)
+	in
+	PCase (cip, pattern_of_constr p, pattern_of_constr a,
+	       Array.to_list (Array.mapi branch_of_constr br))
     | Fix f -> PFix f
     | CoFix f -> PCoFix f in
   let p = pattern_of_constr t in
@@ -151,14 +156,13 @@ let map_pattern_with_binders g f l = function
   | 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)
+  | PCase (ci,po,p,pl) ->
+    PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl)
   (* Non recursive *)
   | (PVar _ | PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _
   (* Bound to terms *)
   | PFix _ | PCoFix _ as x) -> x
 
-let map_pattern f = map_pattern_with_binders (fun _ () -> ()) (fun () -> f) ()
-
 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
@@ -235,14 +239,20 @@ let rec subst_pattern subst pat =
       let c2' = subst_pattern subst c2 in
 	if c' == c && c1' == c1 && c2' == c2 then pat else
 	  PIf (c',c1',c2')
-  | PCase ((a,b,ind,n as cs),typ,c,branches) ->
+  | PCase (cip,typ,c,branches) ->
+      let ind = cip.cip_ind in
       let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in
+      let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in
       let typ' = subst_pattern subst typ in
       let c' = subst_pattern subst c in
-      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')
+      let subst_branch ((i,n,c) as br) =
+	let c' = subst_pattern subst c in
+	if c' == c then br else (i,n,c')
+      in
+      let branches' = list_smartmap subst_branch branches in
+      if cip' == cip && typ' == typ && c' == c && branches' == branches
+      then pat
+      else PCase(cip', typ', c', branches')
   | PFix fixpoint ->
       let cstr = mkFix fixpoint in
       let fixpoint' = destFix (subst_mps subst cstr) in
@@ -257,94 +267,109 @@ let rec subst_pattern subst pat =
 let mkPLambda na b = PLambda(na,PMeta None,b)
 let rev_it_mkPLambda = List.fold_right mkPLambda
 
+let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
+
 let rec pat_of_raw metas vars = function
-  | RVar (_,id) ->
+  | GVar (_,id) ->
       (try PRel (list_index (Name id) vars)
        with Not_found -> PVar id)
-  | RPatVar (_,(false,n)) ->
+  | GPatVar (_,(false,n)) ->
       metas := n::!metas; PMeta (Some n)
-  | RRef (_,gr) ->
+  | GRef (_,gr) ->
       PRef (canonical_gr gr)
   (* Hack pour ne pas réécrire une interprétation complète des patterns*)
-  | RApp (_, RPatVar (_,(true,n)), cl) ->
+  | GApp (_, GPatVar (_,(true,n)), cl) ->
       metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
-  | RApp (_,c,cl) ->
+  | GApp (_,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) ->
+  | GLambda (_,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) ->
+  | GProd (_,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) ->
+  | GLetIn (_,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) ->
+  | GSort (_,s) ->
       PSort s
-  | RHole _ ->
+  | GHole _ ->
       PMeta None
-  | RCast (_,c,_) ->
-      Flags.if_verbose
-        Pp.warning "Cast not taken into account in constr pattern";
+  | GCast (_,c,_) ->
+      Flags.if_warn
+        Pp.msg_warning (str "Cast not taken into account in constr pattern");
       pat_of_raw metas vars c
-  | RIf (_,c,(_,None),b1,b2) ->
+  | GIf (_,c,(_,None),b1,b2) ->
       PIf (pat_of_raw metas vars c,
            pat_of_raw metas vars b1,pat_of_raw metas vars b2)
-  | RLetTuple (loc,nal,(_,None),b,c) ->
-      let mkRLambda c na = RLambda (loc,na,Explicit,RHole (loc,Evd.InternalHole),c) in
-      let c = List.fold_left mkRLambda c nal in
-      PCase ((LetStyle,[|1|],None,None),PMeta None,pat_of_raw metas vars b,
-             [|pat_of_raw metas vars c|])
-  | RCases (loc,sty,p,[c,(na,indnames)],brs) ->
-      let pred,ind_nargs, ind = match p,indnames with
-	| Some p, Some (_,ind,n,nal) ->
-	    rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p)),
-	    Some (n,List.length nal),Some ind
-	| _ -> PMeta None, None, None in
-      let ind = match ind with Some _ -> ind | None ->
-	match brs with
-	  | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
-	  | _ -> None in
-      let cbrs =
-	Array.init (List.length brs) (pat_of_raw_branch loc metas vars ind brs)
+  | GLetTuple (loc,nal,(_,None),b,c) ->
+      let mkGLambda c na = GLambda (loc,na,Explicit,GHole (loc,Evd.InternalHole),c) in
+      let c = List.fold_left mkGLambda c nal in
+      let cip =
+	{ cip_style = LetStyle;
+	  cip_ind = None;
+	  cip_ind_args = None;
+	  cip_extensible = false }
+      in
+      PCase (cip, PMeta None, pat_of_raw metas vars b,
+             [0,1,pat_of_raw metas vars c])
+  | GCases (loc,sty,p,[c,(na,indnames)],brs) ->
+      let get_ind = function
+	| (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
+	| _ -> None
+      in
+      let ind_nargs,ind = match indnames with
+	| Some (_,ind,n,nal) -> Some (n,List.length nal), Some ind
+	| None -> None, get_ind brs
+      in
+      let ext,brs = pats_of_glob_branches loc metas vars ind brs
+      in
+      let pred = match p,indnames with
+	| Some p, Some (_,_,_,nal) ->
+	  rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p))
+	| _ -> PMeta None
+      in
+      let info =
+	{ cip_style = sty;
+	  cip_ind = ind;
+	  cip_ind_args = ind_nargs;
+	  cip_extensible = ext }
       in
-      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)
+      (* Nota : when we have a non-trivial predicate,
+	 the inductive type is known. Same when we have at least
+	 one non-trivial branch. These facts are used in [Constrextern]. *)
+      PCase (info, 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.")
+  | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.")
 
-and pat_of_raw_branch loc metas vars ind brs i =
-  let bri = List.filter
-    (function
-        (_,_,[PatCstr(_,c,lv,Anonymous)],_) -> snd c = i+1
-      | (loc,_,_,_) ->
-          user_err_loc (loc,"pattern_of_rawconstr",
-                        Pp.str "Non supported pattern.")) brs in
-  match bri with
-    | [(_,_,[PatCstr(_,(indsp,_),lv,_)],br)] ->
-	if ind <> None & ind <> Some indsp then
-          user_err_loc (loc,"pattern_of_rawconstr",
-            Pp.str "All constructors must be in the same inductive type.");
-        let lna =
-          List.map
-            (function PatVar(_,na) -> na
-              | PatCstr(loc,_,_,_) ->
-                  user_err_loc (loc,"pattern_of_rawconstr",
-                                Pp.str "Non supported pattern.")) lv 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) ++
-                         str"-th constructor.")
+and pats_of_glob_branches loc metas vars ind brs =
+  let get_arg = function
+    | PatVar(_,na) -> na
+    | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.")
+  in
+  let rec get_pat indexes = function
+    | [] -> false, []
+    | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *)
+    | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs ->
+      if ind <> None && ind <> Some indsp then
+        err loc (Pp.str "All constructors must be in the same inductive type.");
+      if Intset.mem (j-1) indexes then
+	err loc
+          (str "No unique branch for " ++ int j ++ str"-th constructor.");
+      let lna = List.map get_arg lv in
+      let vars' = List.rev lna @ vars in
+      let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in
+      let ext,pats = get_pat (Intset.add (j-1) indexes) brs in
+      ext, ((j-1, List.length lv, pat) :: pats)
+    | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.")
+  in
+  get_pat Intset.empty brs
 
-let pattern_of_rawconstr c =
+let pattern_of_glob_constr c =
   let metas = ref [] in
   let p = pat_of_raw metas [] c in	
   (!metas,p)
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
index 195fecfe..cde6d4dc 100644
--- a/pretyping/pattern.mli
+++ b/pretyping/pattern.mli
@@ -1,14 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pattern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** This module defines the type of pattern used for pattern-matching
+    terms in tatics *)
 
-(*i*)
 open Pp
 open Names
 open Sign
@@ -16,17 +16,55 @@ open Term
 open Environ
 open Libnames
 open Nametab
-open Rawterm
+open Glob_term
 open Mod_subst
-(*i*)
 
-(* Types of substitutions with or w/o bound variables *)
+(** {5 Maps of pattern variables} *)
+
+(** Type [constr_under_binders] is for representing the term resulting
+    of a matching. Matching can return terms defined in a some context
+    of named binders; in the context, variable names are ordered by
+    (<) and referred to by index in the term Thanks to the canonical
+    ordering, a matching problem like
+
+    [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]]
+
+    will be accepted. Thanks to the reference by index, a matching
+    problem like
+
+    [match ... with [(fun x => ?p)] => [forall x => p]]
+
+    will work even if [x] is also the name of an existing goal
+    variable.
+
+    Note: we do not keep types in the signature. Besides simplicity,
+    the main reason is that it would force to close the signature over
+    binders that occur only in the types of effective binders but not
+    in the term itself (e.g. for a term [f x] with [f:A -> True] and
+    [x:A]).
+
+    On the opposite side, by not keeping the types, we loose
+    opportunity to propagate type informations which otherwise would
+    not be inferable, as e.g. when matching [forall x, x = 0] with
+    pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in
+    expression [forall x, h = x] where nothing tells how the type of x
+    could be inferred. We also loose the ability of typing ltac
+    variables before calling the right-hand-side of ltac matching clauses. *)
 
 type constr_under_binders = identifier list * constr
+
+(** Types of substitutions with or w/o bound variables *)
+
 type patvar_map = (patvar * constr) list
 type extended_patvar_map = (patvar * constr_under_binders) list
 
-(* Patterns *)
+(** {5 Patterns} *)
+
+type case_info_pattern =
+    { cip_style : case_style;
+      cip_ind : inductive option;
+      cip_ind_args : (int * int) option; (** number of params and args *)
+      cip_extensible : bool (** does this match end with _ => _ ? *) }
 
 type constr_pattern =
   | PRef of global_reference
@@ -38,14 +76,17 @@ type constr_pattern =
   | PLambda of name * constr_pattern * constr_pattern
   | PProd of name * constr_pattern * constr_pattern
   | PLetIn of name * constr_pattern * constr_pattern
-  | PSort of rawsort
+  | PSort of glob_sort
   | PMeta of patvar option
   | PIf of constr_pattern * constr_pattern * constr_pattern
-  | PCase of (case_style * int array * inductive option * (int * int) option)
-      * constr_pattern * constr_pattern * constr_pattern array
+  | PCase of case_info_pattern * constr_pattern * constr_pattern *
+      (int * int * constr_pattern) list (** index of constructor, nb of args *)
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
+(** Nota : in a [PCase], the array of branches might be shorter than
+    expected, denoting the use of a final "_ => _" branch *)
+
 (** {5 Functions on patterns} *)
 
 val occur_meta_pattern : constr_pattern -> bool
@@ -54,28 +95,28 @@ val subst_pattern : substitution -> constr_pattern -> constr_pattern
 
 exception BoundPattern
 
-(* [head_pattern_bound t] extracts the head variable/constant of the
+(** [head_pattern_bound t] extracts the head variable/constant of the
    type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
    if [t] is an abstraction *)
 
 val head_pattern_bound : constr_pattern -> global_reference
 
-(* [head_of_constr_reference c] assumes [r] denotes a reference and
+(** [head_of_constr_reference c] assumes [r] denotes a reference and
    returns its label; raises an anomaly otherwise *)
 
 val head_of_constr_reference : Term.constr -> global_reference
 
-(* [pattern_of_constr c] translates a term [c] with metavariables into
+(** [pattern_of_constr c] translates a term [c] with metavariables into
    a pattern; currently, no destructor (Cases, Fix, Cofix) and no
    existential variable are allowed in [c] *)
 
 val pattern_of_constr : Evd.evar_map -> constr -> named_context * constr_pattern
 
-(* [pattern_of_rawconstr l c] translates a term [c] with metavariables into
+(** [pattern_of_glob_constr l c] translates a term [c] with metavariables into
    a pattern; variables bound in [l] are replaced by the pattern to which they
     are bound *)
 
-val pattern_of_rawconstr : rawconstr ->
+val pattern_of_glob_constr : glob_constr ->
       patvar list * constr_pattern
 
 val instantiate_pattern :
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 688a25b9..2cf16791 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretype_errors.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Util
-open Stdpp
 open Names
 open Sign
 open Term
@@ -17,7 +15,7 @@ open Termops
 open Namegen
 open Environ
 open Type_errors
-open Rawterm
+open Glob_term
 open Inductiveops
 
 type pretype_error =
@@ -40,12 +38,13 @@ type pretype_error =
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
   | NotProduct of constr
+  | TypingError of type_error
 
-exception PretypeError of env * pretype_error
+exception PretypeError of env * Evd.evar_map * pretype_error
 
 let precatchable_exception = function
   | Util.UserError _ | TypeError _ | PretypeError _
-  | Stdpp.Exc_located(_,(Util.UserError _ | TypeError _ |
+  | Loc.Exc_located(_,(Util.UserError _ | TypeError _ |
     Nametab.GlobalizationError _ | PretypeError _)) -> true
   | _ -> false
 
@@ -57,25 +56,22 @@ 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_betaiotaevar sigma jl =
+  Array.map (j_nf_betaiotaevar sigma) jl
 let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
 let tj_nf_evar sigma {utj_val=v;utj_type=t} =
   {utj_val=nf_evar sigma v;utj_type=t}
 
-let env_ise sigma env =
-  let sign = named_context_val env in
-  let ctxt = rel_context env in
-  let env0 = reset_with_named_context sign env in
-  Sign.fold_rel_context
-    (fun (na,b,ty) e ->
-      push_rel
-        (na, Option.map (nf_evar sigma) b, nf_evar sigma ty)
-        e)
-    ctxt
-    ~init:env0
-
-(* This simplify the typing context of Cases clauses *)
+let env_nf_evar sigma env =
+  process_rel_context
+    (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+  process_rel_context
+    (fun d e ->
+      push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
+
+(* This simplifies the typing context of Cases clauses *)
 (* hope it does not disturb other typing contexts *)
 let contract env lc =
   let l = ref [] in
@@ -99,111 +95,92 @@ let contract2 env a b = match contract env [a;b] with
 let contract3 env a b c = match contract env [a;b;c] with
   | env, [a;b;c] -> env,a,b,c | _ -> assert false
 
-let raise_pretype_error (loc,ctx,sigma,te) =
-  Stdpp.raise_with_loc loc (PretypeError(env_ise sigma ctx,te))
+let raise_pretype_error (loc,env,sigma,te) =
+  Loc.raise loc (PretypeError(env,sigma,te))
 
-let raise_located_type_error (loc,ctx,sigma,te) =
-  Stdpp.raise_with_loc loc (TypeError(env_ise sigma ctx,te))
+let raise_located_type_error (loc,env,sigma,te) =
+  Loc.raise loc (PretypeError(env,sigma,TypingError te))
 
 
 let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty =
   let env, c, actty, expty = contract3 env c actty expty in
-  let j = j_nf_evar sigma {uj_val=c;uj_type=actty} in
-  raise_located_type_error
-    (loc, env, sigma, ActualType (j, nf_evar sigma expty))
+  let j = {uj_val=c;uj_type=actty} in
+  raise_located_type_error (loc, env, sigma, ActualType (j, expty))
 
 let error_cant_apply_not_functional_loc loc env sigma rator randl =
-  let ja = Array.of_list (jl_nf_evar sigma randl) in
   raise_located_type_error
-    (loc, env, sigma,
-    CantApplyNonFunctional (j_nf_evar sigma rator, ja))
+    (loc, env, sigma, CantApplyNonFunctional (rator, Array.of_list randl))
 
 let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl =
-  let ja = Array.of_list (jl_nf_betaiotaevar sigma randl) in
   raise_located_type_error
     (loc, env, sigma,
-     CantApplyBadType
-       ((n,nf_evar sigma c, Reductionops.nf_betaiota sigma t),
-        j_nf_evar sigma rator, ja))
+       CantApplyBadType ((n,c,t), rator, Array.of_list randl))
 
 let error_ill_formed_branch_loc loc env sigma c i actty expty =
-  let simp t = Reduction.nf_betaiota (nf_evar sigma t) in
   raise_located_type_error
-    (loc, env, sigma,
-     IllFormedBranch (nf_evar sigma c,i,simp actty, simp expty))
+    (loc, env, sigma, IllFormedBranch (c, i, actty, expty))
 
 let error_number_branches_loc loc env sigma cj expn =
-  raise_located_type_error
-    (loc, env, sigma,
-     NumberBranches (j_nf_evar sigma cj, expn))
+  raise_located_type_error (loc, env, sigma, NumberBranches (cj, expn))
 
 let error_case_not_inductive_loc loc env sigma cj =
-  raise_located_type_error
-    (loc, env, sigma, CaseNotInductive (j_nf_evar sigma cj))
+  raise_located_type_error (loc, env, sigma, CaseNotInductive cj)
 
 let error_ill_typed_rec_body_loc loc env sigma i na jl tys =
   raise_located_type_error
-    (loc, env, sigma,
-     IllTypedRecBody (i,na,jv_nf_evar sigma jl,
-                      Array.map (nf_evar sigma) tys))
+    (loc, env, sigma, IllTypedRecBody (i, na, jl, tys))
 
 let error_not_a_type_loc loc env sigma j =
-  raise_located_type_error (loc, env, sigma, NotAType (j_nf_evar sigma j))
+  raise_located_type_error (loc, env, sigma, NotAType j)
 
 (*s Implicit arguments synthesis errors. It is hard to find
     a precise location. *)
 
 let error_occur_check env sigma ev c =
-  let c = nf_evar sigma c in
-  raise (PretypeError (env_ise sigma env, OccurCheck (ev,c)))
+  raise (PretypeError (env, sigma, OccurCheck (ev,c)))
 
 let error_not_clean env sigma ev c (loc,k) =
-  let c = nf_evar sigma c in
-  raise_with_loc loc
-    (PretypeError (env_ise sigma env,  NotClean (ev,c,k)))
+  Loc.raise loc (PretypeError (env, sigma, NotClean (ev,c,k)))
 
 let error_unsolvable_implicit loc env sigma evi e explain =
-  raise_with_loc loc
-    (PretypeError (env_ise sigma env, UnsolvableImplicit (evi, e, explain)))
+  Loc.raise loc
+    (PretypeError (env, sigma, UnsolvableImplicit (evi, e, explain)))
 
 let error_cannot_unify env sigma (m,n) =
-  raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+  raise (PretypeError (env, sigma,CannotUnify (m,n)))
 
 let error_cannot_unify_local env sigma (m,n,sn) =
-  raise (PretypeError (env_ise sigma env,CannotUnifyLocal (m,n,sn)))
+  raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn)))
 
 let error_cannot_coerce env sigma (m,n) =
-  raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+  raise (PretypeError (env, sigma,CannotUnify (m,n)))
 
 let error_cannot_find_well_typed_abstraction env sigma p l =
-  raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l)))
+  raise (PretypeError (env, sigma,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)))
+  raise (PretypeError (env, sigma,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)))
+  raise (PretypeError (env, sigma,NonLinearUnification (m,t)))
 
 (*s Ml Case errors *)
 
 let error_cant_find_case_type_loc loc env sigma expr =
-  raise_pretype_error
-    (loc, env, sigma, CantFindCaseType (nf_evar sigma expr))
+  raise_pretype_error (loc, env, sigma, CantFindCaseType expr)
 
 (*s Pretyping errors *)
 
 let error_unexpected_type_loc loc env sigma actty expty =
   let env, actty, expty = contract2 env actty expty in
-  raise_pretype_error
-    (loc, env, sigma,
-     UnexpectedType (nf_evar sigma actty, nf_evar sigma expty))
+  raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty))
 
 let error_not_product_loc loc env sigma c =
-  raise_pretype_error (loc, env, sigma, NotProduct (nf_evar sigma c))
+  raise_pretype_error (loc, env, sigma, NotProduct c)
 
-(*s Error in conversion from AST to rawterms *)
+(*s Error in conversion from AST to glob_constr *)
 
 let error_var_not_found_loc loc s =
   raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s)
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index d3e6ffea..3a3dccb4 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -1,30 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretype_errors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
 open Term
 open Sign
 open Environ
-open Rawterm
+open Glob_term
 open Inductiveops
-(*i*)
 
-(*s The type of errors raised by the pretyper *)
+(** {6 The type of errors raised by the pretyper } *)
 
 type pretype_error =
-  (* Old Case *)
+  (** Old Case *)
   | CantFindCaseType of constr
-  (* Unification *)
+  (** Unification *)
   | OccurCheck of existential_key * constr
   | NotClean of existential_key * constr * Evd.hole_kind
   | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind *
@@ -37,51 +33,55 @@ type pretype_error =
   | CannotFindWellTypedAbstraction of constr * constr list
   | AbstractionOverMeta of name * name
   | NonLinearUnification of name * constr
-  (* Pretyping *)
+  (** Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
   | NotProduct of constr
+  | TypingError of Type_errors.type_error
 
-exception PretypeError of env * pretype_error
+exception PretypeError of env * Evd.evar_map * pretype_error
 
 val precatchable_exception : exn -> bool
 
-(* Presenting terms without solved evars *)
-val nf_evar :  Evd.evar_map -> constr -> constr
-val j_nf_evar :  Evd.evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
-   Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
-   Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
-   Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+(** Presenting terms without solved evars *)
+val nf_evar : Evd.evar_map -> constr -> constr
+val j_nf_evar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar : Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar : Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar : Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+val env_nf_evar : Evd.evar_map -> env -> env
+val env_nf_betaiotaevar : Evd.evar_map -> env -> env
 
+val j_nf_betaiotaevar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment
+val jv_nf_betaiotaevar :
+  Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
 
-(* Raising errors *)
+(** Raising errors *)
 val error_actual_type_loc :
-  loc -> env ->  Evd.evar_map -> unsafe_judgment -> constr -> 'b
+  loc -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b
 
 val error_cant_apply_not_functional_loc :
-  loc -> env ->  Evd.evar_map ->
+  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 ->
+  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
+  loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b
 
 val error_ill_formed_branch_loc :
-  loc -> env ->  Evd.evar_map ->
-      constr -> int -> constr -> constr -> 'b
+  loc -> env -> Evd.evar_map ->
+      constr -> constructor -> constr -> constr -> 'b
 
 val error_number_branches_loc :
-  loc -> env ->  Evd.evar_map ->
+  loc -> env -> Evd.evar_map ->
       unsafe_judgment -> int -> 'b
 
 val error_ill_typed_rec_body_loc :
-  loc -> env ->  Evd.evar_map ->
+  loc -> env -> Evd.evar_map ->
       int -> name array -> unsafe_judgment array -> types array -> 'b
 
 val error_not_a_type_loc :
@@ -89,9 +89,9 @@ val error_not_a_type_loc :
 
 val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
 
-(*s Implicit arguments synthesis errors *)
+(** {6 Implicit arguments synthesis errors } *)
 
-val error_occur_check : env ->  Evd.evar_map -> existential_key -> constr -> 'b
+val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b
 
 val error_not_clean :
   env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
@@ -113,19 +113,19 @@ val error_abstraction_over_meta : env -> Evd.evar_map ->
 val error_non_linear_unification : env -> Evd.evar_map ->
   metavariable -> constr -> 'b
 
-(*s Ml Case errors *)
+(** {6 Ml Case errors } *)
 
 val error_cant_find_case_type_loc :
-  loc -> env ->  Evd.evar_map -> constr -> 'b
+  loc -> env -> Evd.evar_map -> constr -> 'b
 
-(*s Pretyping errors *)
+(** {6 Pretyping errors } *)
 
 val error_unexpected_type_loc :
-  loc -> env ->  Evd.evar_map -> constr -> constr -> 'b
+  loc -> env -> Evd.evar_map -> constr -> constr -> 'b
 
 val error_not_product_loc :
-  loc -> env ->  Evd.evar_map -> constr -> 'b
+  loc -> env -> Evd.evar_map -> constr -> 'b
 
-(*s Error in conversion from AST to rawterms *)
+(** {6 Error in conversion from AST to glob_constr } *)
 
 val error_var_not_found_loc : loc -> identifier -> 'b
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index a3b1dd18..901936f3 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -1,13 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* This file contains the syntax-directed part of the type inference
+   algorithm introduced by Murthy in Coq V5.10, 1995; the type
+   inference algorithm was initially developed in a file named trad.ml
+   which formerly contained a simple concrete-to-abstract syntax
+   translation function introduced in CoC V4.10 for implementing the
+   "exact" tactic, 1989 *)
+(* Support for typing term in Ltac environment by David Delahaye, 2000 *)
+(* Type inference algorithm made a functor of the coercion and
+   pattern-matching compilation by Matthieu Sozeau, March 2006 *)
+(* Fixpoint guard index computation by Pierre Letouzey, July 2007 *)
 
+(* Structural maintainer: Hugo Herbelin *)
+(* Secondary maintenance: collective *)
+
+
+open Compat
 open Pp
 open Util
 open Names
@@ -26,7 +40,7 @@ open List
 open Recordops
 open Evarutil
 open Pretype_errors
-open Rawterm
+open Glob_term
 open Evarconv
 open Pattern
 
@@ -34,7 +48,8 @@ type typing_constraint = OfType of types option | IsType
 type var_map = (identifier * constr_under_binders) list
 type unbound_ltac_var_map = (identifier * identifier option) list
 type ltac_var_map = var_map * unbound_ltac_var_map
-type rawconstr_ltac_closure = ltac_var_map * rawconstr
+type glob_constr_ltac_closure = ltac_var_map * glob_constr
+type pure_open_constr = evar_map * constr
 
 (************************************************************************)
 (* This concerns Cases *)
@@ -55,7 +70,7 @@ let search_guard loc env possible_indexes fixdefs =
     let indexes = Array.of_list (List.map List.hd possible_indexes) in
     let fix = ((indexes, 0),fixdefs) in
     (try check_fix env fix with
-       | e -> if loc = dummy_loc then raise e else Stdpp.raise_with_loc loc e);
+       | e -> if loc = dummy_loc then raise e else Loc.raise loc e);
     indexes
   else
     (* we now search recursively amoungst all combinations *)
@@ -72,20 +87,53 @@ let search_guard loc env possible_indexes fixdefs =
 	 user_err_loc (loc,"search_guard", Pp.str errmsg)
      with Found indexes -> indexes)
 
-(* To embed constr in rawconstr *)
+(* To embed constr in glob_constr *)
 let ((constr_in : constr -> Dyn.t),
      (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
 
 (** Miscellaneous interpretation functions *)
 
 let interp_sort = function
-  | RProp c -> Prop c
-  | RType _ -> new_Type_sort ()
+  | GProp c -> Prop c
+  | GType _ -> new_Type_sort ()
 
 let interp_elimination_sort = function
-  | RProp Null -> InProp
-  | RProp Pos  -> InSet
-  | RType _ -> InType
+  | GProp Null -> InProp
+  | GProp Pos  -> InSet
+  | GType _ -> InType
+
+let resolve_evars env evdref fail_evar resolve_classes =
+  if resolve_classes then
+    evdref := (Typeclasses.resolve_typeclasses ~onlyargs:false
+		 ~split:true ~fail:fail_evar env !evdref);
+  (* Resolve eagerly, potentially making wrong choices *)
+  evdref := (try consider_remaining_unif_problems
+	       ~ts:(Typeclasses.classes_transparent_state ()) env !evdref
+	     with e -> if fail_evar then raise e else !evdref)
+
+let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) =
+  let evdref = ref evd in
+  resolve_evars env evdref fail_evar use_classes;
+  let rec proc_rec c =
+    let c = Reductionops.whd_evar !evdref c in
+    match kind_of_term c with
+    | Evar (evk,args as ev) when not (Evd.mem initial_sigma evk) ->
+        let sigma = !evdref in
+	(try
+	   let c = hook env sigma ev in
+	   evdref := Evd.define evk c !evdref;
+	   c
+	 with Exit ->
+           if fail_evar then
+	     let evi = Evd.find_undefined sigma evk in
+             let (loc,src) = evar_source evk !evdref in
+	     Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
+           else
+             c)
+    | _ -> map_constr proc_rec c in
+  let c = proc_rec c in
+  (* Side-effect *)
+  !evdref,c
 
 module type S =
 sig
@@ -95,20 +143,20 @@ sig
   (* 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
+  (* Generic call to the interpreter from glob_constr to open_constr, leaving
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
 
   val understand_tcc : ?resolve_classes:bool ->
-    evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+    evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr
 
   val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
-    evar_map ref -> env -> typing_constraint -> rawconstr -> constr
+    evar_map ref -> env -> typing_constraint -> glob_constr -> 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.
+  (* Generic call to the interpreter from glob_constr to constr, failing
+     unresolved holes in the glob_constr cannot be instantiated.
 
      In [understand_ltac expand_evars sigma env ltac_env constraint c],
 
@@ -120,29 +168,29 @@ sig
 
   val understand_ltac :
     bool -> evar_map -> env -> ltac_var_map ->
-    typing_constraint -> rawconstr -> evar_map * constr
+    typing_constraint -> glob_constr -> pure_open_constr
 
-  (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+  (* Standard call to get a constr from a glob_constr, resolving implicit args *)
 
   val understand : evar_map -> env -> ?expected_type:Term.types ->
-    rawconstr -> constr
+    glob_constr -> constr
 
-  (* Idem but the rawconstr is intended to be a type *)
+  (* Idem but the glob_constr is intended to be a type *)
 
-  val understand_type : evar_map -> env -> rawconstr -> constr
+  val understand_type : evar_map -> env -> glob_constr -> constr
 
   (* A generalization of the two previous case *)
 
   val understand_gen : typing_constraint -> evar_map -> env ->
-    rawconstr -> constr
+    glob_constr -> constr
 
   (* Idem but returns the judgment of the understood term *)
 
-  val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+  val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment
 
   (* Idem but do not fail on unresolved evars *)
 
-  val understand_judgment_tcc : evar_map ref -> env -> rawconstr -> unsafe_judgment
+  val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment
 
   (*i*)
   (* Internal of Pretyping...
@@ -150,15 +198,15 @@ sig
    *)
   val pretype :
     type_constraint -> env -> evar_map ref ->
-    ltac_var_map -> rawconstr -> unsafe_judgment
+    ltac_var_map -> glob_constr -> unsafe_judgment
 
   val pretype_type :
     val_constraint -> env -> evar_map ref ->
-    ltac_var_map -> rawconstr -> unsafe_type_judgment
+    ltac_var_map -> glob_constr -> unsafe_type_judgment
 
   val pretype_gen :
     bool -> bool -> bool -> evar_map ref -> env ->
-    ltac_var_map -> typing_constraint -> rawconstr -> constr
+    ltac_var_map -> typing_constraint -> glob_constr -> constr
 
     (*i*)
 end
@@ -207,13 +255,6 @@ module Pretyping_F (Coercion : Coercion.S) = struct
               i lna vdefj lar
 	done
 
-  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 = !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 evdref j = function
     | None -> j
@@ -241,45 +282,33 @@ module Pretyping_F (Coercion : Coercion.S) = struct
       errorlabstrm "" (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.")
 
   let pretype_id loc env sigma (lvar,unbndltacvars) id =
+    (* Look for the binder of [id] *)
     try
       let (n,_,typ) = lookup_rel_id id (rel_context env) in
       { uj_val  = mkRel n; uj_type = lift n typ }
     with Not_found ->
+    (* Check if [id] is an ltac variable *)
     try
       let (ids,c) = List.assoc id lvar in
       let subst = List.map (invert_ltac_bound_name env id) ids in
       let c = substl subst c in
       { uj_val = c; uj_type = protected_get_type_of env sigma c }
     with Not_found ->
+    (* Check if [id] is a section or goal variable *)
     try
       let (_,_,typ) = lookup_named id env in
       { uj_val  = mkVar id; uj_type = typ }
     with Not_found ->
-    try (* To build a nicer ltac error message *)
+    (* [id] not found, build nice error message if [id] yet known from ltac *)
+    try
       match List.assoc id unbndltacvars with
       | None -> user_err_loc (loc,"",
 	  str "Variable " ++ pr_id id ++ str " should be bound to a term.")
       | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
     with Not_found ->
+    (* [id] not found, standard error message *)
       error_var_not_found_loc loc id
 
-  (* make a dependent predicate from an undependent one *)
-
-  let make_dep_of_undep env (IndType (indf,realargs)) pj =
-    let n = List.length realargs in
-    let rec decomp n p =
-      if n=0 then p else
-	match kind_of_term p with
-	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
-    in
-    let sign,s = decompose_prod_n n pj.uj_type in
-    let ind = build_dependent_inductive env indf in
-    let s' = mkProd (Anonymous, ind, s) in
-    let ccl = lift 1 (decomp n pj.uj_val) in
-    let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
-
   let evar_kind_of_term sigma c =
     kind_of_term (whd_evar sigma c)
 
@@ -290,27 +319,30 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
 
-  let pretype_sort = function
-    | RProp c -> judge_of_prop_contents c
-    | RType _ -> judge_of_new_Type ()
+  let pretype_sort evdref = function
+    | GProp c -> judge_of_prop_contents c
+    | GType _ -> evd_comb0 judge_of_new_Type evdref
 
   exception Found of fixpoint
 
+  let new_type_evar evdref env loc =
+    evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,InternalHole)) evdref
+
   (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
   (* in environment [env], with existential variables [evdref] and *)
   (* the type constraint tycon *)
   let rec pretype (tycon : type_constraint) env evdref lvar = function
-    | RRef (loc,ref) ->
+    | GRef (loc,ref) ->
 	inh_conv_coerce_to_tycon loc env evdref
 	  (pretype_ref evdref env ref)
 	  tycon
 
-    | RVar (loc, id) ->
+    | GVar (loc, id) ->
 	inh_conv_coerce_to_tycon loc env evdref
 	  (pretype_id loc env !evdref lvar id)
 	  tycon
 
-    | REvar (loc, evk, instopt) ->
+    | GEvar (loc, evk, instopt) ->
 	(* Ne faudrait-il pas s'assurer que hyps est bien un
 	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
 	let hyps = evar_filtered_context (Evd.find !evdref evk) in
@@ -321,24 +353,23 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	let j = (Retyping.get_judgment_of env !evdref c) in
 	  inh_conv_coerce_to_tycon loc env evdref j tycon
 
-    | RPatVar (loc,(someta,n)) ->
+    | GPatVar (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
+            | None | Some _ -> new_type_evar evdref env loc in
         let k = MatchingVar (someta,n) in
 	{ uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
 
-    | RHole (loc,k) ->
+    | GHole (loc,k) ->
 	let ty =
           match tycon with
             | Some (None, ty) -> ty
             | None | Some _ ->
-		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+		new_type_evar evdref env loc in
 	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
 
-    | RRec (loc,fixkind,names,bl,lar,vdef) ->
+    | GRec (loc,fixkind,names,bl,lar,vdef) ->
 	let rec type_bl env ctxt = function
             [] -> ctxt
           | (na,bk,None,ty)::bl ->
@@ -379,7 +410,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	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) ->
+	  | GFix (vn,i) ->
 	      (* First, let's find the guard indexes. *)
 	      (* If recursive argument was not given by user, we try all args.
 	         An earlier approach was to look only for inductive arguments,
@@ -395,22 +426,23 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	      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 ->
+	  | GCoFix i ->
 	      let cofix = (i,(names,ftys,fdefs)) in
-	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
+	      (try check_cofix env cofix with e -> Loc.raise loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
-    | RSort (loc,s) ->
-	inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon
+    | GSort (loc,s) ->
+	let j = pretype_sort evdref s in
+	  inh_conv_coerce_to_tycon loc env evdref j tycon
 
-    | RApp (loc,f,args) ->
+    | GApp (loc,f,args) ->
 	let fj = pretype empty_tycon env evdref lvar f in
- 	let floc = loc_of_rawconstr f in
+ 	let floc = loc_of_glob_constr f in
 	let rec apply_rec env n resj = function
 	  | [] -> resj
 	  | c::rest ->
-	      let argloc = loc_of_rawconstr c in
+	      let argloc = loc_of_glob_constr c 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
@@ -444,7 +476,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  | _ -> resj in
 	inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RLambda(loc,name,bk,c1,c2)      ->
+    | GLambda(loc,name,bk,c1,c2)      ->
 	let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon in
 	let dom_valcon = valcon_of_tycon dom in
 	let j = pretype_type dom_valcon env evdref lvar c1 in
@@ -452,7 +484,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	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)        ->
+    | GProd(loc,name,bk,c1,c2)        ->
 	let j = pretype_type empty_valcon env evdref lvar c1 in
 	let j' =
 	  if name = Anonymous then
@@ -465,13 +497,13 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	in
 	let resj =
 	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
+	  with TypeError _ as e -> Loc.raise loc e in
 	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
-    | RLetIn(loc,name,c1,c2)      ->
+    | GLetIn(loc,name,c1,c2)      ->
 	let j =
 	  match c1 with
-	  | RCast (loc, c, CastConv (DEFAULTcast, t)) ->
+	  | GCast (loc, c, CastConv (DEFAULTcast, t)) ->
 	      let tj = pretype_type empty_valcon env evdref lvar t in
 		pretype (mk_tycon tj.utj_val) env evdref lvar c
 	  | _ -> pretype empty_tycon env evdref lvar c1
@@ -483,12 +515,12 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  { 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) ->
+    | GLetTuple (loc,nal,(na,po),c,d) ->
 	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) =
 	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
+	    let cloc = loc_of_glob_constr c in
 	      error_case_not_inductive_loc cloc env !evdref cj
 	in
 	let cstrs = get_constructors env indf in
@@ -524,10 +556,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
 		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|]) in
-		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+		       let ind,_ = dest_ind_family indf in
+		       let ci = make_case_info env ind LetStyle in
+		       Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+		       mkCase (ci, p, cj.uj_val,[|f|]) in
+		     { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
 
 		 | None ->
 		     let tycon = lift_tycon cs.cs_nargs tycon in
@@ -543,18 +576,18 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		     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|] )
-		     in
-		       { uj_val = v; uj_type = ccl })
+		       let ind,_ = dest_ind_family indf in
+		       let ci = make_case_info env ind LetStyle in
+		       Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+		       mkCase (ci, p, cj.uj_val,[|f|])
+		     in { uj_val = v; uj_type = ccl })
 
-    | RIf (loc,c,(na,po),b1,b2) ->
+    | GIf (loc,c,(na,po),b1,b2) ->
 	let cj = pretype empty_tycon env evdref lvar c in
 	let (IndType (indf,realargs)) =
 	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
+	    let cloc = loc_of_glob_constr c in
 	      error_case_not_inductive_loc cloc env !evdref cj in
 	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 2 then
@@ -577,15 +610,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		let ccl = nf_evar !evdref pj.utj_val in
 		let pred = it_mkLambda_or_LetIn ccl psign in
 		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
-								     uj_type = typ} tycon
-		in
-		  jtyp.uj_val, jtyp.uj_type
+	        pred, typ
 	    | None ->
 		let p = match tycon with
 		  | Some (None, ty) -> ty
-		  | None | Some _ ->
-                      e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
+		  | None | Some _ -> new_type_evar evdref env loc
 		in
 		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
 	  let pred = nf_evar !evdref pred in
@@ -611,18 +640,20 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  let b1 = f cstrs.(0) b1 in
 	  let b2 = f cstrs.(1) b2 in
 	  let v =
-	    let mis,_ = dest_ind_family indf in
-	    let ci = make_case_info env mis IfStyle in
-	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+	    let ind,_ = dest_ind_family indf in
+	    let ci = make_case_info env ind IfStyle in
+	    let pred = nf_evar !evdref pred in
+	    Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
+	    mkCase (ci, pred, cj.uj_val, [|b1;b2|])
 	  in
 	    { uj_val = v; uj_type = p }
 
-    | RCases (loc,sty,po,tml,eqns) ->
+    | GCases (loc,sty,po,tml,eqns) ->
 	Cases.compile_cases loc sty
 	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
 	  tycon env (* loc *) (po,tml,eqns)
 
-    | RCast (loc,c,k) ->
+    | GCast (loc,c,k) ->
 	let cj =
 	  match k with
 	      CastCoerce ->
@@ -633,29 +664,24 @@ module Pretyping_F (Coercion : Coercion.S) = struct
  		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) ->
-		     (try ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
-                      with Reduction.NotConvertible ->
-                        error_actual_type_loc loc env !evdref cj tval)
-
+		  | VMcast ->
+                      if not (occur_existential cty || occur_existential tval) then
+		      begin 
+			try 
+			  ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
+			with Reduction.NotConvertible -> 
+			  error_actual_type_loc loc env !evdref cj tval 
+		      end
+                      else user_err_loc (loc,"",str "Cannot check cast with vm: unresolved arguments remain.")
 		  | _ -> inh_conv_coerce_to_tycon loc env evdref cj (mk_tycon tval)
 		in
 		let v = mkCast (cj.uj_val, k, tval) in
 		  { uj_val = v; uj_type = tval }
 	in inh_conv_coerce_to_tycon loc env evdref cj tycon
 
-    | RDynamic (loc,d) ->
-	if (Dyn.tag d) = "constr" then
-	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env !evdref c) in
-	    j
-	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
-	else
-	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic."))
-
   (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
   and pretype_type valcon env evdref lvar = function
-    | RHole loc ->
+    | GHole loc ->
 	(match valcon with
 	   | Some v ->
                let s =
@@ -670,12 +696,12 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		 { utj_val = v;
 		   utj_type = s }
 	   | None ->
-	       let s = new_Type_sort () in
+	       let s = evd_comb0 new_sort_variable evdref in
 		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
 		   utj_type = s})
     | c ->
 	let j = pretype empty_tycon env evdref lvar c in
-	let loc = loc_of_rawconstr c in
+	let loc = loc_of_glob_constr c in
 	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
 	  match valcon with
 	    | None -> tj
@@ -683,7 +709,7 @@ 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 !evdref tj.utj_val v
+                    (loc_of_glob_constr c) env !evdref tj.utj_val v
 
   let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
     let c' = match kind with
@@ -691,18 +717,12 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
 	  (pretype tycon env evdref lvar c).uj_val
       | IsType ->
-	  (pretype_type empty_valcon env evdref lvar c).utj_val in
-    if resolve_classes then (
-      evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
-	~split:true ~fail:fail_evar env !evdref);
-    evdref := (try consider_remaining_unif_problems env !evdref
-	       with e when not resolve_classes -> 
-		 consider_remaining_unif_problems env 
-		   (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
+	  (pretype_type empty_valcon env evdref lvar c).utj_val 
+    in
+      resolve_evars env evdref fail_evar resolve_classes;
+      let c = if expand_evar then nf_evar !evdref c' else c' in
+	if fail_evar then check_evars env Evd.empty !evdref c;
+	c
 
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
@@ -710,26 +730,24 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   *)
 
   let understand_judgment sigma env c =
-    let evdref = ref (create_evar_defs sigma) in
+    let evdref = ref sigma in
     let j = pretype empty_tycon env evdref ([],[]) c in
-    let evd = consider_remaining_unif_problems env !evdref 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
+      resolve_evars env evdref true true;
+      let j = j_nf_evar !evdref j in
+	check_evars env sigma !evdref (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+	j
 
   let understand_judgment_tcc evdref env c =
     let j = pretype empty_tycon env evdref ([],[]) c in
-    j_nf_evar !evdref j
+      resolve_evars env evdref false true;
+      j_nf_evar !evdref j
 
   (* Raw calls to the unsafe inference machine: boolean says if we must
      fail on unresolved evars; the unsafe_judgment list allows us to
      extend env with some bindings *)
 
   let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
-    let evdref = ref (Evd.create_evar_defs sigma) in
+    let evdref = ref sigma in
     let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
     !evdref, c
 
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index b94f9789..47b3ec87 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -1,24 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretyping.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** This file implements type inference. It maps [glob_constr]
+   (i.e. untyped terms whose names are located) to [constr]. In
+   particular, it drives complex pattern-matching problems ("match")
+   into elementary ones, insertion of coercions and resolution of
+   implicit arguments. *)
 
-(*i*)
 open Names
 open Sign
 open Term
 open Environ
 open Evd
-open Rawterm
+open Glob_term
 open Evarutil
-(*i*)
 
-(* An auxiliary function for searching for fixpoint guard indexes *)
+(** An auxiliary function for searching for fixpoint guard indexes *)
 
 val search_guard :
     Util.loc -> env -> int list list -> rec_declaration -> int array
@@ -28,30 +30,31 @@ type typing_constraint = OfType of types option | IsType
 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
+type glob_constr_ltac_closure = ltac_var_map * glob_constr
+type pure_open_constr = evar_map * constr
 
 module type S =
 sig
 
   module Cases : Cases.S
 
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+  (** 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
+  (** Generic call to the interpreter from glob_constr to open_constr, leaving
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
 
   val understand_tcc : ?resolve_classes:bool ->
-    evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+    evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr
 
   val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
-    evar_map ref -> env -> typing_constraint -> rawconstr -> constr
+    evar_map ref -> env -> typing_constraint -> glob_constr -> constr
 
-  (* More general entry point with evars from ltac *)
+  (** 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.
+  (** Generic call to the interpreter from glob_constr to constr, failing
+     unresolved holes in the glob_constr cannot be instantiated.
 
      In [understand_ltac expand_evars sigma env ltac_env constraint c],
 
@@ -63,56 +66,59 @@ sig
 
   val understand_ltac :
     bool -> evar_map -> env -> ltac_var_map ->
-    typing_constraint -> rawconstr -> evar_map * constr
+    typing_constraint -> glob_constr -> pure_open_constr
 
-  (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+  (** Standard call to get a constr from a glob_constr, resolving implicit args *)
 
   val understand : evar_map -> env -> ?expected_type:Term.types ->
-    rawconstr -> constr
+    glob_constr -> constr
 
-  (* Idem but the rawconstr is intended to be a type *)
+  (** Idem but the glob_constr is intended to be a type *)
 
-  val understand_type : evar_map -> env -> rawconstr -> constr
+  val understand_type : evar_map -> env -> glob_constr -> constr
 
-  (* A generalization of the two previous case *)
+  (** A generalization of the two previous case *)
 
   val understand_gen : typing_constraint -> evar_map -> env ->
-    rawconstr -> constr
+    glob_constr -> constr
 
-  (* Idem but returns the judgment of the understood term *)
+  (** Idem but returns the judgment of the understood term *)
 
-  val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+  val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment
 
-  (* Idem but do not fail on unresolved evars *)
-  val understand_judgment_tcc : evar_map ref -> env -> rawconstr -> unsafe_judgment
+  (** Idem but do not fail on unresolved evars *)
+  val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment
 
-  (*i*)
-  (* Internal of Pretyping...
-   *)
+  (**/**)
+  (** Internal of Pretyping... *)
   val pretype :
     type_constraint -> env -> evar_map ref ->
-    ltac_var_map -> rawconstr -> unsafe_judgment
+    ltac_var_map -> glob_constr -> unsafe_judgment
 
   val pretype_type :
     val_constraint -> env -> evar_map ref ->
-    ltac_var_map -> rawconstr -> unsafe_type_judgment
+    ltac_var_map -> glob_constr -> unsafe_type_judgment
 
   val pretype_gen :
     bool -> bool -> bool -> evar_map ref -> env ->
-    ltac_var_map -> typing_constraint -> rawconstr -> constr
+    ltac_var_map -> typing_constraint -> glob_constr -> constr
 
-  (*i*)
+  (**/**)
 
 end
 
 module Pretyping_F (C : Coercion.S) : S
 module Default : S
 
-(* To embed constr in rawconstr *)
+(** To embed constr in glob_constr *)
 
 val constr_in : constr -> Dyn.t
 val constr_out : Dyn.t -> constr
 
-val interp_sort : rawsort -> sorts
-val interp_elimination_sort : rawsort -> sorts_family
+val interp_sort : glob_sort -> sorts
+val interp_elimination_sort : glob_sort -> sorts_family
 
+(** Last chance for solving evars, possibly using external solver *)
+val solve_remaining_evars : bool -> bool ->
+  (env -> evar_map -> existential -> constr) ->
+  env -> evar_map -> pure_open_constr -> pure_open_constr
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index cea33c1e..9eec9414 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -11,8 +11,9 @@ Evarutil
 Term_dnet
 Recordops
 Evarconv
+Arguments_renaming
 Typing
-Rawterm
+Glob_term
 Pattern
 Matching
 Tacred
@@ -21,7 +22,6 @@ Typeclasses
 Classops
 Coercion
 Unification
-Clenv
 Detyping
 Indrec
 Cases
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
deleted file mode 100644
index 10156cec..00000000
--- a/pretyping/rawterm.mli
+++ /dev/null
@@ -1,167 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: rawterm.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
-open Util
-open Names
-open Sign
-open Term
-open Libnames
-open Nametab
-(*i*)
-
-(**********************************************************************)
-(* The kind of patterns that occurs in "match ... with ... end"       *)
-
-(* locs here refers to the ident's location, not whole pat *)
-(* the last argument of PatCstr is a possible alias ident for the pattern *)
-type cases_pattern =
-  | PatVar of loc * name
-  | PatCstr of loc * constructor * cases_pattern list * name
-
-val cases_pattern_loc : cases_pattern -> loc
-
-(**********************************************************************)
-(* Untyped intermediate terms, after constr_expr and before constr    *)
-(* Resolution of names, insertion of implicit arguments placeholder,  *)
-(* and notations are done, but coercions, inference of implicit       *)
-(* arguments and pattern-matching compilation are not                 *)
-
-type patvar = identifier
-
-type rawsort = RProp of Term.contents | RType of Univ.universe option
-
-type binding_kind = Lib.binding_kind = Explicit | Implicit
-
-type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
-
-type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
-
-type 'a bindings =
-  | ImplicitBindings of 'a list
-  | ExplicitBindings of 'a explicit_bindings
-  | NoBindings
-
-type 'a with_bindings = 'a * 'a bindings
-
-type 'a cast_type =
-  | CastConv of cast_kind * 'a
-  | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
-
-type rawconstr =
-  | RRef of (loc * global_reference)
-  | RVar of (loc * identifier)
-  | REvar of loc * existential_key * rawconstr list option
-  | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
-  | RApp of loc * rawconstr * rawconstr list
-  | RLambda of loc * name * binding_kind *  rawconstr * 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) *
-      rawconstr * rawconstr
-  | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
-  | RRec of loc * fix_kind * identifier array * rawdecl list array *
-      rawconstr array * rawconstr array
-  | RSort of loc * rawsort
-  | RHole of (loc * Evd.hole_kind)
-  | RCast of loc * rawconstr * rawconstr cast_type
-  | RDynamic of loc * Dyn.t
-
-and rawdecl = name * binding_kind * rawconstr option * 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)
-  | RCoFix of int
-
-and predicate_pattern =
-    name * (loc * inductive * int * name list) option
-
-and tomatch_tuple = (rawconstr * predicate_pattern)
-
-and tomatch_tuples = tomatch_tuple list
-
-and cases_clause = (loc * identifier list * cases_pattern list * rawconstr)
-
-and cases_clauses = cases_clause list
-
-val cases_predicate_names : tomatch_tuples -> name list
-
-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 ->
-  (identifier -> 'a -> identifier * 'a) ->
-  ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr
-i*)
-
-val fold_rawconstr : ('a -> rawconstr -> 'a) -> 'a -> rawconstr -> 'a
-val iter_rawconstr : (rawconstr -> unit) -> rawconstr -> unit
-val occur_rawconstr : identifier -> rawconstr -> bool
-val free_rawvars : rawconstr -> identifier list
-val loc_of_rawconstr : rawconstr -> loc
-
-(**********************************************************************)
-(* Conversion from rawconstr to cases pattern, if possible            *)
-
-(* Take the current alias as parameter, raise Not_found if *)
-(* translation is impossible *)
-
-val cases_pattern_of_rawconstr : name -> rawconstr -> cases_pattern
-
-val rawconstr_of_closed_cases_pattern : cases_pattern -> name * rawconstr
-
-(**********************************************************************)
-(* Reduction expressions                                              *)
-
-type 'a raw_red_flag = {
-  rBeta : bool;
-  rIota : bool;
-  rZeta : bool;
-  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
-  rConst : 'a list
-}
-
-val all_flags : 'a raw_red_flag
-
-type 'a or_var = ArgArg of 'a | ArgVar of identifier located
-
-type occurrences_expr = bool * int or_var list
-
-val all_occurrences_expr_but : int or_var list -> occurrences_expr
-val no_occurrences_expr_but : int or_var list -> occurrences_expr
-val all_occurrences_expr : occurrences_expr
-val no_occurrences_expr : occurrences_expr
-
-type 'a with_occurrences = occurrences_expr * 'a
-
-type ('a,'b,'c) red_expr_gen =
-  | Red of bool
-  | Hnf
-  | Simpl of 'c with_occurrences option
-  | Cbv of 'b raw_red_flag
-  | Lazy of 'b raw_red_flag
-  | Unfold of 'b with_occurrences list
-  | Fold of 'a list
-  | Pattern of 'a with_occurrences list
-  | ExtraRedExpr of string
-  | CbvVm
-
-type ('a,'b,'c) may_eval =
-  | ConstrTerm of 'a
-  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
-  | ConstrContext of (loc * identifier) * 'a
-  | ConstrTypeOf of 'a
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index e8c6073e..b3be7afd 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -1,12 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: recordops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Amokrane Saïbi, Dec 1998 *)
+(* Addition of products and sorts in canonical structures by Pierre
+   Corbineau, Feb 2008 *)
+
+(* This file registers properties of records: projections and
+   canonical structures *)
 
 open Util
 open Pp
@@ -14,7 +19,6 @@ open Names
 open Libnames
 open Nametab
 open Term
-open Termops
 open Typeops
 open Libobject
 open Library
@@ -39,6 +43,12 @@ type struc_typ = {
 let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
 let projection_table = ref Cmap.empty
 
+(* TODO: could be unify struc_typ and struc_tuple ? in particular,
+   is the inductive always (fst constructor) ? It seems so... *)
+
+type struc_tuple =
+    inductive * constructor * (name * bool) list * constant option list
+
 let load_structure i (_,(ind,id,kl,projs)) =
   let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
   let struc =
@@ -71,7 +81,7 @@ let discharge_structure (_,(ind,id,kl,projs)) =
   Some (Lib.discharge_inductive ind, discharge_constructor id, kl,
         List.map (Option.map Lib.discharge_con) projs)
 
-let (inStruc,outStruc) =
+let inStruc : struc_tuple -> obj =
   declare_object {(default_object "STRUCTURE") with
     cache_function = cache_structure;
     load_function = load_structure;
@@ -130,7 +140,7 @@ open Libobject
 let load_method (_,(ty,id)) =
   meth_dnet := MethodsDnet.add ty id !meth_dnet
 
-let (in_method,out_method) =
+let in_method : constr * MethodsDnet.ident -> obj =
   declare_object
     { (default_object "RECMETHODS") with
 	load_function = (fun _ -> load_method);
@@ -201,7 +211,7 @@ let cs_pattern_of_constr t =
 	      _ -> 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]
+    | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, -1, [a; Termops.pop b]
     | Sort s -> Sort_cs (family_of_sort s), -1, []
     | _ ->
 	begin
@@ -235,7 +245,7 @@ let compute_canonical_projections (con,ind) =
                      (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 "  
+                                   ++ Termops.print_constr t ++ str " in instance "  
                                    ++ con_pp ++ str " of " ++ proji_sp_pp ++ str ", ignoring it."));
 		   l
 	       end
@@ -285,7 +295,7 @@ let subst_canonical_structure (subst,(cst,ind as obj)) =
 let discharge_canonical_structure (_,(cst,ind)) =
   Some (Lib.discharge_con cst,Lib.discharge_inductive ind)
 
-let (inCanonStruc,outCanonStruct) =
+let inCanonStruc : constant * inductive -> obj =
   declare_object {(default_object "CANONICAL-STRUCTURE") with
     open_function = open_canonical_structure;
     cache_function = cache_canonical_structure;
@@ -323,16 +333,17 @@ let check_and_decompose_canonical_structure ref =
 let declare_canonical_structure ref =
   add_canonical_structure (check_and_decompose_canonical_structure ref)
 
-let outCanonicalStructure x = fst (outCanonStruct x)
-
 let lookup_canonical_conversion (proj,pat) =
   List.assoc pat (Refmap.find proj !object_table)
 
-let is_open_canonical_projection sigma (c,args) =
+let is_open_canonical_projection env sigma (c,args) =
   try
-    let l = Refmap.find (global_of_constr c) !object_table in
-    let n = (snd (List.hd l)).o_NPARAMS in
-    try isEvar_or_Meta (whd_evar sigma (List.nth args n)) with Failure _ -> false
+    let n = find_projection_nparams (global_of_constr c) in
+    try
+      let arg = whd_betadeltaiota env sigma (List.nth args n) in
+      let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in
+      not (isConstruct hd) 
+    with Failure _ -> false
   with Not_found -> false
 
 let freeze () =
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index b71c4969..6165fac2 100644
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -1,23 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: recordops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Nametab
 open Term
 open Libnames
 open Libobject
 open Library
-(*i*)
 
-(*s A structure S is a non recursive inductive type with a single
+(** Operations concerning records and canonical structures *)
+
+(** {6 Records } *)
+(** A structure S is a non recursive inductive type with a single
    constructor (the name of which defaults to Build_S) *)
 
 type struc_typ = {
@@ -26,37 +25,40 @@ type struc_typ = {
   s_PROJKIND : (name * bool) list;
   s_PROJ : constant option list }
 
-val declare_structure :
-  inductive * constructor * (name * bool) list * constant option list -> unit
+type struc_tuple =
+    inductive * constructor * (name * bool) list * constant option list
+
+val declare_structure : struc_tuple -> unit
 
-(* [lookup_structure isp] returns the struc_typ associated to the
+(** [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
+(** [lookup_projections isp] returns the projections associated to the
    inductive path [isp] if it corresponds to a structure, otherwise
    it fails with [Not_found] *)
 val lookup_projections : inductive -> constant option list
 
-(* raise [Not_found] if not a projection *)
+(** raise [Not_found] if not a projection *)
 val find_projection_nparams : global_reference -> int
 
-(* raise [Not_found] if not a projection *)
+(** raise [Not_found] if not a projection *)
 val find_projection : global_reference -> struc_typ
 
-(* we keep an index (dnet) of record's arguments + fields
+(** 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: *)
+  (** 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 *)
+(** {6 Canonical structures } *)
+(** 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
@@ -66,11 +68,11 @@ type cs_pattern =
 
 type obj_typ = {
   o_DEF : constr;
-  o_INJ : int;      (* position of trivial argument *)
-  o_TABS : constr list;    (* ordered *)
-  o_TPARAMS : constr list; (* ordered *)
+  o_INJ : int;      (** position of trivial argument *)
+  o_TABS : constr list;    (** ordered *)
+  o_TPARAMS : constr list; (** ordered *)
   o_NPARAMS : int;
-  o_TCOMPS : constr list } (* ordered *)
+  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
@@ -78,6 +80,6 @@ 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
+  Environ.env -> Evd.evar_map -> (constr * constr list) -> bool
 val canonical_projections : unit ->
   ((global_reference * cs_pattern) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 5af20551..e8acd67c 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reductionops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -44,13 +42,6 @@ let append_stack_list l s =
   | (l1, s) -> Zapp l1 :: s
 let append_stack v s = append_stack_list (Array.to_list v) s
 
-(* Collapse the shifts in the stack *)
-let zshift n s =
-  match (n,s) with
-      (0,_) -> s
-    | (_,Zshift(k)::s) -> Zshift(n+k)::s
-    | _ -> Zshift(n)::s
-
 let rec stack_args_size = function
   | Zapp l::s -> List.length l + stack_args_size s
   | Zshift(_)::s -> stack_args_size s
@@ -63,10 +54,6 @@ let rec decomp_stack = function
   | Zapp(v::l)::s -> Some (v, (Zapp l :: s))
   | Zapp [] :: s -> decomp_stack s
   | _ -> None
-let rec decomp_stackn = function
-  | Zapp [] :: s -> decomp_stackn s
-  | Zapp l :: s -> (Array.of_list l, s)
-  | _ -> assert false
 let array_of_stack s =
   let rec stackrec = function
   | [] -> []
@@ -155,10 +142,6 @@ let whd_stack sigma x =
   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 rec strongrec env t =
     map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in
@@ -309,7 +292,7 @@ let reduce_fix whdfun sigma fix stack =
                               -------------------
    qui coute cher *)
 
-let rec whd_state_gen flags env sigma =
+let rec whd_state_gen flags ts env sigma =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | Rel n when red_delta flags ->
@@ -328,7 +311,7 @@ let rec whd_state_gen flags env sigma =
 	  (match safe_meta_value sigma ev with
 	     | Some body -> whrec (body, stack)
 	     | None -> s)
-      | Const const when red_delta flags ->
+      | Const const when is_transparent_constant ts const ->
 	  (match constant_opt_value env const with
 	     | Some  body -> whrec (body, stack)
 	     | None -> s)
@@ -340,7 +323,7 @@ let rec whd_state_gen flags env sigma =
              | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
              | None when red_eta flags ->
 		 let env' = push_rel (na,None,t) env in
-		 let whrec' = whd_state_gen flags env' sigma in
+		 let whrec' = whd_state_gen flags ts env' sigma in
                  (match kind_of_term (app_stack (whrec' (c, empty_stack))) with
                     | App (f,cl) ->
 			let napp = Array.length cl in
@@ -451,18 +434,19 @@ let whd_betalet = red_of_state_red whd_betalet_state
 
 (* 2. Delta Reduction Functions *)
 
-let whd_delta_state e = whd_state_gen delta e
+let whd_delta_state e = whd_state_gen delta full_transparent_state e
 let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env)
 let whd_delta env = red_of_state_red  (whd_delta_state env)
 
-let whd_betadelta_state e = whd_state_gen betadelta e
+let whd_betadelta_state e = whd_state_gen betadelta full_transparent_state e
 let whd_betadelta_stack env =
   stack_red_of_state_red (whd_betadelta_state env)
 let whd_betadelta env =
   red_of_state_red (whd_betadelta_state env)
 
 
-let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e
+let whd_betadeltaeta_state e =
+  whd_state_gen betadeltaeta full_transparent_state e
 let whd_betadeltaeta_stack env =
   stack_red_of_state_red (whd_betadeltaeta_state env)
 let whd_betadeltaeta env =
@@ -478,19 +462,29 @@ let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
 let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state
 let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state
 
-let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e
+let whd_betadeltaiota_state env =
+  whd_state_gen betadeltaiota full_transparent_state env
 let whd_betadeltaiota_stack env =
   stack_red_of_state_red (whd_betadeltaiota_state env)
 let whd_betadeltaiota env =
   red_of_state_red (whd_betadeltaiota_state env)
 
-let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e
+let whd_betadeltaiota_state_using ts env =
+  whd_state_gen betadeltaiota ts env
+let whd_betadeltaiota_stack_using ts env =
+  stack_red_of_state_red (whd_betadeltaiota_state_using ts env)
+let whd_betadeltaiota_using ts env =
+  red_of_state_red (whd_betadeltaiota_state_using ts env)
+
+let whd_betadeltaiotaeta_state env =
+  whd_state_gen betadeltaiotaeta full_transparent_state env
 let whd_betadeltaiotaeta_stack env =
   stack_red_of_state_red (whd_betadeltaiotaeta_state env)
 let whd_betadeltaiotaeta env =
   red_of_state_red (whd_betadeltaiotaeta_state env)
 
-let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e
+let whd_betadeltaiota_nolet_state env =
+  whd_state_gen betadeltaiota_nolet full_transparent_state env
 let whd_betadeltaiota_nolet_stack env =
   stack_red_of_state_red (whd_betadeltaiota_nolet_state env)
 let whd_betadeltaiota_nolet env =
@@ -586,14 +580,6 @@ let rec whd_betaiota_preserving_vm_cast env sigma t =
 let nf_betaiota_preserving_vm_cast =
   strong whd_betaiota_preserving_vm_cast
 
-(* lazy weak head reduction functions *)
-let whd_flags flgs env sigma t =
-  try
-    whd_val
-      (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
-      (inject t)
-  with Anomaly _ -> error "Tried to normalized ill-typed term" 
-
 (********************************************************************)
 (*                         Conversion                               *)
 (********************************************************************)
@@ -620,7 +606,7 @@ let pb_equal = function
 
 let sort_cmp = sort_cmp
 
-let test_conversion (f:?evars:'a->'b) env sigma x y =
+let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y =
   try let _ =
     f ~evars:(safe_evar_value sigma) env x y in true
   with NotConvertible -> false
@@ -630,8 +616,8 @@ let is_conv env sigma = test_conversion Reduction.conv env sigma
 let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
 let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
 
-let test_trans_conversion f reds env sigma x y =
-  try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true
+let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
+  try let _ = f ~evars:(safe_evar_value sigma) reds env x y in true
   with NotConvertible -> false
     | Anomaly _ -> error "Conversion test raised an anomaly"
 
@@ -784,7 +770,7 @@ let splay_arity env sigma c =
     | Sort s -> l,s
     | _ -> invalid_arg "splay_arity"
 
-let sort_of_arity env c = snd (splay_arity env Evd.empty c)
+let sort_of_arity env sigma c = snd (splay_arity env sigma c)
 
 let splay_prod_n env sigma n =
   let rec decrec env m ln c = if m = 0 then (ln,c) else
@@ -820,19 +806,21 @@ let is_sort env sigma arity =
 (* 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 whd_betaiota_deltazeta_for_iota_state ts env sigma s =
   let rec whrec s =
     let (t, stack as s) = whd_betaiota_state sigma s in
     match kind_of_term t with
     | Case (ci,p,d,lf) ->
-        let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
+        let (cr,crargs) = whd_betadeltaiota_stack_using ts env sigma d in
         let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
         if reducible_mind_case cr then
 	  whrec (rslt, stack)
         else
 	  s
     | Fix fix ->
-	  (match reduce_fix (whd_betadeltaiota_state env) sigma fix stack with
+	  (match
+              reduce_fix (whd_betadeltaiota_state_using ts env) sigma fix stack
+           with
              | Reduced s -> whrec s
 	     | NotReducible -> s)
     | _ -> s
@@ -926,17 +914,6 @@ let nf_meta sigma c = meta_instance sigma (mk_freelisted c)
 
 (* Instantiate metas that create beta/iota redexes *)
 
-let meta_value evd mv =
-  let rec valrec mv =
-    match meta_opt_fvalue evd mv with
-    | Some (b,_) ->
-      instance evd
-        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
-        b.rebus
-    | None -> mkMeta mv
-  in
-  valrec mv
-
 let meta_reducible_instance evd b =
   let fm = Metaset.elements b.freemetas in
   let metas = List.fold_left (fun l mv ->
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 95032bde..3ffc587e 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -1,28 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reductionops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Univ
 open Evd
 open Environ
 open Closure
-(*i*)
 
-(* Reduction Functions. *)
+(** Reduction Functions. *)
 
 exception Elimconst
 
-(************************************************************************)
-(*s A [stack] is a context of arguments, arguments are pushed by
+(***********************************************************************
+  s A [stack] is a context of arguments, arguments are pushed by
    [append_stack] one array at a time but popped with [decomp_stack]
    one by one *)
 
@@ -67,13 +63,13 @@ type contextual_state_reduction_function =
 type state_reduction_function = contextual_state_reduction_function
 type local_state_reduction_function = evar_map -> state -> state
 
-(* Removes cast and put into applicative form *)
+(** Removes cast and put into applicative form *)
 val whd_stack : local_stack_reduction_function
 
-(* For compatibility: alias for whd\_stack *)
+(** For compatibility: alias for whd\_stack *)
 val whd_castapp_stack : local_stack_reduction_function
 
-(*s Reduction Function Operators *)
+(** {6 Reduction Function Operators } *)
 
 val strong : reduction_function -> reduction_function
 val local_strong : local_reduction_function -> local_reduction_function
@@ -84,17 +80,19 @@ val stack_reduction_of_reduction :
 i*)
 val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a
 
-(*s Generic Optimized Reduction Function using Closures *)
+(** {6 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
 val nf_evar : evar_map -> constr -> constr
 
 val nf_betaiota_preserving_vm_cast : reduction_function
-(* Lazy strategy, weak head reduction *)
+
+(** Lazy strategy, weak head reduction *)
 val whd_evar :  evar_map -> constr -> constr
 val whd_beta : local_reduction_function
 val whd_betaiota : local_reduction_function
@@ -120,7 +118,7 @@ val whd_betadeltaiota_nolet_state : contextual_state_reduction_function
 val whd_betaetalet_state : local_state_reduction_function
 val whd_betalet_state : local_state_reduction_function
 
-(*s Head normal forms *)
+(** {6 Head normal forms } *)
 
 val whd_delta_stack :  stack_reduction_function
 val whd_delta_state :  state_reduction_function
@@ -138,7 +136,7 @@ val whd_betadeltaiotaeta :  reduction_function
 val whd_eta : constr -> constr
 val whd_zeta : constr -> constr
 
-(* Various reduction functions *)
+(** Various reduction functions *)
 
 val safe_evar_value : evar_map -> existential -> constr option
 
@@ -154,7 +152,7 @@ val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
 val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_lam : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
-val sort_of_arity : env -> constr -> sorts
+val sort_of_arity : env -> evar_map -> constr -> sorts
 val splay_prod_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_lam_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_prod_assum :
@@ -163,11 +161,11 @@ val decomp_sort : env -> evar_map -> types -> sorts
 val is_sort : env -> evar_map -> types -> bool
 
 type 'a miota_args = {
-  mP      : constr;     (* the result type *)
-  mconstr : constr;     (* the constructor *)
-  mci     : case_info;  (* special info to re-build pattern *)
-  mcargs  : 'a list;    (* the constructor's arguments *)
-  mlf     : 'a array }  (* the branch code vector *)
+  mP      : constr;     (** the result type *)
+  mconstr : constr;     (** the constructor *)
+  mci     : case_info;  (** special info to re-build pattern *)
+  mcargs  : 'a list;    (** the constructor's arguments *)
+  mlf     : 'a array }  (** the branch code vector *)
 
 val reducible_mind_case : constr -> bool
 val reduce_mind_case : constr miota_args -> constr
@@ -177,7 +175,7 @@ val is_arity : env ->  evar_map -> constr -> bool
 
 val whd_programs :  reduction_function
 
-(* [reduce_fix redfun fix stk] contracts [fix stk] if it is actually
+(** [reduce_fix redfun fix stk] contracts [fix stk] if it is actually
    reducible; the structural argument is reduced by [redfun] *)
 
 type fix_reduction_result = NotReducible | Reduced of state
@@ -186,10 +184,10 @@ val fix_recarg : fixpoint -> constr stack -> (int * constr) option
 val reduce_fix : local_state_reduction_function -> evar_map -> fixpoint
    -> constr stack -> fix_reduction_result
 
-(*s Querying the kernel conversion oracle: opaque/transparent constants *)
+(** {6 Querying the kernel conversion oracle: opaque/transparent constants } *)
 val is_transparent : 'a tableKey -> bool
 
-(*s Conversion Functions (uses closures, lazy strategy) *)
+(** {6 Conversion Functions (uses closures, lazy strategy) } *)
 
 type conversion_test = constraints -> constraints
 
@@ -206,18 +204,19 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr ->
 val is_trans_conv_leq : transparent_state -> env ->  evar_map -> constr -> constr -> bool
 val is_trans_fconv : conv_pb -> transparent_state -> env ->  evar_map -> constr -> constr -> bool
 
-(*s Special-Purpose Reduction Functions *)
+(** {6 Special-Purpose Reduction Functions } *)
 
 val whd_meta : evar_map -> constr -> constr
 val plain_instance : (metavariable * constr) list -> constr -> constr
 val instance :evar_map -> (metavariable * constr) list -> constr -> constr
 val head_unfold_under_prod : transparent_state -> reduction_function
 
-(*s Heuristic for Conversion with Evar *)
+(** {6 Heuristic for Conversion with Evar } *)
 
-val whd_betaiota_deltazeta_for_iota_state :  state_reduction_function
+val whd_betaiota_deltazeta_for_iota_state :
+  transparent_state -> state_reduction_function
 
-(*s Meta-related reduction functions *)
+(** {6 Meta-related reduction functions } *)
 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 7fb4f7ba..502e238b 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Term
 open Inductive
@@ -48,8 +46,8 @@ let retype ?(polyprop=true) sigma =
   let rec type_of env cstr=
     match kind_of_term cstr with
     | Meta n ->
-          (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
-           with Not_found -> anomaly ("type_of: unknown meta " ^ string_of_int n))
+      (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
         lift n ty
@@ -129,10 +127,13 @@ let retype ?(polyprop=true) sigma =
     match kind_of_term c with
     | Ind ind ->
       let (_,mip) = lookup_mind_specif env ind in
-      Inductive.type_of_inductive_knowing_parameters ~polyprop env mip argtyps
+	(try Inductive.type_of_inductive_knowing_parameters
+	       ~polyprop env mip argtyps
+	 with Reduction.NotArity -> anomaly "type_of: Not an arity")
     | Const cst ->
       let t = constant_type env cst in
-      Typeops.type_of_constant_knowing_parameters env t argtyps
+	(try Typeops.type_of_constant_knowing_parameters env t argtyps
+	 with Reduction.NotArity -> anomaly "type_of: Not an arity")
     | Var id -> type_of_var env id
     | Construct cstr -> type_of_constructor env cstr
     | _ -> assert false
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index f2c030f9..445f623a 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retyping.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Evd
 open Environ
-(*i*)
 
-(* This family of functions assumes its constr argument is known to be
+(** This family of functions assumes its constr argument is known to be
    well-typable. It does not type-check, just recompute the type
    without any costly verifications. On non well-typable terms, it
    either produces a wrong result or raise an anomaly. Use with care.
@@ -33,10 +29,10 @@ val get_sort_of :
 val get_sort_family_of :
   ?polyprop:bool -> env -> evar_map -> types -> sorts_family
 
-(* Makes an assumption from a constr *)
+(** Makes an assumption from a constr *)
 val get_assumption_of : env -> evar_map -> constr -> types
 
-(* Makes an unsafe judgment from a constr *)
+(** 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 ->
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index bd1eed94..fc35e2d3 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacred.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -18,11 +16,12 @@ open Termops
 open Namegen
 open Declarations
 open Inductive
+open Libobject
 open Environ
 open Closure
 open Reductionops
 open Cbv
-open Rawterm
+open Glob_term
 open Pattern
 open Matching
 
@@ -300,17 +299,6 @@ let reference_eval sigma env = function
        end)
   | ref -> compute_consteval sigma env ref
 
-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
-  rfprec fn []
-
 (* If f is bound to EliminationFix (n',infos), then n' is the minimal
    number of args for starting the reduction and infos is
    (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts
@@ -528,27 +516,127 @@ let special_red_case env sigma whfun (ci, p, c, lf)  =
   in
   redrec (c, empty_stack)
 
+(* data structure to hold the map kn -> rec_args for simpl *)
+
+type behaviour = {
+  b_nargs: int;
+  b_recargs: int list;
+  b_dont_expose_case: bool;
+}
+
+let behaviour_table = ref (Refmap.empty : behaviour Refmap.t)
+
+let _ =
+  Summary.declare_summary "simplbehaviour"
+    { Summary.freeze_function = (fun () -> !behaviour_table);
+      Summary.unfreeze_function = (fun x -> behaviour_table := x);
+      Summary.init_function = (fun () -> behaviour_table := Refmap.empty) }
+
+type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ]
+type req =
+  | ReqLocal
+  | ReqGlobal of global_reference * (int list * int * simpl_flag list)
+
+let load_simpl_behaviour _ (_,(_,(r, b))) =
+  behaviour_table := Refmap.add r b !behaviour_table
+
+let cache_simpl_behaviour o = load_simpl_behaviour 1 o
+
+let classify_simpl_behaviour = function
+  | ReqLocal, _ -> Dispose
+  | ReqGlobal _, _ as o -> Substitute o
+
+let subst_simpl_behaviour (subst, (_, (r,o as orig))) =
+  ReqLocal,
+  let r' = fst (subst_global subst r) in if r==r' then orig else (r',o)
+
+let discharge_simpl_behaviour = function
+  | _,(ReqGlobal (ConstRef c, req), (_, b)) ->
+     let c' = pop_con c in
+     let vars = Lib.section_segment_of_constant c in
+     let extra = List.length vars in
+     let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in
+     let recargs' = List.map ((+) extra) b.b_recargs in
+     let b' = { b with b_nargs = nargs'; b_recargs = recargs' } in
+     Some (ReqGlobal (ConstRef c', req), (ConstRef c', b'))
+  | _ -> None
+
+let rebuild_simpl_behaviour = function
+  | req, (ConstRef c, _ as x) -> req, x
+  | _ -> assert false
+
+let inSimplBehaviour = declare_object { (default_object "SIMPLBEHAVIOUR") with
+  load_function = load_simpl_behaviour;
+  cache_function = cache_simpl_behaviour;
+  classify_function = classify_simpl_behaviour;
+  subst_function = subst_simpl_behaviour;
+  discharge_function = discharge_simpl_behaviour;
+  rebuild_function = rebuild_simpl_behaviour;
+}
+
+let set_simpl_behaviour local r (recargs, nargs, flags as req) =
+  let nargs = if List.mem `SimplNeverUnfold flags then max_int else nargs in
+  let nargs = List.fold_left max nargs recargs in
+  let behaviour = {
+    b_nargs = nargs; b_recargs = recargs;
+    b_dont_expose_case = List.mem `SimplDontExposeCase flags } in
+  let req = if local then ReqLocal else ReqGlobal (r, req) in
+  Lib.add_anonymous_leaf (inSimplBehaviour (req, (r, behaviour)))
+;;
+
+let get_simpl_behaviour r =
+  try
+    let b = Refmap.find r !behaviour_table in
+    let flags =
+      if b.b_nargs = max_int then [`SimplNeverUnfold]
+      else if b.b_dont_expose_case then [`SimplDontExposeCase] else [] in
+    Some (b.b_recargs, (if b.b_nargs = max_int then -1 else b.b_nargs), flags)
+  with Not_found -> None
+
+let get_behaviour = function
+  | EvalVar _ | EvalRel _ | EvalEvar _ -> raise Not_found
+  | EvalConst c -> Refmap.find (ConstRef c) !behaviour_table
+
+let recargs r =
+  try let b = get_behaviour r in Some (b.b_recargs, b.b_nargs)
+  with Not_found -> None
+
+let dont_expose_case r =
+  try (get_behaviour r).b_dont_expose_case with Not_found -> false
+
 (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind
    constants by keeping the name of the constants in the recursive calls;
    it fails if no redex is around *)
 
 let rec red_elim_const env sigma ref largs =
-  match reference_eval sigma env ref with
-    | EliminationCases n when stack_args_size largs >= n ->
+  let nargs = stack_args_size largs in
+  let largs, unfold_anyway =
+    match recargs ref with
+    | None -> largs, false
+    | Some (_,n) when nargs < n -> raise Redelimination
+    | Some (l,n) ->
+        List.fold_left (fun stack i ->
+          let arg = stack_nth stack i in
+          let rarg = whd_construct_state env sigma (arg, empty_stack) in
+          match kind_of_term (fst rarg) with
+          | Construct _ -> stack_assign stack i (app_stack rarg)
+          | _ -> raise Redelimination)
+        largs l, n >= 0 && l = [] && nargs >= n in
+  try match reference_eval sigma env ref with
+    | EliminationCases n when nargs >= n ->
 	let c = reference_value sigma env ref in
 	let c', lrest = whd_betadelta_state env sigma (c,largs) in
 	let whfun = whd_simpl_state env sigma in
         (special_red_case env sigma whfun (destCase c'), lrest)
-    | EliminationFix (min,minfxargs,infos) when stack_args_size largs >=min ->
+    | EliminationFix (min,minfxargs,infos) when nargs >= min ->
 	let c = reference_value sigma env ref in
 	let d, lrest = whd_betadelta_state env sigma (c,largs) in
 	let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in
 	let whfun = whd_construct_state env sigma in
 	(match reduce_fix_use_function env sigma f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
-	   | Reduced (c,rest) -> (nf_beta sigma c, rest))
-    | EliminationMutualFix (min,refgoal,refinfos)
-	when stack_args_size largs >= min ->
+           | Reduced (c,rest) -> (nf_beta sigma c, rest))
+    | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min ->
 	let rec descend ref args =
 	  let c = reference_value sigma env ref in
 	  if ref = refgoal then
@@ -564,6 +652,9 @@ let rec red_elim_const env sigma ref largs =
 	   | NotReducible -> raise Redelimination
 	   | Reduced (c,rest) -> (nf_beta sigma c, rest))
     | _ -> raise Redelimination
+    with Redelimination when unfold_anyway ->
+       let c = reference_value sigma env ref in
+       whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack
 
 (* reduce to whd normal form or to an applied constant that does not hide
    a reducible iota/fix/cofix redex (the "simpl" tactic) *)
@@ -591,7 +682,14 @@ and whd_simpl_state env sigma s =
       | _ when isEvalRef env x ->
 	  let ref = destEvalRef x in
           (try
-	    redrec (red_elim_const env sigma ref stack)
+            let hd, _ as s' = redrec (red_elim_const env sigma ref stack) in
+            let rec is_case x = match kind_of_term x with
+              | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x
+              | App (hd, _) -> is_case hd
+              | Case _ -> true
+              | _ -> false in
+            if dont_expose_case ref && is_case hd then raise Redelimination
+            else s'
            with Redelimination ->
 	     s)
       | _ -> s
@@ -698,7 +796,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 ((strip_lam c)) with
+		   (match kind_of_term (strip_lam c) with
                      | CoFix _ | Fix _ -> s
 		     | _ -> redrec (c, stack))
 	       | None -> s)
@@ -708,7 +806,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
 
 (* Same as [whd_simpl] but also reduces constants that do not hide a
    reducible fix, but does this reduction of constants only until it
-   it immediately hides a non reducible fix or a cofix *)
+   immediately hides a non reducible fix or a cofix *)
 
 let whd_simpl_orelse_delta_but_fix env sigma c =
   let rec redrec s =
@@ -716,7 +814,7 @@ let whd_simpl_orelse_delta_but_fix env sigma c =
     if isEvalRef env constr then
       match reference_opt_value sigma env (destEvalRef constr) with
 	| Some c ->
-	    (match kind_of_term ((strip_lam c)) with
+	    (match kind_of_term (strip_lam c) with
               | CoFix _ | Fix _ -> s'
 	      | _ -> redrec (c, stack))
 	| None -> s'
@@ -780,7 +878,7 @@ let substlin env evalref n (nowhere_except_in,locs) c =
   let term = constr_of_evaluable_ref evalref in
   let rec substrec () c =
     if nowhere_except_in & !pos > maxocc then c
-    else if c = term then
+    else if eq_constr c term then
       let ok =
 	if nowhere_except_in then List.mem !pos locs
 	else not (List.mem !pos locs) in
@@ -867,7 +965,7 @@ let abstract_scheme env sigma (locc,a) c =
   if occur_meta a then
     mkLambda (na,ta,c)
   else
-    mkLambda (na,ta,subst_term_occ locc a c)
+    mkLambda (na,ta,subst_closed_term_occ locc a c)
 
 let pattern_occs loccs_trm env sigma c =
   let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in
@@ -905,6 +1003,10 @@ let reduce_to_ind_gen allow_product env sigma t =
 let reduce_to_quantified_ind x = reduce_to_ind_gen true x
 let reduce_to_atomic_ind x = reduce_to_ind_gen false x
 
+let rec find_hnf_rectype env sigma t =
+  let ind,t = reduce_to_atomic_ind env sigma t in
+  ind, snd (decompose_app t)
+
 (* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta]
    or raise [NotStepReducible] if not a weak-head redex *)
 
@@ -932,7 +1034,7 @@ let one_step_reduce env sigma c =
       | _ when isEvalRef env x ->
 	  let ref = destEvalRef x in
           (try
-            red_elim_const env sigma ref stack
+             red_elim_const env sigma ref stack
            with Redelimination ->
 	     match reference_opt_value sigma env ref with
 	       | Some d -> d, stack
@@ -972,7 +1074,7 @@ let reduce_to_ref_gen allow_product env sigma ref t =
 	  with Not_found ->
           try
 	    let t' = nf_betaiota sigma (one_step_reduce env sigma t) in
-	    elimrec env t' l
+            elimrec env t' l
           with NotStepReducible ->
 	    errorlabstrm ""
 	      (str "Cannot recognize a statement based on " ++
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 55c305cc..8fd14dcc 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -1,33 +1,30 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacred.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Environ
 open Evd
 open Reductionops
 open Closure
-open Rawterm
+open Glob_term
 open Termops
 open Pattern
-(*i*)
+open Libnames
 
 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} *)
+(** {6 Reduction functions associated to tactics. {% \label{%}tacred{% }%} } *)
 
-(* Evaluable global reference *)
+(** Evaluable global reference *)
 
 val is_evaluable : Environ.env -> evaluable_global_reference -> bool
 
@@ -41,57 +38,69 @@ val global_of_evaluable_reference :
 
 exception Redelimination
 
-(* Red (raise user error if nothing reducible) *)
+(** Red (raise user error if nothing reducible) *)
 val red_product : reduction_function
 
-(* Red (raise Redelimination if nothing reducible) *)
+(** Red (raise Redelimination if nothing reducible) *)
 val try_red_product : reduction_function
 
-(* Simpl *)
+(** Tune the behaviour of simpl for the given constant name *)
+type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ]
+
+val set_simpl_behaviour :
+  bool -> global_reference -> (int list * int * simpl_flag list) -> unit
+val get_simpl_behaviour :
+  global_reference -> (int list * int * simpl_flag list) option
+
+(** Simpl *)
 val simpl : reduction_function
 
-(* Simpl only at the head *)
+(** Simpl only at the head *)
 val whd_simpl : reduction_function
 
-(* Hnf: like whd_simpl but force delta-reduction of constants that do
+(** Hnf: like whd_simpl but force delta-reduction of constants that do
    not immediately hide a non reducible fix or cofix *)
 val hnf_constr : reduction_function
 
-(* Unfold *)
+(** Unfold *)
 val unfoldn :
   (occurrences * evaluable_global_reference) list ->  reduction_function
 
-(* Fold *)
+(** Fold *)
 val fold_commands : constr list ->  reduction_function
 
-(* Pattern *)
+(** Pattern *)
 val pattern_occs : (occurrences * constr) list ->  reduction_function
-(* Rem: Lazy strategies are defined in Reduction *)
 
-(* Call by value strategy (uses Closures) *)
+(** Rem: Lazy strategies are defined in Reduction *)
+
+(** Call by value strategy (uses Closures) *)
 val cbv_norm_flags : Closure.RedFlags.reds ->  reduction_function
   val cbv_beta : local_reduction_function
   val cbv_betaiota : local_reduction_function
   val cbv_betadeltaiota :  reduction_function
-  val compute :  reduction_function  (* = [cbv_betadeltaiota] *)
+  val compute :  reduction_function  (** = [cbv_betadeltaiota] *)
 
-(* [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)]
+(** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)]
    with [I] an inductive definition;
    returns [I] and [t'] or fails with a user error *)
 val reduce_to_atomic_ind : env ->  evar_map -> types -> inductive * types
 
-(* [reduce_to_quantified_ind env sigma t] puts [t] in the form
+(** [reduce_to_quantified_ind env sigma t] puts [t] in the form
    [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition;
    returns [I] and [t'] or fails with a user error *)
 val reduce_to_quantified_ind : env ->  evar_map -> types -> inductive * types
 
-(* [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
+(** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
    [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *)
 val reduce_to_quantified_ref :
-  env ->  evar_map -> Libnames.global_reference -> types -> types
+  env ->  evar_map -> global_reference -> types -> types
 
 val reduce_to_atomic_ref :
-  env ->  evar_map -> Libnames.global_reference -> types -> types
+  env ->  evar_map -> global_reference -> types -> types
+
+val find_hnf_rectype : 
+  env ->  evar_map -> types -> inductive * constr list
 
 val contextually : bool -> occurrences * constr_pattern ->
   (patvar_map -> reduction_function) -> reduction_function
diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml
index 9dda5143..98091087 100644
--- a/pretyping/term_dnet.ml
+++ b/pretyping/term_dnet.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
 (*i*)
 open Util
 open Term
diff --git a/pretyping/term_dnet.mli b/pretyping/term_dnet.mli
index 9c4c9dbc..a2c535d1 100644
--- a/pretyping/term_dnet.mli
+++ b/pretyping/term_dnet.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
-(*i*)
 open Term
 open Sign
 open Libnames
 open Mod_subst
-(*i*)
 
-(* Dnets on constr terms.
+(** Dnets on constr terms.
 
    An instantiation of Dnet on (an approximation of) constr. It
    associates a term (possibly with Evar) with an
@@ -33,25 +29,25 @@ open Mod_subst
    See lib/dnet.mli for more details.
 *)
 
-(* Identifiers to store (right hand side of the association) *)
+(** 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 *)
+  (** how to substitute them for storage *)
   val subst : substitution -> t -> t
 
-  (* how to recover the term from the identifier *)
+  (** how to recover the term from the identifier *)
   val constr_of : t -> constr
 end
 
-(* Options : *)
+(** Options : *)
 module type OPT = sig
 
-  (* pre-treatment to terms before adding or searching *)
+  (** pre-treatment to terms before adding or searching *)
   val reduce : constr -> constr
 
-  (* direction of post-filtering w.r.t sort subtyping :
+  (** direction of post-filtering w.r.t sort subtyping :
      - true means query <= terms in the structure
      - false means terms <= query
  *)
@@ -63,17 +59,17 @@ sig
   type t
   type ident
 
-  (* results of filtering : identifier, a context (term with Evar
+  (** 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
+  (** [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 *)
+  (** merge of dnets. Faster than re-adding all terms *)
   val union : t -> t -> t
 
   val subst : substitution -> t -> t
@@ -82,25 +78,25 @@ sig
    * High-level primitives describing specific search problems
    *)
 
-  (* [search_pattern dn c] returns all terms/patterns in dn
+  (** [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
+  (** [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
+  (** [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
+  (** [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 *)
+  (** [find_all dn] returns all idents contained in dn *)
   val find_all : t -> ident list
 
   val map : (ident -> ident) -> t -> t
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 70f2279c..6371fd3a 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -34,7 +32,6 @@ let pr_name = function
   | Name id -> pr_id id
   | Anonymous -> str "_"
 
-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
@@ -149,11 +146,13 @@ let print_env env =
 
 let set_module m = current_module := m*)
 
-let new_univ =
+let new_univ_level =
   let univ_gen = ref 0 in
   (fun sp ->
     incr univ_gen;
-    Univ.make_univ (Lib.library_dp(),!univ_gen))
+    Univ.make_universe_level (Lib.library_dp(),!univ_gen))
+
+let new_univ () = Univ.make_universe (new_univ_level ())
 let new_Type () = mkType (new_univ ())
 let new_Type_sort () = Type (new_univ ())
 
@@ -238,18 +237,18 @@ let mkProd_wo_LetIn (na,body,t) c =
     | None -> mkProd (na,  t, c)
     | Some b -> subst1 b c
 
-let it_mkProd ~init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
-let it_mkLambda ~init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init
+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 =
   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_mkNamedProd_wo_LetIn = it_named_context_quantifier mkNamedProd_wo_LetIn
-let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
+let it_mkProd_or_LetIn init = it_named_context_quantifier mkProd_or_LetIn ~init
+let it_mkProd_wo_LetIn init = it_named_context_quantifier mkProd_wo_LetIn ~init
+let it_mkLambda_or_LetIn init = it_named_context_quantifier mkLambda_or_LetIn ~init
+let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_LetIn ~init
+let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init
+let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init
 
 (* *)
 
@@ -265,11 +264,45 @@ let rec strip_head_cast c = match kind_of_term c with
   | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
 
+let rec drop_extra_implicit_args c = match kind_of_term c with
+  (* Removed trailing extra implicit arguments, what improves compatibility
+     for constants with recently added maximal implicit arguments *)
+  | App (f,args) when isEvar (array_last args) ->
+      drop_extra_implicit_args
+	(mkApp (f,fst (array_chop (Array.length args - 1) args)))
+  | _ -> c
+
 (* Get the last arg of an application *)
 let last_arg c = match kind_of_term c with
   | App (f,cl) -> array_last cl
   | _ -> anomaly "last_arg"
 
+(* Get the last arg of an application *)
+let decompose_app_vect c =
+  match kind_of_term c with
+  | App (f,cl) -> (f, cl)
+  | _ -> (c,[||])
+
+let adjust_app_list_size f1 l1 f2 l2 =
+  let len1 = List.length l1 and len2 = List.length l2 in
+  if len1 = len2 then (f1,l1,f2,l2)
+  else if len1 < len2 then
+   let extras,restl2 = list_chop (len2-len1) l2 in
+    (f1, l1, applist (f2,extras), restl2)
+  else
+    let extras,restl1 = list_chop (len1-len2) l1 in
+    (applist (f1,extras), restl1, f2, l2)
+
+let adjust_app_array_size f1 l1 f2 l2 =
+  let len1 = Array.length l1 and len2 = Array.length l2 in
+  if len1 = len2 then (f1,l1,f2,l2)
+  else if len1 < len2 then
+    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
+    (appvect (f1,extras), restl1, f2, l2)
+
 (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
    subterms of [c]; it carries an extra data [l] (typically a name
    list) which is processed by [g na] (which typically cons [na] to
@@ -523,6 +556,14 @@ let collect_metas c =
   in
   List.rev (collrec [] c)
 
+(* collects all vars; warning: this is only visible vars, not dependencies in
+   all section variables; for the latter, use global_vars_set *)
+let collect_vars c =
+  let rec aux vars c = match kind_of_term c with
+  | Var id -> Idset.add id vars
+  | _ -> fold_constr aux vars c in
+  aux Idset.empty c
+
 (* Tests whether [m] is a subterm of [t]:
    [m] is appropriately lifted through abstractions of [t] *)
 
@@ -546,6 +587,25 @@ let dependent_main noevar m t =
 let dependent = dependent_main false
 let dependent_no_evar = dependent_main true
 
+let count_occurrences m t =
+  let n = ref 0 in
+  let rec countrec m t =
+    if eq_constr m t then
+      incr n
+    else
+      match kind_of_term m, kind_of_term t with
+	| App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
+	    countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
+	    Array.iter (countrec m)
+	      (Array.sub lt
+		(Array.length lm) ((Array.length lt) - (Array.length lm)))
+	| _, Cast (c,_,_) when isMeta c -> ()
+	| _, Evar _ -> ()
+	| _ -> iter_constr_with_binders (lift 1) countrec m t
+  in
+  countrec m t;
+  !n
+
 (* Synonymous *)
 let occur_term = dependent
 
@@ -592,10 +652,9 @@ let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
 	  None
     | _ -> None
 
-(* Recognizing occurrences of a given (closed) subterm in a term for Pattern :
-   [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed)
-   term [c] in a term [t] *)
-(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*)
+(* Recognizing occurrences of a given subterm in a term: [subst_term c t]
+   substitutes [(Rel 1)] for all occurrences of term [c] in a term [t];
+   works if [c] has rels *)
 
 let subst_term_gen eq_fun c t =
   let rec substrec (k,c as kc) t =
@@ -608,10 +667,11 @@ let subst_term_gen eq_fun c t =
   in
   substrec (1,c) t
 
-(* Recognizing occurrences of a given (closed) subterm in a term :
-   [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed)
-   term [c1] in a term [t] *)
-(*i Meme remarque : a priori [c] n'est pas forcement clos i*)
+let subst_term = subst_term_gen eq_constr
+
+(* Recognizing occurrences of a given subterm in a term :
+   [replace_term c1 c2 t] substitutes [c2] for all occurrences of
+   term [c1] in a term [t]; works if [c1] and [c2] have rels *)
 
 let replace_term_gen eq_fun c by_c in_t =
   let rec substrec (k,c as kc) t =
@@ -624,8 +684,6 @@ let replace_term_gen eq_fun c by_c in_t =
   in
   substrec (0,c) in_t
 
-let subst_term = subst_term_gen eq_constr
-
 let replace_term = replace_term_gen eq_constr
 
 (* Substitute only at a list of locations or excluding a list of
@@ -633,6 +691,11 @@ let replace_term = replace_term_gen eq_constr
    occurrence except the ones in l and b=false, means all occurrences
    except the ones in l *)
 
+type hyp_location_flag = (* To distinguish body and type of local defs *)
+  | InHyp
+  | InHypTypeOnly
+  | InHypValueOnly
+
 type occurrences = bool * int list
 let all_occurrences = (false,[])
 let no_occurrences_in_set = (true,[])
@@ -643,57 +706,127 @@ let error_invalid_occurrence l =
     (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 =
+let pr_position (cl,pos) =
+  let clpos = match cl with
+    | None -> str " of the goal"
+    | Some (id,InHyp) -> str " of hypothesis " ++ pr_id id
+    | Some (id,InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id
+    | Some (id,InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in
+  int pos ++ clpos
+
+let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) (nowhere_except_in,locs) =
+  let s = if nested then "Found nested occurrences of the pattern"
+    else "Found incompatible occurrences of the pattern" in
+  errorlabstrm ""
+    (str s ++ str ":" ++
+     spc () ++ str "Matched term " ++ quote (print_constr t2) ++
+     strbrk " at position " ++ pr_position (cl2,pos2) ++ 
+     strbrk " is not compatible with matched term " ++
+     quote (print_constr t1) ++ strbrk " at position " ++ 
+     pr_position (cl1,pos1) ++ str ".")
+
+let is_selected pos (nowhere_except_in,locs) =
+  nowhere_except_in && List.mem pos locs ||
+  not nowhere_except_in && not (List.mem pos locs)
+
+exception NotUnifiable
+
+type 'a testing_function = {
+  match_fun : constr -> 'a;
+  merge_fun : 'a -> 'a -> 'a;
+  mutable testing_state : 'a;
+  mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option
+}
+
+let subst_closed_term_occ_gen_modulo (nowhere_except_in,locs as plocs) test cl occ t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref occ in
-  assert (List.for_all (fun x -> x >= 0) locs);
-  let rec substrec (k,c as kc) t =
-    if nowhere_except_in & !pos > maxocc then t
-    else
-    if eq_constr c t then
-      let r =
-	if nowhere_except_in then
-	  if List.mem !pos locs then (mkRel k) else t
-	else
-	  if List.mem !pos locs then t else (mkRel k)
-      in incr pos; r
-    else
-      map_constr_with_binders_left_to_right
-	(fun d (k,c) -> (k+1,lift 1 c))
-        substrec kc t
+  let nested = ref false in
+  let add_subst t subst =
+    try
+      test.testing_state <- test.merge_fun subst test.testing_state;
+      test.last_found <- Some (cl,!pos,t)
+    with NotUnifiable ->
+      let lastpos = Option.get test.last_found in
+      error_cannot_unify_occurrences !nested (cl,!pos,t) lastpos plocs in
+  let rec substrec k t =
+    if nowhere_except_in & !pos > maxocc then t else
+    try
+      let subst = test.match_fun t in
+      if is_selected !pos plocs then
+        (add_subst t subst; incr pos;
+         (* Check nested matching subterms *)
+         nested := true; ignore (subst_below k t); nested := false;
+         (* Do the effective substitution *)
+         mkRel k)
+      else
+        (incr pos; subst_below k t)
+    with NotUnifiable ->
+      subst_below k t
+  and subst_below k t =
+    map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t
   in
-  let t' = substrec (1,c) t in
+  let t' = substrec 1 t in
   (!pos, 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
-    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;
-    t'
-
-type hyp_location_flag = (* To distinguish body and type of local defs *)
-  | InHyp
-  | InHypTypeOnly
-  | InHypValueOnly
-
-let subst_term_occ_decl ((nowhere_except_in,locs as plocs),hloc) c (id,bodyopt,typ as d) =
-  match bodyopt,hloc with
-  | None, InHypValueOnly -> errorlabstrm "" (pr_id id ++ str " has no value")
-  | None, _ -> (id,None,subst_term_occ plocs c typ)
-  | Some body, InHypTypeOnly -> (id,Some body,subst_term_occ plocs c typ)
-  | Some body, InHypValueOnly -> (id,Some (subst_term_occ plocs c body),typ)
+let is_nowhere (nowhere_except_in,locs) = nowhere_except_in && locs = [] 
+
+let check_used_occurrences nbocc (nowhere_except_in,locs) =
+  let rest = List.filter (fun o -> o >= nbocc) locs in
+  if rest <> [] then error_invalid_occurrence rest
+
+let proceed_with_occurrences f plocs x =
+  if is_nowhere plocs then (* optimization *) x else
+  begin
+    assert (List.for_all (fun x -> x >= 0) (snd plocs));
+    let (nbocc,x) = f 1 x in
+    check_used_occurrences nbocc plocs;
+    x
+  end
+
+let make_eq_test c = {
+  match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable);
+  merge_fun = (fun () () -> ());
+  testing_state = ();
+  last_found = None
+} 
+
+let subst_closed_term_occ_gen plocs pos c t =
+  subst_closed_term_occ_gen_modulo plocs (make_eq_test c) None pos t
+
+let subst_closed_term_occ plocs c t =
+  proceed_with_occurrences (fun occ -> subst_closed_term_occ_gen plocs occ c)
+    plocs t
+
+let subst_closed_term_occ_modulo plocs test cl t =
+  proceed_with_occurrences
+    (subst_closed_term_occ_gen_modulo plocs test cl) plocs t
+
+let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
+  let f = f (Some (id,hyploc)) in
+  match bodyopt,hyploc with
+  | None, InHypValueOnly ->
+      errorlabstrm "" (pr_id id ++ str " has no value.")
+  | None, _ | Some _, InHypTypeOnly ->
+      let acc,typ = f acc typ in acc,(id,bodyopt,typ)
+  | Some body, InHypValueOnly ->
+      let acc,body = f acc body in acc,(id,Some body,typ)
   | Some body, InHyp ->
-	if locs = [] then
-	  if nowhere_except_in then d
-	  else (id,Some (subst_term c body),subst_term c typ)
-	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')
+      let acc,body = f acc body in
+      let acc,typ = f acc typ in
+      acc,(id,Some body,typ)
+
+let subst_closed_term_occ_decl (plocs,hyploc) c d =
+  proceed_with_occurrences
+    (map_named_declaration_with_hyploc
+       (fun _ occ -> subst_closed_term_occ_gen plocs occ c) hyploc) plocs d
+
+let subst_closed_term_occ_decl_modulo (plocs,hyploc) test d =
+  proceed_with_occurrences
+    (map_named_declaration_with_hyploc
+       (subst_closed_term_occ_gen_modulo plocs test)
+       hyploc)
+    plocs d
 
 let vars_of_env env =
   let s =
@@ -965,7 +1098,7 @@ let on_judgment_value f j = { j with uj_val = f j.uj_val }
 let on_judgment_type f j = { j with uj_type = f j.uj_type }
 
 (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
-     variables *)
+     variables; skips let-in's *)
 let context_chop k ctx =
   let rec chop_aux acc = function
     | (0, l2) -> (List.rev acc, l2)
@@ -974,3 +1107,28 @@ let context_chop k ctx =
     | (_, []) -> anomaly "context_chop"
   in chop_aux [] (k,ctx)
 
+(* Do not skip let-in's *)
+let env_rel_context_chop k env =
+  let rels = rel_context env in
+  let ctx1,ctx2 = list_chop k rels in
+  push_rel_context ctx2 (reset_with_named_context (named_context_val env) env),
+  ctx1
+
+(*******************************************)
+(* Functions to deal with impossible cases *)
+(*******************************************)
+let impossible_default_case = ref None
+
+let set_impossible_default_clause c = impossible_default_case := Some c
+
+let coq_unit_judge =
+  let na1 = Name (id_of_string "A") in
+  let na2 = Name (id_of_string "H") in
+  fun () ->
+    match !impossible_default_case with
+    | Some (id,type_of_id) ->
+	make_judge id type_of_id
+    | 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)))
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index 91c76564..5448d97c 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Util
 open Pp
 open Names
@@ -15,7 +13,8 @@ open Term
 open Sign
 open Environ
 
-(* Universes *)
+(** Universes *)
+val new_univ_level : unit -> Univ.universe_level
 val new_univ : unit -> Univ.universe
 val new_sort_in_family : sorts_family -> sorts
 val new_Type : unit -> types
@@ -23,10 +22,11 @@ val new_Type_sort : unit -> sorts
 val refresh_universes : types -> types
 val refresh_universes_strict : types -> types
 
-(* printers *)
+(** printers *)
 val print_sort : sorts -> std_ppcmds
 val pr_sort_family : sorts_family -> std_ppcmds
-(* debug printer: do not use to display terms to the casual user... *)
+
+(** debug printer: do not use to display terms to the casual user... *)
 val set_print_constr : (env -> constr -> std_ppcmds) -> unit
 val print_constr     : constr -> std_ppcmds
 val print_constr_env : env -> constr -> std_ppcmds
@@ -35,35 +35,34 @@ val pr_rel_decl : env -> rel_declaration -> std_ppcmds
 val print_rel_context : env -> std_ppcmds
 val print_env : env -> std_ppcmds
 
-(* about contexts *)
+(** 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 *)
+(** 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
 
-(* iterators/destructors on terms *)
+(** iterators/destructors on terms *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
 val mkProd_wo_LetIn : rel_declaration -> types -> 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_mkNamedProd_or_LetIn   : init:types -> named_context -> types
-val it_mkNamedProd_wo_LetIn   : init:types -> named_context -> types
-val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
+val it_mkProd : types -> (name * types) list -> types
+val it_mkLambda : constr -> (name * types) list -> constr
+val it_mkProd_or_LetIn : types -> rel_context -> types
+val it_mkProd_wo_LetIn : types -> rel_context -> types
+val it_mkLambda_or_LetIn : constr -> rel_context -> constr
+val it_mkNamedProd_or_LetIn : types -> named_context -> types
+val it_mkNamedProd_wo_LetIn : types -> named_context -> types
+val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr
 
 val it_named_context_quantifier :
   (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
 
-(**********************************************************************)
-(* Generic iterators on constr                                        *)
+(** {6 Generic iterators on constr} *)
 
 val map_constr_with_named_binders :
   (name -> 'a -> 'a) ->
@@ -76,7 +75,7 @@ val map_constr_with_full_binders :
   (rel_declaration -> 'a -> 'a) ->
   ('a -> constr -> constr) -> 'a -> constr -> constr
 
-(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
+(** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
    subterms of [c] starting from [acc] and proceeding from left to
    right according to the usual representation of the constructions as
    [fold_constr] but it carries an extra data [n] (typically a lift
@@ -93,8 +92,9 @@ val iter_constr_with_full_binders :
 (**********************************************************************)
 
 val strip_head_cast : constr -> constr
+val drop_extra_implicit_args : constr -> constr
 
-(* occur checks *)
+(** occur checks *)
 exception Occur
 val occur_meta : types -> bool
 val occur_existential : types -> bool
@@ -108,68 +108,96 @@ val occur_var_in_decl :
 val free_rels : constr -> Intset.t
 val dependent : constr -> constr -> bool
 val dependent_no_evar : constr -> constr -> bool
+val count_occurrences : constr -> constr -> int
 val collect_metas : constr -> int list
-val occur_term : constr -> constr -> bool (* Synonymous
- of dependent *)
-(* Substitution of metavariables *)
+val collect_vars : constr -> Idset.t (** for visible vars only *)
+val occur_term : constr -> constr -> bool (** Synonymous
+ of dependent 
+   Substitution of metavariables *)
 type meta_value_map = (metavariable * constr) list
 val subst_meta : meta_value_map -> constr -> constr
 
-(* Type assignment for metavariables *)
+(** Type assignment for metavariables *)
 type meta_type_map = (metavariable * types) list
 
-(* [pop c] lifts by -1 the positive indexes in [c] *)
+(** [pop c] lifts by -1 the positive indexes in [c] *)
 val pop : constr -> constr
 
-(*s Substitution of an arbitrary large term. Uses equality modulo
+(** {6 ... } *)
+(** Substitution of an arbitrary large term. Uses equality modulo
    reduction of let *)
 
-(* [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
+(** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
    as equality *)
 val subst_term_gen :
   (constr -> constr -> bool) -> constr -> constr -> constr
 
-(* [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq]
+(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq]
    as equality *)
 val replace_term_gen :
   (constr -> constr -> bool) ->
     constr -> constr -> constr -> constr
 
-(* [subst_term d c] replaces [Rel 1] by [d] in [c] *)
+(** [subst_term d c] replaces [Rel 1] by [d] in [c] *)
 val subst_term : constr -> constr -> constr
 
-(* [replace_term d e c] replaces [d] by [e] in [c] *)
+(** [replace_term d e c] replaces [d] by [e] in [c] *)
 val replace_term : constr -> constr -> constr -> constr
 
-(* In occurrences sets, false = everywhere except and true = nowhere except *)
+(** In occurrences sets, false = everywhere except and true = nowhere except *)
 type occurrences = bool * int list
 val all_occurrences : occurrences
 val no_occurrences_in_set : occurrences
 
-(* [subst_term_occ_gen occl n c d] replaces occurrences of [c] at
+(** [subst_closed_term_occ_gen occl n c d] replaces occurrences of closed [c] at
    positions [occl], counting from [n], by [Rel 1] in [d] *)
-val subst_term_occ_gen :
+val subst_closed_term_occ_gen :
   occurrences -> int -> constr -> types -> int * types
 
-(* [subst_term_occ occl c d] replaces occurrences of [c] at
-   positions [occl] by [Rel 1] in [d] (see also Note OCC) *)
-val subst_term_occ : occurrences -> constr -> constr -> constr
-
-(* [subst_term_occ_decl occl c decl] replaces occurrences of [c] at
-   positions [occl] by [Rel 1] in [decl] *)
+(** [subst_closed_term_occ_modulo] looks for subterm modulo a
+    testing function returning a substitution of type ['a] (or failing
+    with NotUnifiable); a function for merging substitution (possibly
+    failing with NotUnifiable) and an initial substitution are
+    required too *)
 
-type hyp_location_flag = (* To distinguish body and type of local defs *)
+type hyp_location_flag = (** To distinguish body and type of local defs *)
   | InHyp
   | InHypTypeOnly
   | InHypValueOnly
 
-val subst_term_occ_decl :
+type 'a testing_function = {
+  match_fun : constr -> 'a;
+  merge_fun : 'a -> 'a -> 'a;
+  mutable testing_state : 'a;
+  mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option
+}
+
+val make_eq_test : constr -> unit testing_function
+
+exception NotUnifiable
+
+val subst_closed_term_occ_modulo :
+  occurrences -> 'a testing_function -> (identifier * hyp_location_flag) option
+  -> constr -> types
+
+(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at
+   positions [occl] by [Rel 1] in [d] (see also Note OCC) *)
+val subst_closed_term_occ : occurrences -> constr -> constr -> constr
+
+(** [subst_closed_term_occ_decl occl c decl] replaces occurrences of closed [c]
+   at positions [occl] by [Rel 1] in [decl] *)
+
+val subst_closed_term_occ_decl :
   occurrences * hyp_location_flag -> constr -> named_declaration ->
       named_declaration
 
+val subst_closed_term_occ_decl_modulo :
+  occurrences * hyp_location_flag -> 'a testing_function ->
+  named_declaration -> named_declaration
+
 val error_invalid_occurrence : int list -> 'a
 
-(* Alternative term equalities *)
+(** 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
@@ -181,7 +209,7 @@ val eta_eq_constr : constr -> constr -> bool
 
 exception CannotFilter
 
-(* Lightweight first-order filtering procedure. Unification
+(** 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].
@@ -193,10 +221,18 @@ val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
 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 *)
+(** Get the last arg of a constr intended to be an application *)
 val last_arg : constr -> constr
 
-(* name contexts *)
+(** Force the decomposition of a term as an applicative one *)
+val decompose_app_vect : constr -> constr * constr array
+
+val adjust_app_list_size : constr -> constr list -> constr -> constr list ->
+  (constr * constr list * constr * constr list)
+val adjust_app_array_size : constr -> constr array -> constr -> constr array ->
+  (constr * constr array * constr * constr array)
+
+(** name contexts *)
 type names_context = name list
 val add_name : name -> names_context -> names_context
 val lookup_name_of_rel : int -> names_context -> name
@@ -207,18 +243,19 @@ val ids_of_named_context : named_context -> identifier list
 val ids_of_context : env -> identifier list
 val names_of_rel_context : env -> names_context
 
-val context_chop : int -> rel_context -> (rel_context*rel_context)
+val context_chop : int -> rel_context -> rel_context * rel_context
+val env_rel_context_chop : int -> env -> env * rel_context
 
-(* Set of local names *)
+(** Set of local names *)
 val vars_of_env: env -> Idset.t
 val add_vname : Idset.t -> name -> Idset.t
 
-(* other signature iterators *)
+(** 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 smash_rel_context : rel_context -> rel_context (* expand lets in 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
@@ -234,19 +271,23 @@ 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
 
-(* Gives an ordered list of hypotheses, closed by dependencies,
+(** Gives an ordered list of hypotheses, closed by dependencies,
    containing a given set *)
 val dependency_closure : env -> named_context -> Idset.t -> identifier list
 
-(* Test if an identifier is the basename of a global reference *)
+(** Test if an identifier is the basename of a global reference *)
 val is_section_variable : identifier -> bool
 
 val isGlobalRef : constr -> bool
 
 val has_polymorphic_type : constant -> bool
 
-(* Combinators on judgments *)
+(** Combinators on judgments *)
 
 val on_judgment       : (types -> types) -> unsafe_judgment -> unsafe_judgment
 val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment
 val on_judgment_type  : (types -> types) -> unsafe_judgment -> unsafe_judgment
+
+(** {6 Functions to deal with impossible cases } *)
+val set_impossible_default_clause : constr * types -> unit
+val coq_unit_judge : unit -> unsafe_judgment
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 9e64143d..e85f174e 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Libnames
@@ -24,21 +22,32 @@ open Libobject
 (*i*)
 
 
-let add_instance_hint_ref = ref (fun id pri -> assert false)
+let add_instance_hint_ref = ref (fun id local pri -> assert false)
 let register_add_instance_hint =
   (:=) add_instance_hint_ref
 let add_instance_hint id = !add_instance_hint_ref id
 
-let set_typeclass_transparency_ref = ref (fun id pri -> assert false)
+let remove_instance_hint_ref = ref (fun id -> assert false)
+let register_remove_instance_hint =
+  (:=) remove_instance_hint_ref
+let remove_instance_hint id = !remove_instance_hint_ref id
+
+let set_typeclass_transparency_ref = ref (fun id local c -> assert false)
 let register_set_typeclass_transparency =
   (:=) set_typeclass_transparency_ref
-let set_typeclass_transparency gr c = !set_typeclass_transparency_ref gr c
+let set_typeclass_transparency gr local c = !set_typeclass_transparency_ref gr local c
+
+let classes_transparent_state_ref = ref (fun () -> assert false)
+let register_classes_transparent_state = (:=) classes_transparent_state_ref
+let classes_transparent_state () = !classes_transparent_state_ref ()
+
+let solve_instanciation_problem = ref (fun _ _ _ -> assert false)
 
-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
+let resolve_one_typeclass env evm t =
+  !solve_instanciation_problem env evm t
 
 type rels = constr list
+type direction = Forward | Backward
 
 (* This module defines type-classes *)
 type typeclass = {
@@ -52,8 +61,9 @@ type typeclass = {
   cl_props : rel_context;
 
   (* The method implementaions as projections. *)
-  cl_projs : (identifier * constant option) list;
+  cl_projs : (name * (direction * int option) option * constant option) list;
 }
+
 module Gmap = Fmap.Make(RefOrdered)
 
 type typeclasses = typeclass Gmap.t
@@ -65,7 +75,7 @@ type instance = {
      -1 for discard, 0 for none, mutable to avoid redeclarations
      when multiple rebuild_object happen. *)
   is_global: int;
-  is_impl: global_reference; 
+  is_impl: global_reference;
 }
 
 type instances = (instance Gmap.t) Gmap.t
@@ -118,7 +128,11 @@ let dest_class_app env c =
   let cl, args = decompose_app c in
     global_class_of_constr env cl, args
 
-let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None
+let dest_class_arity env c =
+  let rels, c = Term.decompose_prod_assum c in
+    rels, dest_class_app env c
+
+let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with _ -> None
 
 let rec is_class_type evd c =
   match kind_of_term c with
@@ -148,7 +162,7 @@ let subst_class (subst,cl) =
   let do_subst_context (grs,ctx) =
     list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
     do_subst_ctx ctx in
-  let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, Option.smartmap do_subst_con y)) projs in
+  let do_subst_projs projs = list_smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in
   { cl_impl = do_subst_gr cl.cl_impl;
     cl_context = do_subst_context cl.cl_context;
     cl_props = do_subst_ctx cl.cl_props;
@@ -180,7 +194,7 @@ let discharge_class (_,cl) =
       let newgrs = List.map (fun (_, _, t) -> 
 	match class_of_constr t with
 	| None -> None
-	| Some tc -> Some (tc.cl_impl, true))
+	| Some (_, (tc, _)) -> Some (tc.cl_impl, true))
 	ctx' 
       in
 	list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
@@ -195,11 +209,15 @@ let discharge_class (_,cl) =
     { 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 }
+      cl_projs = list_smartmap (fun (x, y, z) -> x, y, Option.smartmap Lib.discharge_con z) cl.cl_projs }
 
-let rebuild_class cl = cl
+let rebuild_class cl = 
+  try 
+    let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in
+      set_typeclass_transparency cst false false; cl
+  with _ -> cl
 
-let (class_input,class_output) =
+let class_input : typeclass -> obj =
   declare_object
     { (default_object "type classes state") with
       cache_function = cache_class;
@@ -213,55 +231,150 @@ let (class_input,class_output) =
 let add_class cl =
   Lib.add_anonymous_leaf (class_input cl)
 
+(** Build the subinstances hints. *)
+
+let check_instance env sigma c =
+  try 
+    let (evd, c) = resolve_one_typeclass env sigma
+      (Retyping.get_type_of env sigma c) in
+      Evd.is_empty (Evd.undefined_evars evd)
+  with _ -> false
+
+let build_subclasses ~check env sigma glob pri =
+  let rec aux pri c =
+    let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in
+      match class_of_constr ty with
+      | None -> []
+      | Some (rels, (tc, args)) ->
+	let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in
+	let projargs = Array.of_list (args @ [instapp]) in
+	let projs = list_map_filter 
+	  (fun (n, b, proj) ->
+	   match b with 
+	   | None -> None
+	   | Some (Backward, _) -> None
+	   | Some (Forward, pri') ->
+	     let proj = Option.get proj in
+	     let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in
+	       if check && check_instance env sigma body then None
+	       else 
+		 let pri = 
+		   match pri, pri' with
+		   | Some p, Some p' -> Some (p + p')
+		   | Some p, None -> Some (p + 1)
+		   | _, _ -> None
+		 in
+		   Some (ConstRef proj, pri, body)) tc.cl_projs 
+	in
+	let declare_proj hints (cref, pri, body) =
+	  let rest = aux pri body in
+	    hints @ (pri, body) :: rest
+	in List.fold_left declare_proj [] projs 
+  in aux pri (constr_of_global glob)
 
 (*
  * instances persistent object
  *)
 
-let load_instance (_,inst) = 
+type instance_action = 
+  | AddInstance
+  | RemoveInstance
+
+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 remove_instance inst =
+  let insts = 
+    try Gmap.find inst.is_class !instances 
+    with Not_found -> assert false in
+  let insts = Gmap.remove inst.is_impl insts in
+  instances := Gmap.add inst.is_class insts !instances
+
+let cache_instance (_, (action, i)) =
+  match action with 
+  | AddInstance -> load_instance i
+  | RemoveInstance -> remove_instance i      
 
-let subst_instance (subst,inst) = 
+let subst_instance (subst, (action, inst)) = action,
   { inst with 
       is_class = fst (subst_global subst inst.is_class);
       is_impl = fst (subst_global subst inst.is_impl) }
 
-let discharge_instance (_,inst) =
+let discharge_instance (_, (action, inst)) =
   if inst.is_global <= 0 then None
-  else Some 
+  else Some (action,
     { inst with 
       is_global = pred inst.is_global;
       is_class = Lib.discharge_global inst.is_class;
-      is_impl = Lib.discharge_global inst.is_impl }
+      is_impl = Lib.discharge_global inst.is_impl })
     
-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 is_local i = i.is_global = -1
+
+let add_instance check inst =
+  add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri;
+  List.iter (fun (pri, c) -> add_instance_hint c (is_local inst) pri) 
+    (build_subclasses ~check:(check && not (isVarRef inst.is_impl))
+       (Global.env ()) Evd.empty inst.is_impl inst.is_pri)
 
-let (instance_input,instance_output) =
+let rebuild_instance (action, inst) =
+  if action = AddInstance then add_instance true inst;
+  (action, inst)
+
+let classify_instance (action, inst) =
+  if is_local inst then Dispose
+  else Substitute (action, inst)
+
+let load_instance (_, (action, inst) as ai) =
+  cache_instance ai;
+  if action = AddInstance then
+    add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri
+
+let instance_input : instance_action * instance -> obj =
   declare_object
     { (default_object "type classes instances state") with
       cache_function = cache_instance;
-      load_function = (fun _ -> load_instance);
-      open_function = (fun _ -> load_instance);
+      load_function = (fun _ x -> cache_instance x);
+      open_function = (fun _ x -> cache_instance x);
       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
+  Lib.add_anonymous_leaf (instance_input (AddInstance, i));
+  add_instance true i
+
+let remove_instance i =
+  Lib.add_anonymous_leaf (instance_input (RemoveInstance, i));
+  remove_instance_hint i.is_impl
+
+let declare_instance pri local glob =
+  let c = constr_of_global glob in
+  let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in
+    match class_of_constr ty with
+    | Some (rels, (tc, args) as _cl) ->
+      add_instance (new_instance tc pri (not local) glob)
+(*       let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *)
+(*       let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *)
+(* 	Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *)
+(* 	Auto.add_hints local [typeclasses_db]  *)
+(* 	(Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *)
+    | None -> ()
+
+let add_class cl =
+  add_class cl;
+  List.iter (fun (n, inst, body) ->
+	     match inst with
+	     | Some (Backward, pri) ->
+	       declare_instance pri false (ConstRef (Option.get body))
+	     | _ -> ())
+  cl.cl_projs
+
 
 open Declarations
 
@@ -275,7 +388,7 @@ let add_constant_class cst =
       cl_projs = []
     }
   in add_class tc;
-    set_typeclass_transparency (EvalConstRef cst) false
+    set_typeclass_transparency (EvalConstRef cst) false false
       
 let add_inductive_class ind =
   let mind, oneind = Global.lookup_inductive ind in
@@ -308,13 +421,6 @@ let instance_constructor cl args =
 
 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 (Gmap.add y.is_impl y l) m
-  with Not_found ->
-    Gmap.add x (Gmap.add y.is_impl y Gmap.empty) m
-
 let cmap_elements c = Gmap.fold (fun k v acc -> v :: acc) c []
 
 let instances_of c =
@@ -350,41 +456,43 @@ let is_implicit_arg k =
     | InternalHole -> true
     | _ -> false
 
+
 (* 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]
    calls (e.g. when doing apply in an External hint in typeclass_instances).
-   Would be solved by having real evars-as-goals. *)
+   Would be solved by having real evars-as-goals.
 
-let ((bool_in : bool -> Dyn.t),
-    (bool_out : Dyn.t -> bool)) = Dyn.create "bool"
+   Nota: we will only check the resolvability status of undefined evars.
+ *)
 
-let bool_false = bool_in false
+let resolvable = Store.field ()
+open Store.Field
 
 let is_resolvable evi =
-  match evi.evar_extra with
-      Some t -> if Dyn.tag t = "bool" then bool_out t else true
-    | None -> true
+  assert (evi.evar_body = Evar_empty);
+  Option.default true (resolvable.get evi.evar_extra)
+
+let mark_unresolvable_undef evi =
+  let t = resolvable.set false evi.evar_extra in
+  { evi with evar_extra = t }
 
 let mark_unresolvable evi =
-  { evi with evar_extra = Some bool_false }
+  assert (evi.evar_body = Evar_empty);
+  mark_unresolvable_undef evi
 
 let mark_unresolvables sigma =
-  Evd.fold (fun ev evi evs ->
-    Evd.add evs ev (mark_unresolvable evi))
-    sigma Evd.empty
+  Evd.fold_undefined (fun ev evi evs ->
+    Evd.add evs ev (mark_unresolvable_undef evi))
+    sigma (Evd.defined_evars sigma)
 
 let has_typeclasses evd =
-  Evd.fold (fun ev evi has -> has ||
-    (evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi))
+  Evd.fold_undefined (fun ev evi has -> has ||
+    (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) 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 83ae84a5..74ccaf83 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Libnames
 open Decl_kinds
@@ -20,25 +17,28 @@ open Nametab
 open Mod_subst
 open Topconstr
 open Util
-(*i*)
 
-(* This module defines type-classes *)
+type direction = Forward | Backward
+
+(** 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;
 
-  (* 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;
 
-  (* Context of definitions and properties on defs, will not be shared *)
+  (** 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
-     sorting restrictions. *)
-  cl_projs : (identifier * constant option) list;
+  (** The methods implementations of the typeclass as projections. 
+      Some may be undefinable due to sorting restrictions or simply undefined if 
+      no name is provided. The [int option option] indicates subclasses whose hint has
+      the given priority. *)
+  cl_projs : (name * (direction * int option) option * constant option) list;
 }
 
 type instance
@@ -55,15 +55,16 @@ val add_inductive_class : inductive -> unit
 
 val new_instance : typeclass -> int option -> bool -> global_reference -> instance
 val add_instance : instance -> unit
+val remove_instance : instance -> unit
 
-val class_info : global_reference -> typeclass (* raises a UserError if not a class *)
+val class_info : global_reference -> typeclass (** raises a UserError if not a class *)
 
 
-(* These raise a UserError if not a class. *)
+(** These raise a UserError if not a class. *)
 val dest_class_app : env -> constr -> typeclass * constr list
 
-(* Just return None if not a class *)
-val class_of_constr : constr -> typeclass option
+(** Just return None if not a class *)
+val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option
   
 val instance_impl : instance -> global_reference
 
@@ -72,14 +73,13 @@ val is_instance : global_reference -> bool
 
 val is_implicit_arg : hole_kind -> bool
 
-(* Returns the term and type for the given instance of the parameters and fields
+(** Returns the term and type for the given instance of the parameters and fields
    of the type class. *)
 
 val instance_constructor : typeclass -> constr list -> constr option * types
 
-(* Use evar_extra for marking resolvable evars. *)
-val bool_in : bool -> Dyn.t
-val bool_out : Dyn.t -> bool
+(** Resolvability.
+    Only undefined evars could be marked or checked for resolvability. *)
 
 val is_resolvable : evar_info -> bool
 val mark_unresolvable : evar_info -> evar_info
@@ -90,11 +90,26 @@ 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_set_typeclass_transparency : (evaluable_global_reference -> bool -> unit) -> unit
-val set_typeclass_transparency : evaluable_global_reference -> bool -> unit
+val register_set_typeclass_transparency : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) -> unit
+val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit
 
-val register_add_instance_hint : (global_reference -> int option -> unit) -> unit
-val add_instance_hint : global_reference -> int option -> unit
+val register_classes_transparent_state : (unit -> transparent_state) -> unit
+val classes_transparent_state : unit -> transparent_state
+
+val register_add_instance_hint : (constr -> bool (* local? *) -> int option -> unit) -> unit
+val register_remove_instance_hint : (global_reference -> unit) -> unit
+val add_instance_hint : constr -> bool -> int option -> unit
+val remove_instance_hint : global_reference -> 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
+
+val declare_instance : int option -> bool -> global_reference -> unit
+
+
+(** Build the subinstances hints for a given typeclass object.
+    check tells if we should check for existence of the 
+    subinstances and add only the missing ones. *)
+
+val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) ->
+  (int option * constr) list
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index 62941a76..ab7bb9dc 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses_errors.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Decl_kinds
@@ -18,6 +16,7 @@ open Environ
 open Nametab
 open Mod_subst
 open Topconstr
+open Compat
 open Util
 open Libnames
 (*i*)
@@ -47,7 +46,7 @@ let unsatisfiable_constraints env evd ev =
       raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
   | Some ev ->
       let loc, kind = Evd.evar_source ev evd in
-	raise (Stdpp.Exc_located (loc, TypeClassError
+	raise (Loc.Exc_located (loc, TypeClassError
 	  (env, UnsatisfiableConstraints (evd, Some (ev, kind)))))
 
 let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m))
@@ -55,5 +54,5 @@ let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstan
 let rec unsatisfiable_exception exn =
   match exn with
   | TypeClassError (_, UnsatisfiableConstraints _) -> true
-  | Stdpp.Exc_located(_, e) -> unsatisfiable_exception e
+  | Loc.Exc_located(_, e) -> unsatisfiable_exception e
   | _ -> false
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index a763a80b..79f0678f 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses_errors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Decl_kinds
 open Term
@@ -20,16 +17,15 @@ open Mod_subst
 open Topconstr
 open Util
 open Libnames
-(*i*)
 
 type contexts = Parameters | Properties
 
 type typeclass_error =
   | NotAClass of constr
-  | UnboundMethod of global_reference * identifier located (* Class name, method *)
+  | 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 *)
+  | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 80db26a4..efcdff9d 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
@@ -19,6 +17,7 @@ open Inductive
 open Inductiveops
 open Typeops
 open Evd
+open Arguments_renaming
 
 let meta_type evd mv =
   let ty =
@@ -35,6 +34,14 @@ 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_type_judgment env evdref j =
+  match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with
+    | Sort s -> {utj_val = j.uj_val; utj_type = s }
+    | Evar ev ->
+        let (evd,s) = Evarutil.define_evar_as_sort !evdref ev in
+        evdref := evd; { utj_val = j.uj_val; utj_type = s }
+    | _ -> error_not_type env j
+
 let e_judge_of_apply env evdref funj argjv =
   let rec apply_rec n typ = function
   | [] ->
@@ -47,29 +54,82 @@ let e_judge_of_apply env evdref funj argjv =
 	   apply_rec (n+1) (subst1 hj.uj_val c2) restjl
 	 else
 	   error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv
+      | Evar ev ->
+	  let (evd',t) = Evarutil.define_evar_as_product !evdref ev in
+          evdref := evd';
+          let (_,_,c2) = destProd t in
+	  apply_rec (n+1) (subst1 hj.uj_val c2) restjl
       | _ ->
 	  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) =
+let e_check_branch_types env evdref ind 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)
+      error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
   done
 
+let rec max_sort l =
+  if List.mem InType l then InType else
+  if List.mem InSet l then InSet else InProp
+
+let e_is_correct_arity env evdref c pj ind specif params =
+  let arsign = make_arity_signature env true (make_ind_family (ind,params)) in
+  let allowed_sorts = elim_sorts specif in
+  let error () = error_elim_arity env ind allowed_sorts c pj None in
+  let rec srec env pt ar =
+    let pt' = whd_betadeltaiota env !evdref pt in
+    match kind_of_term pt', ar with
+    | Prod (na1,a1,t), (_,None,a1')::ar' ->
+        if not (Evarconv.e_cumul env evdref a1 a1') then error ();
+        srec (push_rel (na1,None,a1) env) t ar'
+    | Sort s, [] ->
+        if not (List.mem (family_of_sort s) allowed_sorts) then error ()
+    | Evar (ev,_), [] ->
+        let s = Termops.new_sort_in_family (max_sort allowed_sorts) in
+        evdref := Evd.define ev (mkSort s) !evdref
+    | _, (_,Some _,_ as d)::ar' ->
+        srec (push_rel d env) (lift 1 pt') ar'
+    | _ ->
+        error ()
+  in
+  srec env pj.uj_type (List.rev arsign)
+
+let e_type_case_branches env evdref (ind,largs) pj c =
+  let specif = lookup_mind_specif env ind in
+  let nparams = inductive_params specif in
+  let (params,realargs) = list_chop nparams largs in
+  let p = pj.uj_val in
+  let univ = e_is_correct_arity env evdref c pj ind specif params in
+  let lc = build_branches_type ind specif params p in
+  let n = (snd specif).Declarations.mind_nrealargs_ctxt in
+  let ty =
+    whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
+  (lc, ty, univ)
+
 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);
+  let (bty,rslty,univ) = e_type_case_branches env evdref indspec pj cj.uj_val in
+  e_check_branch_types env evdref (fst indspec) cj (lfj,bty);
   { uj_val  = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
     uj_type = rslty }
 
+let check_allowed_sort env sigma ind c p =
+  let pj = Retyping.get_judgment_of env sigma p in
+  let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in
+  let specif = Global.lookup_inductive ind in
+  let sorts = elim_sorts specif in
+  if not (List.exists ((=) ksort) sorts) then
+    let s = inductive_sort_family (snd specif) in
+    error_elim_arity env ind sorts c pj
+      (Some(ksort,s,error_elim_explain ksort s))
+
 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
@@ -100,13 +160,13 @@ let rec execute env evdref cstr =
         judge_of_variable env id
 
     | Const c ->
-        make_judge cstr (type_of_constant env c)
+        make_judge cstr (rename_type_of_constant env c)
 
     | Ind ind ->
-	make_judge cstr (type_of_inductive env ind)
+	make_judge cstr (rename_type_of_inductive env ind)
 
     | Construct cstruct ->
-	make_judge cstr (type_of_constructor env cstruct)
+	make_judge cstr (rename_type_of_constructor env cstruct)
 
     | Case (ci,p,c,lf) ->
         let cj = execute env evdref c in
@@ -153,23 +213,23 @@ let rec execute env evdref cstr =
 
     | Lambda (name,c1,c2) ->
         let j = execute env evdref c1 in
-	let var = type_judgment env j in
+	let var = e_type_judgment env evdref j in
 	let env1 = push_rel (name,None,var.utj_val) env in
         let j' = execute env1 evdref c2 in
         judge_of_abstraction env1 name var j'
 
     | Prod (name,c1,c2) ->
         let j = execute env evdref c1 in
-        let varj = type_judgment env j in
+        let varj = e_type_judgment env evdref j in
 	let env1 = push_rel (name,None,varj.utj_val) env in
         let j' = execute env1 evdref c2 in
-        let varj' = type_judgment env1 j' in
+        let varj' = e_type_judgment env1 evdref j' in
 	judge_of_product env name varj varj'
 
      | LetIn (name,c1,c2,c3) ->
         let j1 = execute env evdref c1 in
         let j2 = execute env evdref c2 in
-        let j2 = type_judgment env j2 in
+        let j2 = e_type_judgment env evdref 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 evdref c3 in
@@ -178,7 +238,7 @@ let rec execute env evdref cstr =
     | Cast (c,k,t) ->
         let cj = execute env evdref c in
         let tj = execute env evdref t in
-	let tj = type_judgment env tj in
+	let tj = e_type_judgment env evdref tj in
         e_judge_of_cast env evdref cj k tj
 
 and execute_recdef env evdref (names,lar,vdef) =
@@ -192,8 +252,6 @@ and execute_recdef env evdref (names,lar,vdef) =
 
 and execute_array env evdref = Array.map (execute env evdref)
 
-and execute_list env evdref = List.map (execute env evdref)
-
 let check env evd c t =
   let evdref = ref evd in
   let j = execute env evdref c in
@@ -211,15 +269,23 @@ let type_of env evd c =
 (* 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
+  let evdref = ref evd in
+  let j = execute env evdref c in
+  let a = e_type_judgment env evdref j in
   a.utj_type
 
 (* Try to solve the existential variables by typing *)
 
+let e_type_of env evd c =
+  let evdref = ref evd in
+  let j = execute env evdref c in
+  (* side-effect on evdref *)
+  !evdref, Termops.refresh_universes j.uj_type
+
 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
-  
+  !evdref, nf_evar !evdref c
+
+let _ = Evarconv.set_solve_evars solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 07cb7d59..224fd995 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -1,31 +1,38 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
+open Names
 open Term
 open Environ
 open Evd
-(*i*)
 
-(* This module provides the typing machine with existential variables
+(** This module provides the typing machine with existential variables
    (but without universes). *)
 
-(* Typecheck a term and return its type *)
+(** Typecheck a term and return its type *)
 val type_of : env -> evar_map -> constr -> types
-(* Typecheck a type and return its sort *)
+
+(** Typecheck a term and return its type + updated evars *)
+val e_type_of : env -> evar_map -> constr -> evar_map * 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
 
-(* Returns the instantiated type of a metavariable *)
+(** 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
+(** Solve existential variables using typing *)
+val solve_evars : env -> evar_map -> constr -> evar_map * constr
+
+(** Raise an error message if incorrect elimination for this inductive *)
+(** (first constr is term to match, second is return predicate) *)
+val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr ->
+  unit
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 7aa2272d..e6fa6eec 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unification.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,8 +18,7 @@ open Environ
 open Evd
 open Reduction
 open Reductionops
-open Rawterm
-open Pattern
+open Glob_term
 open Evarutil
 open Pretype_errors
 open Retyping
@@ -51,7 +48,7 @@ let abstract_scheme env c l lname_typ =
    are unclear...
        if occur_meta ta then error "cannot find a type for the generalisation"
        else *) if occur_meta a then mkLambda_name env (na,ta,t)
-       else mkLambda_name env (na,ta,subst_term_occ locc a t))
+       else mkLambda_name env (na,ta,subst_closed_term_occ locc a t))
     c
     (List.rev l)
     lname_typ
@@ -66,6 +63,19 @@ let abstract_list_all env evd typ c l =
   with UserError _ | Type_errors.TypeError _ ->
     error_cannot_find_well_typed_abstraction env evd p l
 
+let set_occurrences_of_last_arg args =
+  Some all_occurrences :: List.tl (array_map_to_list (fun _ -> None) args)
+
+let abstract_list_all_with_dependencies env evd typ c l =
+  let evd,ev = new_evar evd env typ in
+  let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
+  let argoccs = set_occurrences_of_last_arg (snd ev') in
+  let evd,b =
+    Evarconv.second_order_matching empty_transparent_state
+      env evd ev' argoccs c in
+  if b then nf_evar evd (existential_value evd (destEvar ev))
+  else error "Cannot find a well-typed abstraction."
+
 (**)
 
 (* A refinement of [conv_pb]: the integers tells how many arguments
@@ -73,23 +83,16 @@ let abstract_list_all env evd typ c l =
    is non zero, steps of eta-expansion will be allowed
 *)
 
-type conv_pb_up_to_eta = Cumul | ConvUnderApp of int * int
-
-let topconv = ConvUnderApp (0,0)
-let of_conv_pb = function CONV -> topconv | CUMUL -> Cumul
-let conv_pb_of = function ConvUnderApp _ -> CONV | Cumul -> CUMUL
-let prod_pb = function ConvUnderApp _ -> topconv | pb -> pb
-
 let opp_status = function
   | IsSuperType -> IsSubType
   | IsSubType -> IsSuperType
-  | ConvUpToEta _ | UserGiven as x -> x
+  | Conv -> Conv
 
 let add_type_status (x,y) = ((x,TypeNotProcessed),(y,TypeNotProcessed))
 
 let extract_instance_status = function
-  | Cumul -> add_type_status (IsSubType, IsSuperType)
-  | ConvUnderApp (n1,n2) -> add_type_status (ConvUpToEta n1, ConvUpToEta n2)
+  | CUMUL -> add_type_status (IsSubType, IsSuperType)
+  | CONV -> add_type_status (Conv, Conv)
 
 let rec assoc_pair x = function
     [] -> raise Not_found
@@ -110,7 +113,7 @@ let pose_all_metas_as_evars env evd t =
         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;
+        evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
         ev)
   | _ ->
       map_constr aux t in
@@ -121,15 +124,15 @@ let pose_all_metas_as_evars env evd t =
 let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) =
   match kind_of_term f with
     | Meta k ->
-	let 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
+	let sigma,c = pose_all_metas_as_evars env sigma c in
+	let c = solve_pattern_eqn env l c in
+	let pb = (Conv,TypeNotProcessed) in
 	  if noccur_between 1 nb c then
             sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst
-	  else error_cannot_unify_local env sigma (mkApp (f, l),c,c)
+	  else error_cannot_unify_local env sigma (applist (f, l),c,c)
     | Evar ev ->
 	let sigma,c = pose_all_metas_as_evars env sigma c in
-	sigma,metasubst,(ev,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
+	sigma,metasubst,(env,ev,solve_pattern_eqn env l c)::evarsubst
     | _ -> assert false
 
 let push d (env,n) = (push_rel_assum d env,n+1)
@@ -161,46 +164,172 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       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 }
 
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "pattern-unification for existential variables in tactics";
+      optkey   = ["Tactic";"Pattern";"Unification"];
+      optread  = (fun () -> !global_evars_pattern_unification_flag);
+      optwrite = (:=) global_evars_pattern_unification_flag }
+
 type unify_flags = {
   modulo_conv_on_closed_terms : Names.transparent_state option;
-  use_metas_eagerly : bool;
+    (* What this flag controls was activated with all constants transparent, *)
+    (* even for auto, since Coq V5.10 *)
+
+  use_metas_eagerly_in_conv_on_closed_terms : bool;
+    (* This refinement of the conversion on closed terms is activable *)
+    (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *)
+
   modulo_delta : Names.transparent_state;
+    (* This controls which constant are unfoldable; this is on for apply *)
+    (* (but not simple apply) since Feb 2008 for 8.2 *)
+
+  modulo_delta_types : Names.transparent_state;
+
+  check_applied_meta_types : bool;
+    (* This controls whether meta's applied to arguments have their *)
+    (* type unified with the type of their instance *)
+
   resolve_evars : bool;
-  use_evars_pattern_unification : bool
+    (* This says if type classes instances resolution must be used to infer *)
+    (* the remaining evars *)
+
+  use_pattern_unification : bool;
+    (* This says if type classes instances resolution must be used to infer *)
+    (* the remaining evars *)
+
+  use_meta_bound_pattern_unification : bool;
+    (* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *)
+    (* This allows for instance to unify "forall x:A, B(x)" with "A' -> B'" *)
+    (* This was on for all tactics, including auto, since Sep 2006 for 8.1 *)
+
+  frozen_evars : ExistentialSet.t;
+    (* Evars of this set are considered axioms and never instantiated *)
+    (* Useful e.g. for autorewrite *)
+
+  restrict_conv_on_strict_subterms : bool;
+    (* No conversion at the root of the term; potentially useful for rewrite *)
+
+  modulo_betaiota : bool;
+    (* Support betaiota in the reduction *)
+    (* Note that zeta is always used *)
+
+  modulo_eta : bool;
+    (* Support eta in the reduction *)
+
+  allow_K_in_toplevel_higher_order_unification : bool
+    (* This is used only in second/higher order unification when looking for *)
+    (* subterms (rewrite and elim) *)
 }
 
+(* Default flag for unifying a type against a type (e.g. apply) *)
+(* We set all conversion flags *)
 let default_unify_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
   modulo_delta = full_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
   resolve_evars = false;
-  use_evars_pattern_unification = true;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = true;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
+      (* in fact useless when not used in w_unify_to_subterm_list *)
 }
 
+(* Default flag for the "simple apply" version of unification of a *)
+(* type against a type (e.g. apply) *)
+(* We set only the flags available at the time the new "apply" extends *)
+(* out of "simple apply" *)
 let default_no_delta_unify_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
+  resolve_evars = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
+}
+
+(* Default flags for looking for subterms in elimination tactics *)
+(* Not used in practice at the current date, to the exception of *)
+(* allow_K) because only closed terms are involved in *)
+(* induction/destruct/case/elim and w_unify_to_subterm_list does not *)
+(* call w_unify for induction/destruct/case/elim  (13/6/2011) *)
+let elim_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  modulo_delta = full_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
+  resolve_evars = false;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = true
+}
+
+let elim_no_delta_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
   modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = false;
-  use_evars_pattern_unification = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = true
 }
 
+let set_no_head_reduction flags =
+  { flags with restrict_conv_on_strict_subterms = true }
+
 let use_evars_pattern_unification flags =
-  !global_evars_pattern_unification_flag && flags.use_evars_pattern_unification
+  !global_evars_pattern_unification_flag && flags.use_pattern_unification
   && Flags.version_strictly_greater Flags.V8_2
 
+let use_metas_pattern_unification flags nb l =
+  !global_evars_pattern_unification_flag && flags.use_pattern_unification
+  || (Flags.version_less_or_equal Flags.V8_3 || 
+      flags.use_meta_bound_pattern_unification) &&
+     array_for_all (fun c -> isRel c && destRel c <= nb) l
+
 let expand_key env = function
   | Some (ConstKey cst) -> constant_opt_value env cst
   | Some (VarKey id) -> (try named_body id env with Not_found -> None)
   | Some (RelKey _) -> None
   | None -> None
 
-let key_of flags f =
+let subterm_restriction is_subterm flags =
+  not is_subterm && flags.restrict_conv_on_strict_subterms
+
+let key_of b flags f =
+  if subterm_restriction b flags then None else
   match kind_of_term f with
   | Const cst when is_transparent (ConstKey cst) &&
         Cpred.mem cst (snd flags.modulo_delta) ->
@@ -219,20 +348,51 @@ let oracle_order env cf1 cf2 =
   | Some k1 ->
       match cf2 with
       | None -> Some true
-      | Some k2 -> Some (Conv_oracle.oracle_order k1 k2)
+      | Some k2 -> Some (Conv_oracle.oracle_order false k1 k2)
+
+let do_reduce ts (env, nb) sigma c =
+  let (t, stack') = whd_betaiota_deltazeta_for_iota_state ts env sigma (c, empty_stack) in
+  let l = list_of_stack stack' in
+    applist (t, l)
+
+let use_full_betaiota flags =
+  flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3
+
+let isAllowedEvar flags c = match kind_of_term c with
+  | Evar (evk,_) -> not (ExistentialSet.mem evk flags.frozen_evars)
+  | _ -> false
+
+let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN =
+  match subst_defined_metas metasubst tyM with
+  | None -> ()
+  | Some m ->
+  match subst_defined_metas metasubst tyN with
+  | None -> ()
+  | Some n ->
+      if not (is_trans_fconv CONV full_transparent_state env sigma m n)
+         && is_ground_term sigma m && is_ground_term sigma n
+      then
+	error_cannot_unify env sigma (m,n)
 
 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 rec unirec_rec (curenv,nb as curenvnb) pb b wt ((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 ->
+            if k1 = k2 then substn else
 	    let stM,stN = extract_instance_status pb in
-	    if k2 < k1
-	    then sigma,(k1,cN,stN)::metasubst,evarsubst
-	    else if k1 = k2 then substn
+            if wt && flags.check_applied_meta_types then
+              (let tyM = Typing.meta_type sigma k1 in
+               let tyN = Typing.meta_type sigma k2 in
+               check_compatibility curenv substn tyM tyN);
+	    if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst
 	    else sigma,(k2,cM,stM)::metasubst,evarsubst
 	| Meta k, _ when not (dependent cM cN) ->
+            if wt && flags.check_applied_meta_types then
+              (let tyM = Typing.meta_type sigma k in
+               let tyN = get_type_of curenv sigma cN in
+               check_compatibility curenv substn tyM tyN);
 	    (* Here we check that [cN] does not contain any local variables *)
 	    if nb = 0 then
               sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
@@ -242,6 +402,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
               evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cN)
 	| _, Meta k when not (dependent cN cM) ->
+            if wt && flags.check_applied_meta_types then
+              (let tyM = get_type_of curenv sigma cM in
+               let tyN = Typing.meta_type sigma k in
+               check_compatibility curenv substn tyM tyN);
 	    (* Here we check that [cM] does not contain any local variables *)
 	    if nb = 0 then
               (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst)
@@ -250,65 +414,123 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
               (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst,
               evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cM)
-	| Evar ev, _ -> sigma,metasubst,((ev,cN)::evarsubst)
-	| _, Evar ev -> sigma,metasubst,((ev,cM)::evarsubst)
+	| Evar (evk,_ as ev), _
+            when not (ExistentialSet.mem evk flags.frozen_evars) ->
+	    let cmvars = free_rels cM and cnvars = free_rels cN in
+	      if Intset.subset cnvars cmvars then
+		sigma,metasubst,((curenv,ev,cN)::evarsubst)
+	      else error_cannot_unify_local curenv sigma (m,n,cN)
+	| _, Evar (evk,_ as ev)
+            when not (ExistentialSet.mem evk flags.frozen_evars) ->
+	    let cmvars = free_rels cM and cnvars = free_rels cN in
+	      if Intset.subset cmvars cnvars then
+		sigma,metasubst,((curenv,ev,cM)::evarsubst)
+	      else error_cannot_unify_local curenv sigma (m,n,cN)
+	| Sort s1, Sort s2 ->
+	    (try 
+	       let sigma' = 
+		 if cv_pb = CUMUL 
+		 then Evd.set_leq_sort sigma s1 s2 
+		 else Evd.set_eq_sort sigma s1 s2 
+	       in (sigma', metasubst, evarsubst)
+	     with _ -> error_cannot_unify curenv sigma (m,n))
+	      
 	| 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
+	    unirec_rec (push (na,t1) curenvnb) CONV true wt
+	      (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2
 	| Prod (na,t1,c1), Prod (_,t2,c2) ->
-	    unirec_rec (push (na,t1) curenvnb) (prod_pb pb) true
-	      (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)
+	    unirec_rec (push (na,t1) curenvnb) pb true false
+	      (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2
+	| LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b wt substn (subst1 a c) cN
+	| _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b wt substn cM (subst1 a c)
+
+        (* eta-expansion *)
+	| Lambda (na,t1,c1), _ when flags.modulo_eta ->
+	    unirec_rec (push (na,t1) curenvnb) CONV true wt substn
+	      c1 (mkApp (lift 1 cN,[|mkRel 1|]))
+	| _, Lambda (na,t2,c2) when flags.modulo_eta ->
+	    unirec_rec (push (na,t2) curenvnb) CONV true wt substn
+	      (mkApp (lift 1 cM,[|mkRel 1|])) c2
 
 	| 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 || use_evars_pattern_unification flags && isEvar f1) &
-	    is_unification_pattern curenvnb f1 l1 cN &
-	    not (dependent f1 cN) ->
-	      solve_pattern_eqn_array curenvnb f1 l1 cN substn
+            (try 
+	       array_fold_left2 (unirec_rec curenvnb CONV true wt)
+		 (unirec_rec curenvnb CONV true false
+		    (unirec_rec curenvnb CONV true false substn p1 p2) c1 c2)
+                 cl1 cl2
+	     with ex when precatchable_exception ex ->
+	       reduce curenvnb pb b wt substn cM cN)
+
+	| App (f1,l1), _ when 
+	    (isMeta f1 && use_metas_pattern_unification flags nb l1
+            || use_evars_pattern_unification flags && isAllowedEvar flags f1) ->
+            (match
+                is_unification_pattern curenvnb sigma f1 (Array.to_list l1) cN
+             with
+             | None ->
+                 (match kind_of_term cN with
+                 | App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
+                 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN)
+             | Some l ->
+                 solve_pattern_eqn_array curenvnb f1 l cN substn)
 
 	| _, App (f2,l2) when
-	    (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 f2 l2 cM substn
+	    (isMeta f2 && use_metas_pattern_unification flags nb l2
+            || use_evars_pattern_unification flags && isAllowedEvar flags f2) ->
+            (match
+                is_unification_pattern curenvnb sigma f2 (Array.to_list l2) cM
+             with
+             | None ->
+                 (match kind_of_term cM with
+                 | App (f1,l1) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
+                 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN)
+             | Some l ->
+	         solve_pattern_eqn_array curenvnb f2 l cM substn)
 
 	| App (f1,l1), App (f2,l2) ->
-	    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
-		      (f1, l1, appvect (f2,extras), restl2)
-		    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 ->
-		  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)
+            unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
 
 	| _ ->
-	    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
+            unify_not_same_head curenvnb pb b wt substn cM cN
 
-  and expand (curenv,_ as curenvnb) pb b (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 =
+  and unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 =
+    try
+      let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in
+      array_fold_left2 (unirec_rec curenvnb CONV true false)
+	(unirec_rec curenvnb CONV true true substn f1 f2) l1 l2
+    with ex when precatchable_exception ex ->
+    try reduce curenvnb pb b false substn cM cN
+    with ex when precatchable_exception ex ->
+    try expand curenvnb pb b false substn cM f1 l1 cN f2 l2
+    with ex when precatchable_exception ex ->
+    canonical_projections curenvnb pb b cM cN substn
+
+  and unify_not_same_head curenvnb pb b wt substn cM cN =
+    try canonical_projections curenvnb pb b cM cN substn
+    with ex when precatchable_exception ex ->
+    if constr_cmp cv_pb cM cN then substn else
+    try reduce curenvnb pb b wt substn cM cN
+    with ex when precatchable_exception ex ->
+    let (f1,l1) =
+      match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
+    let (f2,l2) =
+      match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
+    expand curenvnb pb b wt substn cM f1 l1 cN f2 l2
+
+  and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN =
+    if use_full_betaiota flags && not (subterm_restriction b flags) then
+      let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in
+	if not (eq_constr cM cM') then
+	  unirec_rec curenvnb pb b wt substn cM' cN
+	else
+	  let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in
+	    if not (eq_constr cN cN') then
+	      unirec_rec curenvnb pb b wt substn cM cN'
+	    else error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    else
+      error_cannot_unify (fst curenvnb) sigma (cM,cN)
+	    
+  and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 =
 
     if
       (* Try full conversion on meta-free terms. *)
@@ -323,17 +545,19 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
 	 (it is used by apply and rewrite); it might now be redundant
 	 with the support for delta-expansion (which is used
 	 essentially for apply)... *)
+      not (subterm_restriction b flags) &&
       match flags.modulo_conv_on_closed_terms with
       | None -> false
       | Some convflags ->
-      let subst = if flags.use_metas_eagerly then metasubst else ms in
+      let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in
       match subst_defined_metas subst cM with
       | None -> (* some undefined Metas in cM *) false
       | 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
+          (* No subterm restriction there, too much incompatibilities *)
+	  if is_trans_fconv pb convflags env sigma m1 n1
 	  then true else
 	    if is_ground_term sigma m1 && is_ground_term sigma n1 then
 	      error_cannot_unify curenv sigma (cM,cN)
@@ -341,55 +565,52 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
     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
+      let cf1 = key_of b flags f1 and cf2 = key_of b flags f2 in
 	match oracle_order curenv cf1 cf2 with
 	| None -> error_cannot_unify curenv sigma (cM,cN)
 	| Some true ->
 	    (match expand_key curenv cf1 with
 	    | Some c ->
-		unirec_rec curenvnb pb b substn
+		unirec_rec curenvnb pb b wt substn
                   (whd_betaiotazeta sigma (mkApp(c,l1))) cN
 	    | None ->
 		(match expand_key curenv cf2 with
 		| Some c ->
-		    unirec_rec curenvnb pb b substn cM
+		    unirec_rec curenvnb pb b wt substn cM
                       (whd_betaiotazeta sigma (mkApp(c,l2)))
 		| None ->
 		    error_cannot_unify curenv sigma (cM,cN)))
 	| Some false ->
 	    (match expand_key curenv cf2 with
 	    | Some c ->
-		unirec_rec curenvnb pb b substn cM
+		unirec_rec curenvnb pb b wt substn cM
                   (whd_betaiotazeta sigma (mkApp(c,l2)))
 	    | None ->
 		(match expand_key curenv cf1 with
 		| Some c ->
-		    unirec_rec curenvnb pb b substn
+		    unirec_rec curenvnb pb b wt substn
                       (whd_betaiotazeta sigma (mkApp(c,l1))) cN
 		| None ->
 		    error_cannot_unify curenv sigma (cM,cN)))
-    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
+	  if is_open_canonical_projection env sigma f1l1 then
 	    let f2l2 = decompose_app cN in
 	      solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 substn
 	  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
+      if flags.modulo_conv_on_closed_terms = None ||
+         subterm_restriction b flags 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
+	      if is_open_canonical_projection env sigma f2l2 then
 		let f1l1 = decompose_app cM in
 		  solve_canonical_projection curenvnb pb b cN f2l2 cM f1l1 substn
 	      else error_cannot_unify (fst curenvnb) sigma (cM,cN)
@@ -413,20 +634,20 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
       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))
+    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u))
       (evd,ms,es) us2 us in
-    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u))
+    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u))
       substn params1 params in
-    let substn = unilist2 (unirec_rec curenvnb pb b) substn ts ts1 in
-      unirec_rec curenvnb pb b substn c1 (applist (c,(List.rev ks)))
+    let substn = unilist2 (unirec_rec curenvnb pb b false) substn ts ts1 in
+      unirec_rec curenvnb pb b false substn c1 (applist (c,(List.rev ks)))
 
   in
-  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 
+  let evd = sigma in
+    if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n
+        || subterm_restriction conv_at_top flags then false
       else if (match flags.modulo_conv_on_closed_terms with
-      | Some 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 
+      | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n
+      | _ -> constr_cmp cv_pb m n) then true
       else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
             | Some (cv_id, cv_k), (dl_id, dl_k) ->
                 Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k
@@ -434,74 +655,67 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
                 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
+    else unirec_rec (env,0) cv_pb conv_at_top false subst m n
 
 let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
 
 let left = true
 let right = false
 
-let pop k = if k=0 then 0 else k-1
-
-let rec unify_with_eta keptside flags env sigma k1 k2 c1 c2 =
-  (* Reason up to limited eta-expansion: ci is allowed to start with ki lam *)
-  (* Question: try whd_betadeltaiota on ci if ki>0 ? *)
+let rec unify_with_eta keptside flags env sigma c1 c2 =
+(* Question: try whd_betadeltaiota on ci if not two lambdas? *)
   match kind_of_term c1, kind_of_term c2 with
   | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
-      let env' = push_rel_assum (na,t1) env in
-      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,(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)
-	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)
-	(mkApp (lift 1 c1,[|mkRel 1|])) c2'
+    let env' = push_rel_assum (na,t1) env in
+    let sigma,metas,evars = unify_0 env sigma CONV flags t1 t2 in
+    let side,(sigma,metas',evars') =
+      unify_with_eta keptside flags env' sigma c1' c2'
+    in (side,(sigma,metas@metas',evars@evars'))
+  | (Lambda (na,t,c1'),_)->
+    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
+      c1' (mkApp (lift 1 c2,[|mkRel 1|]))
+  | (_,Lambda (na,t,c2')) ->
+    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
+      (mkApp (lift 1 c1,[|mkRel 1|])) c2'
   | _ ->
-      (keptside,ConvUpToEta(min k1 k2),
-       unify_0 env sigma topconv flags c1 c2)
-
+    (keptside,unify_0 env sigma CONV flags c1 c2)
+    
 (* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'],
    we now compute the problem on [u =? u'] and decide which of u or u' is kept
 
    Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically
    in the case u' <= ?n <= u)
  *)
-
+    
 let merge_instances env sigma flags st1 st2 c1 c2 =
   match (opp_status st1, st2) with
-  | (UserGiven, ConvUpToEta n2) ->
-      unify_with_eta left flags env sigma 0 n2 c1 c2
-  | (ConvUpToEta n1, UserGiven) ->
-      unify_with_eta right flags env sigma n1 0 c1 c2
-  | (ConvUpToEta n1, ConvUpToEta n2) ->
+  | (Conv, Conv) ->
       let side = left (* arbitrary choice, but agrees with compatibility *) in
-      unify_with_eta side flags env sigma n1 n2 c1 c2
-  | ((IsSubType | ConvUpToEta _ | UserGiven as oppst1),
-     (IsSubType | ConvUpToEta _ | UserGiven)) ->
-      let res = unify_0 env sigma Cumul flags c2 c1 in
+      let (side,res) = unify_with_eta side flags env sigma c1 c2 in
+      (side,Conv,res)
+  | ((IsSubType | Conv as oppst1),
+     (IsSubType | Conv)) ->
+    let res = unify_0 env sigma CUMUL flags c2 c1 in
       if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
-      else if st2=IsSubType or st1=UserGiven then (left, st1, res)
+      else if st2=IsSubType then (left, st1, res)
       else (right, st2, res)
-  | ((IsSuperType | ConvUpToEta _ | UserGiven as oppst1),
-     (IsSuperType | ConvUpToEta _ | UserGiven)) ->
-      let res = unify_0 env sigma Cumul flags c1 c2 in
+  | ((IsSuperType | Conv as oppst1),
+     (IsSuperType | Conv)) ->
+    let res = unify_0 env sigma CUMUL flags c1 c2 in
       if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
-      else if st2=IsSuperType or st1=UserGiven then (left, st1, res)
+      else if st2=IsSuperType then (left, st1, res)
       else (right, st2, res)
   | (IsSuperType,IsSubType) ->
-      (try (left, IsSubType, unify_0 env sigma Cumul flags c2 c1)
-       with _ -> (right, IsSubType, unify_0 env sigma Cumul flags c1 c2))
+    (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
+     with _ -> (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
   | (IsSubType,IsSuperType) ->
-      (try (left, IsSuperType, unify_0 env sigma Cumul flags c1 c2)
-       with _ -> (right, IsSuperType, unify_0 env sigma Cumul flags c2 c1))
-
+    (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
+     with _ -> (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1))
+    
 (* Unification
  *
  * Procedure:
@@ -557,18 +771,20 @@ let applyHead env evd n c  =
       (evd, c)
     else
       match kind_of_term (whd_betadeltaiota env evd cty) with
-        | Prod (_,c1,c2) ->
-            let (evd',evar) =
-	      Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in
-	    apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
-	| _ -> error "Apply_Head_Then"
+      | Prod (_,c1,c2) ->
+        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 evd c) evd
-
-let is_mimick_head f =
+    apprec n c (Typing.type_of env evd c) evd
+    
+let is_mimick_head ts f =
   match kind_of_term f with
-      (Const _|Var _|Rel _|Construct _|Ind _) -> true
-    | _ -> false
+  | Const c -> not (Closure.is_transparent_constant ts c)
+  | Var id -> not (Closure.is_transparent_variable ts id)
+  | (Rel _|Construct _|Ind _) -> true
+  | _ -> false
 
 let try_to_coerce env evd c cty tycon =
   let j = make_judge c cty in
@@ -580,14 +796,14 @@ let try_to_coerce env evd c cty tycon =
 let w_coerce_to_type env evd c cty mvty =
   let evd,mvty = pose_all_metas_as_evars env evd mvty in
   let tycon = mk_tycon_type mvty in
-  try try_to_coerce env evd c cty tycon
-  with e when precatchable_exception e ->
+    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
        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 evd cty in
-    try_to_coerce env evd c cty tycon
-
+      try_to_coerce env evd c cty tycon
+	  
 let w_coerce env evd mv c =
   let cty = get_type_of env evd c in
   let mvty = Typing.meta_type evd mv in
@@ -596,25 +812,17 @@ let w_coerce env evd mv c =
 let unify_to_type env sigma flags c status u =
   let c = refresh_universes c in
   let t = get_type_of env sigma c in
-  let t = Tacred.hnf_constr env sigma (nf_betaiota sigma (nf_meta sigma t)) in
-  let u = Tacred.hnf_constr env sigma u in
-    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 t = nf_betaiota sigma (nf_meta sigma t) in
+    unify_0 env sigma CUMUL flags t u
 
 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,[],[])
+  let mvty = nf_meta sigma mvty in
+    unify_to_type env sigma 
+      {flags with modulo_delta = flags.modulo_delta_types;
+	 modulo_conv_on_closed_terms = Some flags.modulo_delta_types;
+	 modulo_betaiota = true}
+      c status mvty
 
 (* Move metas that may need coercion at the end of the list of instances *)
 
@@ -628,8 +836,8 @@ let order_metas metas =
 
 (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *)
 
-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
+let solve_simple_evar_eqn ts env evd ev rhs =
+  let evd,b = solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) in
   if not b then error_cannot_unify env evd (mkEvar ev,rhs);
   Evarconv.consider_remaining_unif_problems env evd
 
@@ -642,28 +850,32 @@ let w_merge env with_types flags (evd,metas,evars) =
 
     (* Process evars *)
     match evars with
-    | ((evn,_ as ev),rhs)::evars' ->
-    	if is_defined_evar evd ev then
+    | (curenv,(evk,_ as ev),rhs)::evars' ->
+	if Evd.is_defined evd evk then
 	  let v = Evd.existential_value evd ev in
 	  let (evd,metas',evars'') =
-	    unify_0 env evd topconv flags rhs v in
+	    unify_0 curenv evd CONV flags rhs v in
 	  w_merge_rec evd (metas'@metas) (evars''@evars') eqns
     	else begin
+	  (* This can make rhs' ill-typed if metas are *)
           let rhs' = subst_meta_instances metas rhs in
           match kind_of_term rhs with
 	  | App (f,cl) when occur_meta rhs' ->
-	      if occur_evar evn rhs' then
-                error_occur_check env evd evn rhs';
-	      if is_mimick_head f then
-		let evd' = mimick_evar evd flags f (Array.length cl) evn in
-		  w_merge_rec evd' metas evars eqns
+	      if occur_evar evk rhs' then
+                error_occur_check curenv evd evk rhs';
+	      if is_mimick_head flags.modulo_delta f then
+		let evd' =
+		  mimick_undefined_evar evd flags f (Array.length cl) evk in
+		w_merge_rec evd' metas evars eqns
 	      else
-		let evd', rhs'' = pose_all_metas_as_evars env evd rhs' in
-	  	  w_merge_rec (solve_simple_evar_eqn env evd' ev rhs'')
-		    metas evars' eqns
+		let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
+		w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'')
+		  metas evars' eqns
+
           | _ ->
-	      w_merge_rec (solve_simple_evar_eqn env evd ev rhs')
-		metas evars' eqns
+	      let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
+		w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'')
+		  metas evars' eqns
 	end
     | [] ->
 
@@ -679,7 +891,8 @@ let w_merge env with_types flags (evd,metas,evars) =
               (* No coercion needed: delay the unification of types *)
 	      ((evd,c),([],[])),(mv,status,c)::eqns
 	  else
-	    ((evd,c),([],[])),eqns in
+	    ((evd,c),([],[])),eqns 
+	in
 	  if meta_defined evd mv then
 	    let {rebus=c'},(status',_) = meta_fvalue evd mv in
             let (take_left,st,(evd,metas',evars')) =
@@ -692,23 +905,30 @@ let w_merge env with_types flags (evd,metas,evars) =
               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
+	      w_merge_rec evd' (metas''@metas) evars'' eqns
     | [] ->
-
-    (* Process type eqns *)
-    match eqns with
-    | (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 evd sp in
+	(* Process type eqns *)
+	let rec process_eqns failures = function
+	  | (mv,status,c)::eqns ->
+              (match (try Inl (unify_type env evd flags mv status c)
+		      with e -> Inr e)
+	       with 
+	       | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns
+	       | Inl (evd,metas,evars) ->
+		   w_merge_rec evd metas evars (List.map fst failures @ eqns))
+	  | [] -> 
+	      (match failures with
+	       | [] -> evd
+	       | ((mv,status,c),e)::_ -> raise e)
+	in process_eqns [] eqns
+	      
+  and mimick_undefined_evar evd flags hdc nargs sp =
+    let ev = Evd.find_undefined evd sp in
     let sp_env = Global.env_of_context ev.evar_hyps in
     let (evd', c) = applyHead sp_env evd nargs hdc in
     let (evd'',mc,ec) =
-      unify_0 sp_env evd' Cumul flags
-        (Retyping.get_type_of sp_env evd' c) ev.evar_concl in
+      unify_0 sp_env evd' CUMUL flags
+        (get_type_of sp_env evd' c) ev.evar_concl in
     let evd''' = w_merge_rec evd'' mc ec [] in
     if evd' == evd'''
     then Evd.define sp c evd'''
@@ -733,33 +953,47 @@ let w_unify_meta_types env ?(flags=default_unify_flags) evd =
 
 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
+    unify_0_with_initial_metas subst true env CUMUL
       flags
-      (Retyping.get_type_of env sigma n)
-      (Retyping.get_type_of env sigma m)
+      (get_type_of env sigma n)
+      (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
+    unify_0_with_initial_metas subst true env CUMUL
       flags
-      (Retyping.get_type_of env sigma m)
-      (Retyping.get_type_of env sigma n)
+      (get_type_of env sigma m)
+      (get_type_of env sigma n)
   else subst
 
-let w_unify_core_0 env with_types cv_pb flags m n evd =
+let try_resolve_typeclasses env evd flags m n =
+  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_core_0 env evd with_types cv_pb flags m n =
   let (mc1,evd') = retract_coercible_metas evd in
   let (sigma,ms,es) = check_types env flags (evd,mc1,[]) m n in
   let subst2 =
-     unify_0_with_initial_metas (evd',ms,es) true env cv_pb flags m n
+     unify_0_with_initial_metas (evd',ms,es) false 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
+  try_resolve_typeclasses env evd flags m n
 
-let w_unify_0 env = w_unify_core_0 env false
-let w_typed_unify env = w_unify_core_0 env true
+let w_unify_0 env evd = w_unify_core_0 env evd false
+let w_typed_unify env evd = w_unify_core_0 env evd true
+
+let w_typed_unify_list env evd flags f1 l1 f2 l2 =
+  let flags' = { flags with resolve_evars = false } in
+  let f1,l1,f2,l2 = adjust_app_list_size f1 l1 f2 l2 in
+  let (mc1,evd') = retract_coercible_metas evd in
+  let subst =
+    List.fold_left2 (fun subst m n ->
+      unify_0_with_initial_metas subst true env CONV flags' m n) (evd',[],[])
+      (f1::l1) (f2::l2) in
+  let evd = w_merge env true flags subst in
+  try_resolve_typeclasses env evd flags (applist(f1,l1)) (applist(f2,l2))
 
 (* 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
@@ -777,12 +1011,12 @@ let iter_fail f a =
 (* Tries to find an instance of term [cl] in term [op].
    Unifies [cl] to every subterm of [op] until it finds a match.
    Fails if no match is found *)
-let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd =
+let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) =
   let rec matchrec cl =
     let cl = strip_outer_cast cl in
     (try
        if closed0 cl && not (isEvar cl)
-       then w_typed_unify env topconv flags op cl evd,cl
+       then w_typed_unify env evd CONV flags op cl,cl
        else error "Bound 1"
      with ex when precatchable_exception ex ->
        (match kind_of_term cl with
@@ -832,12 +1066,12 @@ let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd =
   in
   try matchrec cl
   with ex when precatchable_exception ex ->
-    raise (PretypeError (env,NoOccurrenceFound (op, None)))
+    raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
 
 (* 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 w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) =
   let return a b =
     let (evd,c as a) = a () in
       if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b
@@ -862,7 +1096,7 @@ let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd =
     let cl = strip_outer_cast cl in
       (bind
 	  (if closed0 cl
-	  then return (fun () -> w_typed_unify env topconv flags op cl evd,cl)
+	  then return (fun () -> w_typed_unify env evd CONV flags op cl,cl)
             else fail "Bound 1")
           (match kind_of_term cl with
 	    | App (f,args) ->
@@ -894,61 +1128,65 @@ let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd =
   in
   let res = matchrec cl [] in
   if res = [] then
-    raise (PretypeError (env,NoOccurrenceFound (op, None)))
+    raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
   else
     res
 
-let w_unify_to_subterm_list env flags allow_K hdmeta oplist t evd =
+let w_unify_to_subterm_list env evd flags hdmeta oplist t =
   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)
+	if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l)
 	else error_abstraction_over_meta env evd hdmeta (destMeta op)
       else if occur_meta_or_existential op then
         let (evd',cl) =
           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)
+	    w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
+	  with PretypeError (env,_,NoOccurrenceFound _) when
+              flags.allow_K_in_toplevel_higher_order_unification -> (evd,op)
         in
-	  if not allow_K && (* ensure we found a different instance *)
+	  if not flags.allow_K_in_toplevel_higher_order_unification &&
+            (* 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
+      else if flags.allow_K_in_toplevel_higher_order_unification or dependent op t
+      then
 	(evd,op::l)
       else
 	(* This is not up to delta ... *)
-	raise (PretypeError (env,NoOccurrenceFound (op, None))))
+	raise (PretypeError (env,evd,NoOccurrenceFound (op, None))))
     oplist
     (evd,[])
 
-let secondOrderAbstraction env flags allow_K typ (p, oplist) evd =
+let secondOrderAbstraction env evd flags typ (p, oplist) =
   (* Remove delta when looking for a subterm *)
   let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in
-  let (evd',cllist) =
-    w_unify_to_subterm_list env flags allow_K p oplist typ evd in
+  let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in
   let typp = Typing.meta_type evd' p in
   let pred = abstract_list_all env evd' typp typ cllist in
-  w_merge env false flags (evd',[p,pred,(ConvUpToEta 0,TypeProcessed)],[])
+  w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[])
+
+let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
+  let typp = Typing.meta_type evd p in
+  let pred = abstract_list_all_with_dependencies env evd typp typ oplist in
+  w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[])
+
+let secondOrderAbstractionAlgo dep =
+  if dep then secondOrderDependentAbstraction else secondOrderAbstraction
 
-let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
+let w_unify2 env evd flags dep cv_pb ty1 ty2 =
   let c1, oplist1 = whd_stack evd ty1 in
   let c2, oplist2 = whd_stack evd ty2 in
   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
-        (* Resume first order unification *)
-	w_unify_0 env cv_pb flags (nf_meta evd' ty1) ty2 evd'
+        secondOrderAbstractionAlgo dep env evd flags ty2 (p1,oplist1)
     | _, Meta p2 ->
         (* Find the predicate *)
-	let evd' =
-          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'
+        secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2)
     | _ -> error "w_unify2"
 
 (* The unique unification algorithm works like this: If the pattern is
@@ -971,8 +1209,7 @@ let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
    Before, second-order was used if the type of Meta(1) and [x:A]t was
    convertible and first-order otherwise. But if failed if e.g. the type of
    Meta(1) had meta-variables in it. *)
-let w_unify allow_K env cv_pb ?(flags=default_unify_flags) ty1 ty2 evd =
-  let cv_pb = of_conv_pb cv_pb in
+let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 =
   let hd1,l1 = whd_stack evd ty1 in
   let hd2,l2 = whd_stack evd ty2 in
     match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
@@ -980,22 +1217,27 @@ let w_unify allow_K env cv_pb ?(flags=default_unify_flags) ty1 ty2 evd =
       | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
 	  when List.length l1 = List.length l2 ->
 	  (try
-	      w_typed_unify env cv_pb flags ty1 ty2 evd
+	      w_typed_unify_list env evd flags hd1 l1 hd2 l2
 	    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)
+		w_unify2 env evd flags false cv_pb ty1 ty2
+	      with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e)
 
       (* Second order case *)
       | (Meta _, true, _, _ | _, _, Meta _, true) ->
 	  (try
-	      w_unify2 env flags allow_K cv_pb ty1 ty2 evd
-	    with PretypeError (env,NoOccurrenceFound _) as e -> raise e
+	      w_unify2 env evd flags false cv_pb ty1 ty2
+	    with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e
 	      | ex when precatchable_exception ex ->
 		  try
-		    w_typed_unify env cv_pb flags ty1 ty2 evd
+		    w_typed_unify_list env evd flags hd1 l1 hd2 l2
 		  with ex' when precatchable_exception ex' ->
-		    raise ex)
+                    (* Last chance, use pattern-matching with typed
+                       dependencies (done late for compatibility) *)
+	            try
+	              w_unify2 env evd flags true cv_pb ty1 ty2
+		    with ex' when precatchable_exception ex' ->
+		      raise ex)
 
       (* General case: try first order *)
-      | _ -> w_typed_unify env cv_pb flags ty1 ty2 evd
+      | _ -> w_typed_unify env evd cv_pb flags ty1 ty2
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 2f48081a..e4bca4d3 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -1,54 +1,78 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unification.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Environ
 open Evd
-(*i*)
 
 type unify_flags = {
   modulo_conv_on_closed_terms : Names.transparent_state option;
-  use_metas_eagerly : bool;
+  use_metas_eagerly_in_conv_on_closed_terms : bool;
   modulo_delta : Names.transparent_state;
+  modulo_delta_types : Names.transparent_state;
+  check_applied_meta_types : bool;
   resolve_evars : bool;
-  use_evars_pattern_unification : bool
+  use_pattern_unification : bool;
+  use_meta_bound_pattern_unification : bool;
+  frozen_evars : ExistentialSet.t;
+  restrict_conv_on_strict_subterms : bool;
+  modulo_betaiota : bool;
+  modulo_eta : bool;
+  allow_K_in_toplevel_higher_order_unification : bool
 }
 
 val default_unify_flags : unify_flags
 val default_no_delta_unify_flags : unify_flags
 
-(* The "unique" unification fonction *)
+val elim_flags : unify_flags
+val elim_no_delta_flags : unify_flags
+
+(** The "unique" unification fonction *)
 val w_unify :
-  bool -> env -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map -> evar_map
+  env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map
 
-(* [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
+(** [w_unify_to_subterm env (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_map -> evar_map * constr
+  env -> evar_map -> ?flags:unify_flags -> constr * constr -> evar_map * constr
 
 val w_unify_to_subterm_all :
-  env -> ?flags:unify_flags -> constr * constr -> evar_map -> (evar_map * constr) list
+  env -> evar_map -> ?flags:unify_flags -> constr * constr -> (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
+(** [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_map -> constr -> types -> types ->
   evar_map * constr
 
 (*i This should be in another module i*)
 
-(* [abstract_list_all env evd t c l]                       *)
-(* abstracts the terms in l over c to get a term of type t *)
-(* (exported for inv.ml) *)
+(** [abstract_list_all env evd t c l]                       
+   abstracts the terms in l over c to get a term of type t 
+   (exported for inv.ml) *)
 val abstract_list_all :
   env -> evar_map -> constr -> constr -> constr list -> constr
+
+
+(* For tracing *)
+
+val w_merge : env -> bool -> unify_flags -> evar_map *
+  (metavariable * constr * (instance_constraint * instance_typing_status)) list *
+  (env * types pexistential * types) list -> evar_map
+
+val unify_0 :            Environ.env ->
+           Evd.evar_map ->
+           Evd.conv_pb ->
+           unify_flags ->
+           Term.types ->
+           Term.types ->
+           Evd.evar_map * Evd.metabinding list *
+           (Environ.env * Term.types Term.pexistential * Term.constr) list
+
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 395f5c8d..fad2e6f0 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vnorm.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Declarations
 open Term
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 4cf99842..ee946e53 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
 open Names
 open Term
 open Environ
 open Reduction
-(*i*)
 
-(*s Reduction functions *)
+(** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
 
diff --git a/pretyping/clenv.ml b/proofs/clenv.ml
index abfef8d4..d06c6f2e 100644
--- a/pretyping/clenv.ml
+++ b/proofs/clenv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,7 +18,7 @@ open Environ
 open Evd
 open Reduction
 open Reductionops
-open Rawterm
+open Glob_term
 open Pattern
 open Tacred
 open Pretype_errors
@@ -31,10 +29,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_env = Refiner.pf_env
 let pf_type_of gls c  = Typing.type_of (pf_env gls) gls.sigma c
-let pf_concl gl = gl.it.evar_concl
 
 (******************************************************************)
 (* Clausal environments *)
@@ -142,13 +138,10 @@ let mk_clenv_from_env environ sigma n (c,cty) =
     env = environ }
 
 let mk_clenv_from_n gls n (c,cty) =
-  mk_clenv_from_env (Global.env_of_context gls.it.evar_hyps) gls.sigma n (c, cty)
+  mk_clenv_from_env (pf_env gls) gls.sigma 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_vars_as_displayed [] t)
-
 let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t)
 
 (******************************************************************)
@@ -190,7 +183,7 @@ let clenv_assign mv rhs clenv =
       else
 	clenv
     else
-      let st = (ConvUpToEta 0,TypeNotProcessed) in
+      let st = (Conv,TypeNotProcessed) in
       {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd}
   with Not_found ->
     error "clenv_assign: undefined meta"
@@ -199,63 +192,94 @@ let clenv_assign mv rhs clenv =
 
 (* [clenv_dependent hyps_only clenv]
  * returns a list of the metavars which appear in the template of clenv,
- * and which are dependent, This is computed by taking the metavars in cval,
- * in right-to-left order, and collecting the metavars which appear
+ * and which are dependent, This is computed by taking the metavars of the
+ * template in right-to-left order, and collecting the metavars which appear
  * in their types, and adding in all the metavars appearing in the
  * type of clenv.
- * If [hyps_only] then metavariables occurring in the type are _excluded_ *)
+ * If [hyps_only] then metavariables occurring in the concl are _excluded_
+ * If [iter] is also set then all metavariables *recursively* occurring
+ * in the concl are _excluded_
+
+   Details of the strategies used for computing the set of unresolved
+   dependent metavariables
+
+   We typically have a clause of the form
+
+   lem(?T:Type,?T,?U:Type,?V:Type,?x:?T,?y:?U,?z:?V,?H:hyp(?x,?z)) :concl(?y,?z)
 
-(* [clenv_metavars clenv mv]
- * returns a list of the metavars which appear in the type of
- * the metavar mv.  The list is unordered. *)
+   Then, we compute:
+   A  = the set of all unresolved metas
+   C  = the set of metas occurring in concl (here ?y, ?z)
+   C* = the recursive closure of C wrt types (here ?y, ?z, ?U, ?V)
+   D  = the set of metas occurring in a type of meta (here ?x, ?T, ?z, ?U, ?V)
+   NL = the set of duplicated metas even if non dependent (here ?T)
+       (we make the assumption that duplicated metas have internal dependencies)
+
+   Then, for the "apply"-style tactic (hyps_only), missing metas are
+     A inter ((D minus C) union NL)
+
+   for the optimized "apply"-style tactic (taking in care, f_equal style
+   lemma, from 2/8/10, Coq > 8.3), missing metas are
+     A inter (( D minus C* ) union NL)
+
+   for the "elim"-style tactic, missing metas are
+     A inter (D union C union NL)
+
+   In any case, we respect the order given in A.
+*)
 
-let clenv_metavars evd mv =
+let clenv_metas_in_type_of_meta evd mv =
   (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas
 
-let dependent_metas clenv mvs conclmetas =
+let dependent_in_type_of_metas clenv mvs =
   List.fold_right
-    (fun mv deps ->
-       Metaset.union deps (clenv_metavars clenv.evd mv))
-    mvs conclmetas
-
-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)
-    | _       -> fold_constr collrec acc c
-  in
-  snd (collrec ([],[]) c)
-
-let clenv_dependent hyps_only clenv =
-  let mvs = undefined_metas clenv.evd in
-  let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
-  let deps = dependent_metas clenv mvs ctyp_mvs in
-  let nonlinear = duplicated_metas (clenv_value clenv) in
-  (* Make the assumption that duplicated metas have internal dependencies *)
+    (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.evd mv))
+    mvs Metaset.empty
+
+let dependent_closure clenv mvs =
+  let rec aux mvs acc =
+    Metaset.fold
+      (fun mv deps ->
+	let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.evd mv in
+	aux metas_of_meta_type (Metaset.union deps metas_of_meta_type))
+      mvs acc in
+  aux mvs mvs
+
+let clenv_dependent_gen hyps_only ?(iter=true) clenv =
+  let all_undefined = undefined_metas clenv.evd in
+  let deps_in_concl = (mk_freelisted (clenv_type clenv)).freemetas in
+  let deps_in_hyps = dependent_in_type_of_metas clenv all_undefined in
+  let deps_in_concl =
+    if hyps_only && iter then dependent_closure clenv deps_in_concl
+    else deps_in_concl in
   List.filter
-    (fun mv -> if Metaset.mem mv deps
-               then not (hyps_only && Metaset.mem mv ctyp_mvs)
-               else List.mem mv nonlinear)
-    mvs
+    (fun mv ->
+      if hyps_only then
+	Metaset.mem mv deps_in_hyps && not (Metaset.mem mv deps_in_concl)
+      else
+	Metaset.mem mv deps_in_hyps || Metaset.mem mv deps_in_concl)
+    all_undefined
 
-let clenv_missing ce = clenv_dependent true ce
+let clenv_missing ce = clenv_dependent_gen true ce
+let clenv_dependent ce = clenv_dependent_gen false ce
 
 (******************************************************************)
 
-let clenv_unify allow_K ?(flags=default_unify_flags) cv_pb t1 t2 clenv =
+let clenv_unify ?(flags=default_unify_flags) cv_pb t1 t2 clenv =
   { clenv with
-      evd = w_unify allow_K ~flags:flags clenv.env cv_pb t1 t2 clenv.evd }
+      evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 }
 
 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 =
+let clenv_unique_resolver ?(flags=default_unify_flags) clenv gl =
+  let concl = Goal.V82.concl clenv.evd (sig_it gl) in
   if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then
-    clenv_unify allow_K CUMUL ~flags:flags (clenv_type clenv) (pf_concl gl)
-      (clenv_unify_meta_types ~flags:flags clenv)
+    clenv_unify CUMUL ~flags (clenv_type clenv) concl
+      (clenv_unify_meta_types ~flags clenv)
   else
-    clenv_unify allow_K CUMUL ~flags:flags
-      (meta_reducible_instance clenv.evd clenv.templtyp) (pf_concl gl) clenv
+    clenv_unify CUMUL ~flags
+      (meta_reducible_instance clenv.evd clenv.templtyp) concl clenv
 
 (* [clenv_pose_metas_as_evars clenv dep_mvs]
  * For each dependent evar in the clause-env which does not have a value,
@@ -304,9 +328,10 @@ let evar_clenv_unique_resolver = clenv_unique_resolver
 (******************************************************************)
 
 let connect_clenv gls clenv =
+  let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in
   { clenv with
-    evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd;
-    env = Global.env_of_context gls.it.evar_hyps }
+    evd = evd ;
+    env = Goal.V82.env evd (sig_it gls) }
 
 (* [clenv_fchain mv clenv clenv']
  *
@@ -331,7 +356,12 @@ let connect_clenv gls clenv =
 
    In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma].
 *)
-let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv =
+
+let fchain_flags =
+  { default_unify_flags with
+    allow_K_in_toplevel_higher_order_unification = true }
+
+let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv =
   (* Add the metavars of [nextclenv] to [clenv], with their name-environment *)
   let clenv' =
     { templval = clenv.templval;
@@ -340,7 +370,7 @@ let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv
       env = nextclenv.env } in
   (* unify the type of the template of [nextclenv] with the type of [mv] *)
   let clenv'' =
-    clenv_unify allow_K ~flags:flags CUMUL
+    clenv_unify ~flags:flags CUMUL
       (clenv_term clenv' nextclenv.templtyp)
       (clenv_meta_type clenv' mv)
       clenv' in
@@ -364,7 +394,7 @@ type arg_bindings = constr explicit_bindings
 let clenv_independent clenv =
   let mvs = collect_metas (clenv_value clenv) in
   let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
-  let deps = dependent_metas clenv mvs ctyp_mvs in
+  let deps = Metaset.union (dependent_in_type_of_metas clenv mvs) ctyp_mvs in
   List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
 
 let check_bindings bl =
@@ -406,7 +436,7 @@ let clenv_unify_binding_type clenv c t u =
       let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
       TypeProcessed, { clenv with evd = evd }, c
     with 
-      | PretypeError (_,NotClean _) as e -> raise e
+      | PretypeError (_,_,NotClean _) as e -> raise e
       | e when precatchable_exception e ->
 	  TypeNotProcessed, clenv, c
 
@@ -414,7 +444,7 @@ let clenv_assign_binding clenv k c =
   let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in
   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 }
+  { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd }
 
 let clenv_match_args bl clenv =
   if bl = [] then
@@ -439,22 +469,32 @@ let clenv_constrain_last_binding c clenv =
   let k = try list_last all_mvs with Failure _ -> raise NoSuchBinding in
   clenv_assign_binding clenv k c
 
+let error_not_right_number_missing_arguments n =
+  errorlabstrm ""
+    (strbrk "Not the right number of missing arguments (expected " ++
+      int n ++ str ").")
+
 let clenv_constrain_dep_args hyps_only bl clenv =
   if bl = [] then
     clenv
   else
-    let occlist = clenv_dependent hyps_only clenv in
+    let occlist = clenv_dependent_gen hyps_only clenv in
     if List.length occlist = List.length bl then
       List.fold_left2 clenv_assign_binding clenv occlist bl
     else
-      errorlabstrm ""
-	(strbrk "Not the right number of missing arguments (expected " ++
-	 int (List.length occlist) ++ str ").")
+      if hyps_only then
+	(* Tolerance for compatibility <= 8.3 *)
+	let occlist' = clenv_dependent_gen hyps_only ~iter:false clenv in
+	if List.length occlist' = List.length bl then
+	  List.fold_left2 clenv_assign_binding clenv occlist' bl
+	else
+	  error_not_right_number_missing_arguments (List.length occlist)
+      else
+	error_not_right_number_missing_arguments (List.length occlist)
 
 (****************************************************************)
 (* Clausal environment for an application *)
 
-
 let make_clenv_binding_gen hyps_only n env sigma (c,t) = function
   | ImplicitBindings largs ->
       let clause = mk_clenv_from_env env sigma n (c,t) in
@@ -479,4 +519,4 @@ let pr_clenv clenv =
   h 0
     (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
      str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
-     pr_evar_map clenv.evd)
+     pr_evar_map (Some 2) clenv.evd)
diff --git a/pretyping/clenv.mli b/proofs/clenv.mli
index 6fbb668b..abd67236 100644
--- a/pretyping/clenv.mli
+++ b/proofs/clenv.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: clenv.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -17,78 +14,72 @@ open Environ
 open Evd
 open Evarutil
 open Mod_subst
-open Rawterm
+open Glob_term
 open Unification
-(*i*)
 
-(***************************************************************)
-(* The Type of Constructions clausale environments. *)
+(** {6 The Type of Constructions clausale environments.} *)
 
-(* [env] is the typing context
- * [evd] is the mapping from metavar and evar numbers to their types
- *       and values.
- * [templval] is the template which we are trying to fill out.
- * [templtyp] is its type.
- *)
 type clausenv = {
-  env      : env;
-  evd      : evar_map;
-  templval : constr freelisted;
-  templtyp : constr freelisted }
-
-(* Substitution is not applied on templenv (because [subst_clenv] is
+  env      : env; (** the typing context *)
+  evd      : evar_map; (** the mapping from metavar and evar numbers to their 
+			   types and values *)
+  templval : constr freelisted; (** the template which we are trying to fill 
+				    out *)
+  templtyp : constr freelisted (** its type *)}
+
+(** Substitution is not applied on templenv (because [subst_clenv] is
    applied only on hints which typing env is overwritten by the
    goal env) *)
 val subst_clenv : substitution -> clausenv -> clausenv
 
-(* subject of clenv (instantiated) *)
+(** subject of clenv (instantiated) *)
 val clenv_value     : clausenv -> constr
-(* type of clenv (instantiated) *)
+
+(** type of clenv (instantiated) *)
 val clenv_type      : clausenv -> types
-(* substitute resolved metas *)
+
+(** substitute resolved metas *)
 val clenv_nf_meta   : clausenv -> constr -> constr
-(* type of a meta in clenv context *)
+
+(** type of a meta in clenv context *)
 val clenv_meta_type : clausenv -> metavariable -> types
 
-val mk_clenv_from : evar_info sigma -> constr * types -> clausenv
+val mk_clenv_from : Goal.goal sigma -> constr * types -> clausenv
 val mk_clenv_from_n :
-  evar_info sigma -> int option -> constr * types -> clausenv
-val mk_clenv_type_of : evar_info sigma -> constr -> clausenv
+  Goal.goal sigma -> int option -> constr * types -> clausenv
+val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv
 val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv
 
-(***************************************************************)
-(* linking of clenvs *)
+(** {6 linking of clenvs } *)
 
-val connect_clenv : evar_info sigma -> clausenv -> clausenv
+val connect_clenv : Goal.goal sigma -> clausenv -> clausenv
 val clenv_fchain :
-  ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
+  ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
 
-(***************************************************************)
-(* Unification with clenvs *)
+(** {6 Unification with clenvs } *)
 
-(* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
+(** Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
 val clenv_unify :
-  bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv
+  ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv
 
-(* unifies the concl of the goal with the type of the clenv *)
+(** unifies the concl of the goal with the type of the clenv *)
 val clenv_unique_resolver :
-  bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv
+  ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv
 
-(* same as above ([allow_K=false]) but replaces remaining metas
+(** same as above ([allow_K=false]) but replaces remaining metas
    with fresh evars if [evars_flag] is [true] *)
 val evar_clenv_unique_resolver :
-  bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv
+  ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv
 
-val clenv_dependent : bool -> clausenv -> metavariable list
+val clenv_dependent : clausenv -> metavariable list
 
 val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv
 
-(***************************************************************)
-(* Bindings *)
+(** {6 Bindings } *)
 
 type arg_bindings = constr explicit_bindings
 
-(* bindings where the key is the position in the template of the
+(** bindings where the key is the position in the template of the
    clenv (dependent or not). Positions can be negative meaning to
    start from the rightmost argument of the template. *)
 val clenv_independent : clausenv -> metavariable list
@@ -98,26 +89,27 @@ val clenv_missing : clausenv -> metavariable list
 exception NoSuchBinding
 val clenv_constrain_last_binding : constr -> clausenv -> clausenv
 
-(* defines metas corresponding to the name of the bindings *)
+(** defines metas corresponding to the name of the bindings *)
 val clenv_match_args : arg_bindings -> clausenv -> clausenv
 
 val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv
 
-(* start with a clenv to refine with a given term with bindings *)
+(** start with a clenv to refine with a given term with bindings *)
 
-(* the arity of the lemma is fixed *)
-(* 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 -> constr bindings ->
-   clausenv
+(** the arity of the lemma is fixed 
+   the optional int tells how many prods of the lemma have to be used 
+   use all of them if None *)
 val make_clenv_binding_env_apply :
   env -> evar_map -> int option -> constr * constr -> constr bindings ->
    clausenv
+
+val make_clenv_binding_apply :
+  Goal.goal sigma -> int option -> constr * constr -> constr bindings ->
+   clausenv
 val make_clenv_binding :
-  evar_info sigma -> constr * constr -> constr bindings -> clausenv
+  Goal.goal sigma -> constr * constr -> constr bindings -> clausenv
 
-(* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
+(** [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
    [lmetas] is a list of metas to be applied to a proof of [t] so that
    it produces the unification pattern [ccl]; [sigma'] is [sigma]
    extended with [lmetas]; if [n] is defined, it limits the size of
@@ -129,20 +121,19 @@ val make_clenv_binding :
 val clenv_environments :
  evar_map -> int option -> types -> evar_map * constr list * types
 
-(* [clenv_environments_evars env sigma n t] does the same but returns
+(** [clenv_environments_evars env sigma n t] does the same but returns
    a list of Evar's defined in [env] and extends [sigma] accordingly *)
 val clenv_environments_evars :
  env -> evar_map -> int option -> types -> evar_map * constr list * types
 
-(* [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *)
+(** [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *)
 val clenv_conv_leq :
  env -> evar_map -> types -> constr -> int -> constr list
 
-(* if the clause is a product, add an extra meta for this product *)
+(** if the clause is a product, add an extra meta for this product *)
 exception NotExtensibleClause
 val clenv_push_prod : clausenv -> clausenv
 
-(***************************************************************)
-(* Pretty-print *)
+(** {6 Pretty-print (debug only) } *)
 val pr_clenv : clausenv -> Pp.std_ppcmds
 
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 7b760859..eb935d05 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenvtac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,12 +18,11 @@ open Evd
 open Evarutil
 open Proof_type
 open Refiner
-open Proof_trees
 open Logic
 open Reduction
 open Reductionops
 open Tacmach
-open Rawterm
+open Glob_term
 open Pattern
 open Tacexpr
 open Clenv
@@ -64,7 +61,7 @@ let clenv_value_cast_meta clenv =
     clenv_cast_meta clenv (clenv_value clenv)
 
 let clenv_pose_dependent_evars with_evars clenv =
-  let dep_mvs = clenv_dependent false clenv in
+  let dep_mvs = clenv_dependent clenv in
   if dep_mvs <> [] & not with_evars then
     raise
       (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
@@ -84,17 +81,18 @@ let clenv_refine with_evars ?(with_classes=true) clenv gls =
     (refine (clenv_cast_meta clenv (clenv_value clenv)))
     gls
 
-let dft = Unification.default_unify_flags
+open Unification
+
+let dft = default_unify_flags
 
-let res_pf clenv ?(with_evars=false) ?(allow_K=false) ?(flags=dft) gls =
-  clenv_refine with_evars
-    (clenv_unique_resolver allow_K ~flags:flags clenv gls) gls
+let res_pf clenv ?(with_evars=false) ?(flags=dft) gls =
+  clenv_refine with_evars (clenv_unique_resolver ~flags clenv gls) gls
 
 let elim_res_pf_THEN_i clenv tac gls =
-  let clenv' = (clenv_unique_resolver true clenv gls) in
+  let clenv' = (clenv_unique_resolver ~flags:elim_flags clenv gls) in
   tclTHENLASTn (clenv_refine false clenv') (tac clenv') gls
 
-let e_res_pf clenv = res_pf clenv ~with_evars:true ~allow_K:false ~flags:dft
+let e_res_pf clenv = res_pf clenv ~with_evars:true ~flags:dft
 
 
 (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
@@ -102,21 +100,27 @@ let e_res_pf clenv = res_pf clenv ~with_evars:true ~allow_K:false ~flags:dft
    d'une même Meta sont compatibles. D'ailleurs le "fst" jette les metas
    provenant de w_Unify. (Utilisé seulement dans prolog.ml) *)
 
-open Unification
-
 let fail_quick_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = false;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
   modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = false;
-  use_evars_pattern_unification = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true; (* ? *)
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
 }
 
 (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
 let unifyTerms ?(flags=fail_quick_unif_flags) m n gls =
   let env = pf_env gls in
   let evd = create_goal_evar_defs (project gls) in
-  let evd' = w_unify false env CONV ~flags m n evd in
+  let evd' = w_unify env evd CONV ~flags m n in
   tclIDTAC {it = gls.it; sigma =  evd'}
 
 let unify ?(flags=fail_quick_unif_flags) m gls =
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 45e12645..49a961f5 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: clenvtac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -18,16 +15,15 @@ open Clenv
 open Proof_type
 open Tacexpr
 open Unification
-(*i*)
 
-(* Tactics *)
+(** Tactics *)
 val unify : ?flags:unify_flags -> constr -> tactic
 val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> tactic
-val res_pf : clausenv -> ?with_evars:evars_flag -> ?allow_K:bool -> ?flags:unify_flags -> tactic
+val res_pf : clausenv -> ?with_evars:evars_flag -> ?flags:unify_flags -> tactic
 val elim_res_pf_THEN_i : clausenv -> (clausenv -> tactic array) -> tactic
 
 val clenv_pose_dependent_evars : evars_flag -> clausenv -> clausenv
 val clenv_value_cast_meta : clausenv -> constr
 
-(* Compatibility, use res_pf ?with_evars:true instead *)
+(** Compatibility, use res_pf ?with_evars:true instead *)
 val e_res_pf : clausenv -> tactic
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index 69168dbd..36268de1 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -1,20 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_refiner.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
 open Evd
 open Evarutil
 open Sign
-open Proof_trees
 open Refiner
 
 (******************************************)
@@ -33,7 +30,7 @@ let define_and_solve_constraints evk c evd =
     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)
+	if b then Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 else p) (evd,true)
       pbs)
   with e when Pretype_errors.precatchable_exception e ->
     error "Instance does not satisfy constraints."
@@ -46,7 +43,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
     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
+      let loc = Glob_term.loc_of_glob_constr rawc in
       user_err_loc
         (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^
 			string_of_existential evk))
@@ -55,19 +52,10 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
 
 (* vernac command Existential *)
 
-let instantiate_pf_com n com pfts =
-  let gls = top_goal_of_pftreestate pfts in
-  let sigma = gls.sigma in
-  let (evk,evi) =
-    let evl = Evarutil.non_instantiated sigma in
-      if (n <= 0) then
-	error "incorrect existential variable index"
-      else if List.length evl < n then
-	  error "not so many uninstantiated existential variables"
-      else
-	List.nth evl (n-1)
-  in
+(* Main component of vernac command Existential *)
+let instantiate_pf_com evk com sigma =
+  let evi = Evd.find sigma evk in
   let env = Evd.evar_env evi in
   let rawc = Constrintern.intern_constr sigma env com in
   let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in
-  change_constraints_pftreestate sigma' pfts
+  sigma'
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index 69d4853e..8e7c0713 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -1,29 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_refiner.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Environ
 open Evd
 open Refiner
 open Pretyping
-open Rawterm
-(*i*)
+open Glob_term
 
-(* Refinement of existential variables. *)
+(** Refinement of existential variables. *)
 
 val w_refine : evar * evar_info ->
-  rawconstr_ltac_closure -> evar_map -> evar_map
+  glob_constr_ltac_closure -> evar_map -> evar_map
 
 val instantiate_pf_com :
-  int -> Topconstr.constr_expr -> pftreestate -> pftreestate
+  Evd.evar -> Topconstr.constr_expr -> Evd.evar_map -> Evd.evar_map
 
-(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *)
+(** the instantiate tactic was moved to [tactics/evar_tactics.ml] *)
diff --git a/proofs/goal.ml b/proofs/goal.ml
new file mode 100644
index 00000000..1542267e
--- /dev/null
+++ b/proofs/goal.ml
@@ -0,0 +1,588 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Term
+
+(* This module implements the abstract interface to goals *)
+(* A general invariant of the module, is that a goal whose associated 
+   evar is defined in the current evar_map, should not be accessed. *)
+
+(* type of the goals *)
+type goal = {
+  content : Evd.evar;      (* Corresponding evar. Allows to retrieve
+			      logical information once put together
+			      with an evar_map. *)
+  tags : string list       (* Heriditary? tags to be displayed *)
+}
+(* spiwack: I don't deal with the tags, yet. It is a worthy discussion
+   whether we do want some tags displayed besides the goal or not. *)
+
+
+let pr_goal {content = e} = str "GOAL:" ++ Pp.int e
+
+(* access primitive *)
+(* invariant : [e] must exist in [em] *)
+let content evars { content = e } = Evd.find evars e
+
+
+(* Builds a new (empty) goal with evar [e] *)
+let build e =
+  { content = e ;
+    tags = []
+  }
+
+
+let uid {content = e} = string_of_int e
+let get_by_uid u =
+  (* this necessarily forget about tags.
+     when tags are to be implemented, they
+     should be done another way.
+     We could use the store in evar_extra,
+     for instance. *)
+  build (int_of_string u)
+
+(* Builds a new goal with content evar [e] and 
+   inheriting from goal [gl]*)
+let descendent gl e =
+  { gl with content = e}
+
+(* [advance sigma g] returns [Some g'] if [g'] is undefined and 
+    is the current avatar of [g] (for instance [g] was changed by [clear]
+    into [g']). It returns [None] if [g] has been (partially) solved. *)
+open Store.Field
+let rec advance sigma g =
+  let evi = Evd.find sigma g.content in
+  if Option.default false (Evarutil.cleared.get evi.Evd.evar_extra) then
+    let v = 
+      match evi.Evd.evar_body with 
+      | Evd.Evar_defined c -> c
+      | _ -> Util.anomaly "Some goal is marked as 'cleared' but is uninstantiated"
+    in
+    let (e,_) = Term.destEvar v in
+    let g' = { g with content = e } in
+    advance sigma g'
+  else
+    match evi.Evd.evar_body with
+    | Evd.Evar_defined _ -> None
+    | _ -> Some g
+
+(*** Goal tactics ***)
+
+
+(* Goal tactics are [subgoal sensitive]-s *)
+type subgoals = { subgoals: goal list }
+
+(* type of the base elements of the goal API.*)
+(* it has an extra evar_info with respect to what would be expected,
+   it is supposed to be the evar_info of the goal in the evar_map.
+   The idea is that it is computed by the [run] function as an 
+   optimisation, since it will generaly not change during the 
+   evaluation. *)
+type 'a sensitive = 
+    Environ.env -> Evd.evar_map ref -> goal -> Evd.evar_info -> 'a
+
+(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *)
+(* the evar_info corresponding to the goal is computed at once
+   as an optimisation (it shouldn't change during the evaluation). *)
+let eval t env defs gl =
+  let info = content defs gl in
+  let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
+  let rdefs = ref defs in
+  let r = t env rdefs gl info in
+  ( r , !rdefs )
+
+(* monadic bind on sensitive expressions *)
+let bind e f env rdefs goal info =
+  f (e env rdefs goal info) env rdefs goal info
+
+(* monadic return on sensitive expressions *)
+let return v _ _ _ _ = v
+
+(* interpretation of "open" constr *)
+(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. 
+    In an ideal world, this could/should be the other way round.
+    As of now, though, it seems at least quite useful to build tactics. *)
+let interp_constr cexpr env rdefs _ _ =
+  let (defs,c) = Constrintern.interp_open_constr !rdefs env cexpr in
+  rdefs := defs ;
+  c
+
+(* Type of constr with holes used by refine. *)
+(* The list of evars doesn't necessarily contain all the evars in the constr, 
+    only those the constr has introduced. *)
+(* The variables in [myevars] are supposed to be stored
+   in decreasing order. Breaking this invariant might cause
+   many things to go wrong. *)
+type refinable = {
+  me: constr;
+  my_evars: Evd.evar list
+}
+
+module Refinable = struct
+  type t = refinable
+
+  type handle = Evd.evar list ref
+
+  let make t env rdefs gl info = 
+    let r = ref [] in
+    let me = t r env rdefs gl info in
+    { me = me;
+       my_evars = !r }
+  let make_with t env rdefs gl info =
+    let r = ref [] in
+    let (me,side) = t r env rdefs gl info in
+    { me = me ; my_evars = !r } , side
+
+  let mkEvar handle env typ _ rdefs _ _ =
+    let ev = Evarutil.e_new_evar rdefs env typ in
+    let (e,_) = Term.destEvar ev in
+    handle := e::!handle;
+    ev
+      
+  (* [with_type c typ] constrains term [c] to have type [typ].  *)
+  let with_type t typ env rdefs _ _ = 
+    (* spiwack: this function assumes that no evars can be created during
+        this sort of coercion.
+        If it is not the case it could produce bugs. We would need to add a handle
+        and add the new evars to it. *)
+    let my_type = Retyping.get_type_of env !rdefs t in
+    let j = Environ.make_judge t my_type in
+    let tycon = Evarutil.mk_tycon_type typ in
+    let (new_defs,j') = 
+      Coercion.Default.inh_conv_coerce_to (Util.dummy_loc) env !rdefs j tycon 
+    in
+    rdefs := new_defs;
+    j'.Environ.uj_val 
+
+  (* spiwack: it is not very fine grain since it solves all typeclasses holes, 
+      not only those containing the current goal, or a given term. But it
+      seems to fit our needs so far. *)
+  let resolve_typeclasses ?onlyargs ?split ?(fail=false) () env rdefs _ _ =
+    rdefs:=Typeclasses.resolve_typeclasses ?onlyargs ?split ~fail env !rdefs;
+    ()
+
+
+
+  (* a pessimistic (i.e : there won't be many positive answers) filter
+     over evar_maps, acting only on undefined evars *)
+  let evar_map_filter_undefined f evm =
+    Evd.fold_undefined
+      (fun ev evi r -> if f ev evi then Evd.add r ev evi else r)
+      evm
+      Evd.empty
+
+  (* Union, sorted in decreasing order, of two lists of evars in decreasing order. *)
+  let rec fusion l1 l2 = match l1 , l2 with
+    | [] , _ -> l2
+    | _ , [] -> l1
+    | a::l1 , b::_ when a>b -> a::(fusion l1 l2)
+    | a::l1 , b::l2 when a=b -> a::(fusion l1 l2)
+    | _ , b::l2 -> b::(fusion l1 l2)
+
+  let update_handle handle init_defs post_defs =
+    (* [delta_evars] holds the evars that have been introduced by this
+       refinement (but not immediatly solved) *)
+    (* spiwack: this is the hackish part, don't know how to do any better though. *)
+    let delta_evars = evar_map_filter_undefined
+      (fun ev _ -> not (Evd.mem init_defs ev))
+      post_defs
+    in
+    (* [delta_evars] in the shape of a list of [evar]-s*)
+    let delta_list = List.map fst (Evd.to_list delta_evars) in
+    (* The variables in [myevars] are supposed to be stored
+       in decreasing order. Breaking this invariant might cause
+       many things to go wrong. *)
+    handle := fusion delta_list !handle;
+    delta_evars
+
+  (* [constr_of_raw] is a pretyping function. The [check_type] argument
+      asks whether the term should have the same type as the conclusion.
+      [resolve_classes] is a flag on pretyping functions which, if set to true,
+      calls the typeclass resolver.
+      The principal argument is a [glob_constr] which is then pretyped in the
+      context of a term, the remaining evars are registered to the handle.
+      It is the main component of the toplevel refine tactic.*)
+  (* spiwack: it is not entirely satisfactory to have this function here. Plus it is
+      a bit hackish. However it does not seem possible to move it out until
+      pretyping is defined as some proof procedure. *)
+  let constr_of_raw handle check_type resolve_classes rawc env rdefs gl info =
+    (* We need to keep trace of what [rdefs] was originally*)
+    let init_defs = !rdefs in
+    (* if [check_type] is true, then creates a type constraint for the 
+       proof-to-be *)
+    let tycon = Pretyping.OfType (Option.init check_type (Evd.evar_concl info)) in
+    (* call to [understand_tcc_evars] returns a constr with undefined evars
+       these evars will be our new goals *)
+    let open_constr = 
+      Pretyping.Default.understand_tcc_evars ~resolve_classes rdefs env tycon rawc
+    in
+      ignore(update_handle handle init_defs !rdefs);
+      open_constr 
+  
+  let constr_of_open_constr handle check_type (evars, c) env rdefs gl info =
+    let delta = update_handle handle !rdefs evars in
+      rdefs := Evd.fold (fun ev evi evd -> Evd.add evd ev evi) delta !rdefs;
+      if check_type then with_type c (Evd.evar_concl (content !rdefs gl)) env rdefs gl info
+      else c
+ 
+end
+
+(* [refine t] takes a refinable term and use it as a partial proof for current
+    goal. *)
+let refine step env rdefs gl info =
+  (* subgoals to return *)
+  (* The evars in [my_evars] are stored in reverse order.
+     It is expectingly better however to display the goal
+     in increasing order. *)
+  rdefs := Evarconv.consider_remaining_unif_problems env !rdefs ;
+  let subgoals = List.map (descendent gl) (List.rev step.my_evars) in
+  (* creates the new [evar_map] by defining the evar of the current goal
+     as being [refine_step]. *)
+  let new_defs = Evd.define gl.content (step.me) !rdefs in
+  rdefs := new_defs;   
+  (* Filtering the [subgoals] for uninstanciated (=unsolved) goals. *)
+  let subgoals = 
+    Option.List.flatten (List.map (advance !rdefs) subgoals) 
+  in
+  { subgoals = subgoals }
+
+
+(*** Cleaning  goals ***)
+
+let clear ids env rdefs gl info =
+  let hyps = Evd.evar_hyps info in
+  let concl = Evd.evar_concl info in
+  let (hyps,concl) = Evarutil.clear_hyps_in_evi rdefs hyps concl ids in
+  let cleared_env = Environ.reset_with_named_context hyps env in
+  let cleared_concl = Evarutil.e_new_evar rdefs cleared_env concl in
+  let (cleared_evar,_) = Term.destEvar cleared_concl in
+  let cleared_goal = descendent gl cleared_evar in
+  rdefs := Evd.define gl.content cleared_concl !rdefs;
+  { subgoals = [cleared_goal] }
+
+let wrap_apply_to_hyp_and_dependent_on sign id f g =
+  try Environ.apply_to_hyp_and_dependent_on sign id f g 
+  with Environ.Hyp_not_found -> 
+    Util.error "No such assumption" 
+
+let check_typability env sigma c =
+  let _ = Typing.type_of env sigma c in () 
+
+let recheck_typability (what,id) env sigma t =
+  try check_typability env sigma t
+  with _ ->
+    let s = match what with
+      | None -> "the conclusion"
+      | Some id -> "hypothesis "^(Names.string_of_id id) in
+    Util.error
+      ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id))
+
+let remove_hyp_body env sigma id =
+  let sign =
+    wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id
+      (fun (_,c,t) _ ->
+	match c with
+	| None -> Util.error ((Names.string_of_id id)^" is not a local definition")
+	| Some c ->(id,None,t))
+      (fun (id',c,t as d) sign ->
+	(
+	  begin 
+	    let env = Environ.reset_with_named_context sign env in
+	    match c with
+	    | None ->  recheck_typability (Some id',id) env sigma t
+	    | Some b ->
+		let b' = mkCast (b,DEFAULTcast, t) in
+		recheck_typability (Some id',id) env sigma b'
+	  end;d))
+  in
+  Environ.reset_with_named_context sign env 
+
+
+let clear_body idents env rdefs gl info =
+  let info = content !rdefs gl in
+  let full_env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
+  let aux env id = 
+     let env' = remove_hyp_body env !rdefs id in
+       recheck_typability (None,id) env' !rdefs (Evd.evar_concl info);
+       env'
+  in
+  let new_env = 
+    List.fold_left aux full_env idents
+  in
+  let concl = Evd.evar_concl info in
+  let (defs',new_constr) = Evarutil.new_evar !rdefs new_env concl in
+  let (new_evar,_) = destEvar new_constr in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_constr defs';
+  { subgoals = [new_goal] }
+
+
+(*** Sensitive primitives ***)
+
+(* [concl] is the conclusion of the current goal *)
+let concl _ _ _ info =
+  Evd.evar_concl info
+
+(* [hyps] is the [named_context_val] representing the hypotheses
+   of the current goal *)
+let hyps _ _ _ info =
+  Evd.evar_hyps info
+
+(* [env] is the current [Environ.env] containing both the 
+   environment in which the proof is ran, and the goal hypotheses *)
+let env env _ _ _ = env
+
+(* [defs] is the [Evd.evar_map] at the current evaluation point *)
+let defs _ rdefs _ _ =
+  !rdefs
+
+(* Cf mli for more detailed comment.
+    [null], [plus], [here] and [here_list] use internal exception [UndefinedHere]
+    to communicate whether or not the value is defined in the particular context. *)
+exception UndefinedHere
+(* no handler: this should never be allowed to reach toplevel *)
+let null _ _ _ _ = raise UndefinedHere
+
+let plus s1 s2 env rdefs goal info =
+  try s1 env rdefs goal info
+  with UndefinedHere -> s2 env rdefs goal info
+
+(* Equality of two goals *)
+let equal { content = e1 } { content = e2 } = e1 = e2
+
+let here goal value _ _ goal' _ =
+  if equal goal goal' then
+    value
+  else 
+    raise UndefinedHere
+
+(* arnaud: voir à la passer dans Util ? *)
+let rec list_mem_with eq x = function
+  | y::_ when eq x y -> true
+  | _::l -> list_mem_with eq x l
+  | [] -> false
+
+let here_list goals value _ _ goal' _ =
+  if list_mem_with equal goal' goals then
+    value
+  else
+    raise UndefinedHere
+
+
+(*** Conversion in goals ***)
+
+let convert_hyp check (id,b,bt as d) env rdefs gl info =
+  let sigma = !rdefs in
+  (* This function substitutes the new type and body definitions
+     in the appropriate variable when used with {!Environ.apply_hyps}. *)
+  let replace_function =
+    (fun _ (_,c,ct) _ ->
+       if check && not (Reductionops.is_conv env sigma bt ct) then
+	 Util.error ("Incorrect change of the type of "^(Names.string_of_id id));
+       if check && not (Option.Misc.compare (Reductionops.is_conv env sigma) b c) then
+	 Util.error ("Incorrect change of the body of "^(Names.string_of_id id));
+       d)
+  in
+  (* Modified named context. *)
+  let new_hyps = 
+    Environ.apply_to_hyp (hyps env rdefs gl info) id replace_function
+  in  
+  let new_env = Environ.reset_with_named_context new_hyps env in
+  let new_constr = 
+    Evarutil.e_new_evar rdefs new_env (concl env rdefs gl info)
+  in
+  let (new_evar,_) = Term.destEvar new_constr in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_constr !rdefs;
+  { subgoals = [new_goal] }
+  
+let convert_concl check cl' env rdefs gl info =
+  let sigma = !rdefs in
+  let cl = concl env rdefs gl info in
+  check_typability env sigma cl';
+  if (not check) || Reductionops.is_conv_leq env sigma cl' cl then
+    let new_constr = 
+      Evarutil.e_new_evar rdefs env cl' 
+    in
+    let (new_evar,_) = Term.destEvar new_constr in
+    let new_goal = descendent gl new_evar in
+    rdefs := Evd.define gl.content new_constr !rdefs;
+    { subgoals = [new_goal] }
+  else
+    Util.error "convert-concl rule passed non-converting term"
+
+
+(*** Bureaucracy in hypotheses ***)  
+
+(* Renames a hypothesis. *)
+let rename_hyp_sign id1 id2 sign =
+  Environ.apply_to_hyp_and_dependent_on sign id1
+    (fun (_,b,t) _ -> (id2,b,t))
+    (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d)
+let rename_hyp id1 id2 env rdefs gl info = 
+  let hyps = hyps env rdefs gl info in
+  if id1 <> id2 &&
+    List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then
+       Util.error ((Names.string_of_id id2)^" is already used.");
+  let new_hyps = rename_hyp_sign id1 id2 hyps in
+  let new_env = Environ.reset_with_named_context new_hyps env in
+  let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in
+  let new_subproof = Evarutil.e_new_evar rdefs new_env new_concl in
+  let new_subproof = Term.replace_vars [id2,mkVar id1] new_subproof in
+  let (new_evar,_) = Term.destEvar new_subproof in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_subproof !rdefs;
+  { subgoals = [new_goal] }
+
+(*** Additional functions ***)
+
+(* emulates List.map for functions of type 
+   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
+   new evar_map to next definition. *)
+(*This sort of construction actually works with any monad (here the State monade
+   in Haskell). There is a generic construction in Haskell called mapM.
+*)
+let rec list_map f l s = 
+  match l with
+  | [] -> ([],s)
+  | a::l -> let (a,s) = f s a in
+               let (l,s) = list_map f l s in
+	       (a::l,s)
+
+
+(* Layer to implement v8.2 tactic engine ontop of the new architecture. 
+   Types are different from what they used to be due to a change of the
+   internal types. *)
+module V82 = struct
+
+  (* Old style env primitive *)
+  let env evars gl = 
+    let evi = content evars gl in
+    Evd.evar_env evi
+
+  (* For printing *)
+  let unfiltered_env evars gl = 
+    let evi = content evars gl in
+    Evd.evar_unfiltered_env evi
+
+  (* Old style hyps primitive *)
+  let hyps evars gl =
+    let evi = content evars gl in
+    evi.Evd.evar_hyps
+
+  (* Access to ".evar_concl" *)
+  let concl evars gl =
+    let evi = content evars gl in
+    evi.Evd.evar_concl
+
+  (* Access to ".evar_extra" *)
+  let extra evars gl =
+    let evi = content evars gl in
+    evi.Evd.evar_extra
+
+  (* Old style filtered_context primitive *)
+  let filtered_context evars gl =
+    let evi = content evars gl in
+    Evd.evar_filtered_context evi
+
+  (* Old style mk_goal primitive *)
+  let mk_goal evars hyps concl extra =
+    let evk = Evarutil.new_untyped_evar () in
+    let evi = { Evd.evar_hyps = hyps; 
+		     Evd.evar_concl = concl; 
+		     Evd.evar_filter = List.map (fun _ -> true) 
+	                                                        (Environ.named_context_of_val hyps);
+		     Evd.evar_body = Evd.Evar_empty; 
+		     Evd.evar_source = (Util.dummy_loc,Evd.GoalEvar);
+		     Evd.evar_candidates = None;
+		     Evd.evar_extra = extra }
+    in
+    let evi = Typeclasses.mark_unresolvable evi in
+    let evars = Evd.add evars evk evi in
+    let ids = List.map Util.pi1 (Environ.named_context_of_val hyps) in
+    let inst = Array.of_list (List.map mkVar ids) in
+    let ev = Term.mkEvar (evk,inst) in
+    (build evk, ev, evars)
+
+  (* Equality function on goals *)
+  let equal evars gl1 gl2 =
+    let evi1 = content evars gl1 in
+    let evi2 = content evars gl2 in
+    Evd.eq_evar_info evi1 evi2
+
+  (* Creates a dummy [goal sigma] for use in auto *)
+  let dummy_goal =
+    (* This goal seems to be marshalled somewhere. Therefore it cannot be 
+       marked unresolvable for typeclasses, as non-empty Store.t-s happen
+       to have functional content. *)
+    let evi = Evd.make_evar Environ.empty_named_context_val Term.mkProp in
+    let evk = Evarutil.new_untyped_evar () in
+    let sigma = Evd.add Evd.empty evk evi in
+    { Evd.it = build evk ; Evd.sigma = sigma }
+
+  (* Makes a goal out of an evar *)
+  let build = build
+
+  (* Instantiates a goal with an open term *)
+  let partial_solution sigma { content=evk } c =
+    Evd.define evk c sigma
+   
+  (* Parts of the progress tactical *)
+  let same_goal evars1 gl1 evars2 gl2 =
+    let evi1 = content evars1 gl1 in
+    let evi2 = content evars2 gl2 in
+    Term.eq_constr evi1.Evd.evar_concl evi2.Evd.evar_concl &&
+    Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps
+      
+  let weak_progress glss gls =
+    match glss.Evd.it with
+    | [ g ] -> not (same_goal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it)
+    | _ -> true
+
+  let progress glss gls =
+    weak_progress glss gls
+    (* spiwack: progress normally goes like this:
+    (Evd.progress_evar_map gls.Evd.sigma glss.Evd.sigma) || (weak_progress glss gls) 
+       This is immensly slow in the current implementation. Maybe we could
+       reimplement progress_evar_map with restricted folds like "fold_undefined",
+       with a good implementation of them.
+    *)
+      
+  (* Used for congruence closure *)
+  let new_goal_with sigma gl new_hyps =
+    let evi = content sigma gl in
+    let new_evi = { evi with Evd.evar_hyps = new_hyps } in
+    let new_evi = Typeclasses.mark_unresolvable new_evi in
+    let evk = Evarutil.new_untyped_evar () in
+    let new_sigma = Evd.add Evd.empty evk new_evi in
+    { Evd.it = build evk ; sigma = new_sigma }
+
+  (* Used by the typeclasses *)
+  let nf_evar sigma gl =
+    let evi = content sigma gl in
+    let evi = Evarutil.nf_evar_info sigma evi in
+    let sigma = Evd.add sigma gl.content evi in
+    (gl,sigma)
+
+  (* Goal represented as a type, doesn't take into account section variables *)
+  let abstract_type sigma gl = 
+    let (gl,sigma) = nf_evar sigma gl in
+    let env = env sigma gl in
+    let genv = Global.env () in
+    let is_proof_var decl = 
+      try ignore (Environ.lookup_named (Util.pi1 decl) genv); false 
+      with Not_found -> true in
+    Environ.fold_named_context_reverse (fun t decl ->
+					  if is_proof_var decl then
+					    mkNamedProd_or_LetIn decl t
+					  else
+					    t
+				       ) ~init:(concl sigma gl) env
+
+end
diff --git a/proofs/goal.mli b/proofs/goal.mli
new file mode 100644
index 00000000..e9d23065
--- /dev/null
+++ b/proofs/goal.mli
@@ -0,0 +1,243 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This module implements the abstract interface to goals *)
+
+type goal
+
+(* spiwack: this primitive is not extremely brilliant. It may be a good
+    idea to define goals and proof views in the same file to avoid this
+    sort of communication pipes. But I find it heavy. *)
+val build : Evd.evar -> goal 
+
+(* Gives a unique identifier to each goal. The identifier is
+   guaranteed to contain no space. *)
+val uid : goal -> string
+(* Returns the goal (even if it has been partially solved)
+   corresponding to a unique identifier obtained by {!uid}. *)
+val get_by_uid : string -> goal
+
+(* Debugging help *)
+val pr_goal : goal -> Pp.std_ppcmds
+
+(* [advance sigma g] returns [Some g'] if [g'] is undefined and 
+    is the current avatar of [g] (for instance [g] was changed by [clear]
+    into [g']). It returns [None] if [g] has been (partially) solved. *)
+open Store.Field
+val advance : Evd.evar_map -> goal -> goal option
+
+
+(*** Goal tactics ***)
+
+
+(* Goal tactics are [subgoal sensitive]-s *)
+type subgoals = private { subgoals: goal list }
+
+(* Goal sensitive values *)
+type +'a sensitive
+
+(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *)
+val eval : 'a sensitive -> Environ.env -> Evd.evar_map -> goal -> 'a * Evd.evar_map
+
+(* monadic bind on sensitive expressions *)
+val bind : 'a sensitive -> ('a -> 'b sensitive) -> 'b sensitive
+
+(* monadic return on sensitive expressions *)
+val return : 'a -> 'a sensitive
+
+
+(* interpretation of "open" constr *)
+(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. 
+    In an ideal world, this could/should be the other way round.
+    As of now, though, it seems at least quite useful to build tactics. *)
+val interp_constr : Topconstr.constr_expr -> Term.constr sensitive
+
+(* Type of constr with holes used by refine. *)
+type refinable
+
+module Refinable : sig
+  type t = refinable 
+  type handle
+
+  val make : (handle -> Term.constr sensitive) -> refinable sensitive
+  val make_with : (handle -> (Term.constr*'a) sensitive) -> (refinable*'a) sensitive
+
+  val mkEvar : handle -> Environ.env -> Term.types -> Term.constr sensitive
+
+  (* [with_type c typ] constrains term [c] to have type [typ].  *)
+  val with_type : Term.constr -> Term.types -> Term.constr sensitive
+
+  val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> unit -> unit sensitive
+
+
+  (* [constr_of_raw h check_type resolve_classes] is a pretyping function.
+      The [check_type] argument asks whether the term should have the same
+      type as the conclusion. [resolve_classes] is a flag on pretyping functions
+      which, if set to true, calls the typeclass resolver.
+      The principal argument is a [glob_constr] which is then pretyped in the
+      context of a term, the remaining evars are registered to the handle.
+      It is the main component of the toplevel refine tactic.*)
+  val constr_of_raw : 
+    handle -> bool -> bool -> Glob_term.glob_constr -> Term.constr sensitive
+
+  (* [constr_of_open_constr h check_type] transforms an open constr into a 
+     goal-sensitive constr, adding the undefined variables to the set of subgoals.
+     If [check_type] is true, the term is coerced to the conclusion of the goal.
+     It allows to do refinement with already-built terms with holes.
+  *)
+  val constr_of_open_constr : handle -> bool -> Evd.open_constr -> Term.constr sensitive
+
+end
+
+(* [refine t] takes a refinable term and use it as a partial proof for current
+    goal. *)
+val refine : refinable -> subgoals sensitive
+
+
+(*** Cleaning  goals ***)
+
+(* Implements the [clear] tactic *)
+val clear : Names.identifier list -> subgoals sensitive
+
+(* Implements the [clearbody] tactic *)
+val clear_body : Names.identifier list -> subgoals sensitive
+
+
+(*** Conversion in goals ***)
+
+(* Changes an hypothesis of the goal with a convertible type and body.
+   Checks convertibility if the boolean argument is true. *)
+val convert_hyp : bool -> Term.named_declaration -> subgoals sensitive
+
+(* Changes the conclusion of the goal with a convertible type and body.
+   Checks convertibility if the boolean argument is true. *)
+val convert_concl : bool -> Term.constr -> subgoals sensitive
+
+(*** Bureaucracy in hypotheses ***)
+
+(* Renames a hypothesis. *)
+val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive
+
+(*** Sensitive primitives ***)
+
+(* [concl] is the conclusion of the current goal *)
+val concl : Term.constr sensitive
+
+(* [hyps] is the [named_context_val] representing the hypotheses
+   of the current goal *)
+val hyps : Environ.named_context_val sensitive
+
+(* [env] is the current [Environ.env] containing both the 
+   environment in which the proof is ran, and the goal hypotheses *)
+val env : Environ.env sensitive
+
+(* [defs] is the [Evd.evar_map] at the current evaluation point *)
+val defs : Evd.evar_map sensitive
+
+(* These four functions serve as foundation for the goal sensitive part
+    of the tactic monad (see Proofview).
+    [here] is a special sort of [return]: [here g a] is the value [a], but
+    does not have any value (it raises an exception) if evaluated in
+    any other goal than [g].
+    [here_list] is the same, except with a list of goals rather than a single one.
+    [plus a b] is the same as [a] if [a] is defined in the current goal, otherwise
+    it is [b]. Effectively it's defined in the goals where [a] and [b] are defined.
+    [null] is defined in no goal. (it is a neutral element for [plus]). *)
+(* spiwack: these primitives are a bit hackish, but I couldn't find another way
+    to pass information between goals, like for an intro tactic which gives to
+    each goal the name of the variable it introduce.
+    In pratice, in my experience, the primitives given in Proofview (in terms of
+    [here] and [plus]) are sufficient to define any tactics, hence these might
+    be another example of communication primitives between Goal and Proofview.
+    Still, I can't see a way to prevent using the Proofview primitive to read
+    a goal sensitive value out of its valid context. *)
+val null : 'a sensitive
+
+val plus : 'a sensitive -> 'a sensitive -> 'a sensitive 
+
+val here : goal -> 'a -> 'a sensitive 
+
+val here_list : goal list -> 'a -> 'a sensitive 
+
+(*** Additional functions ***)
+
+(* emulates List.map for functions of type 
+   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
+   new evar_map to next definition *)
+val list_map : (Evd.evar_map -> 'a -> 'b * Evd.evar_map) -> 
+                        'a list -> 
+                        Evd.evar_map -> 
+                        'b list *Evd.evar_map
+
+(* Layer to implement v8.2 tactic engine ontop of the new architecture. 
+   Types are different from what they used to be due to a change of the
+   internal types. *)
+module V82 : sig
+
+  (* Old style env primitive *)
+  val env : Evd.evar_map -> goal -> Environ.env
+
+  (* For printing *)
+  val unfiltered_env : Evd.evar_map -> goal -> Environ.env
+
+  (* Old style hyps primitive *)
+  val hyps : Evd.evar_map -> goal -> Environ.named_context_val
+
+  (* Access to ".evar_concl" *)
+  val concl : Evd.evar_map -> goal -> Term.constr
+
+  (* Access to ".evar_extra" *)
+  val extra : Evd.evar_map -> goal -> Store.t
+
+  (* Old style filtered_context primitive *)
+  val filtered_context : Evd.evar_map -> goal -> Sign.named_context
+
+  (* Old style mk_goal primitive, returns a new goal with corresponding 
+       hypotheses and conclusion, together with a term which is precisely
+       the evar corresponding to the goal, and an updated evar_map. *)
+  val mk_goal : Evd.evar_map -> 
+                         Environ.named_context_val ->
+                         Term.constr ->
+                         Store.t ->
+                         goal * Term.constr * Evd.evar_map
+
+  (* Equality function on goals *)
+  val equal : Evd.evar_map -> goal -> goal -> bool
+
+  (* Creates a dummy [goal sigma] for use in auto *)
+  val dummy_goal : goal Evd.sigma
+
+  (* Makes a goal out of an evar *)
+  (* spiwack: used by [Proofview.init], not entirely clean probably, but it is
+      the only way I could think of to preserve compatibility with previous Coq
+      stuff. *)
+  val build : Evd.evar -> goal 
+
+
+  (* Instantiates a goal with an open term *)
+  val partial_solution : Evd.evar_map -> goal -> Term.constr -> Evd.evar_map
+   
+  (* Principal part of the weak-progress tactical *)
+  val weak_progress : goal list Evd.sigma -> goal Evd.sigma -> bool
+   
+  (* Principal part of the progress tactical *)
+  val progress : goal list Evd.sigma -> goal Evd.sigma -> bool
+    
+ (* Principal part of tclNOTSAMEGOAL *)
+  val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool
+
+ (* Used for congruence closure *)
+  val new_goal_with : Evd.evar_map -> goal ->  Environ.named_context_val -> goal Evd.sigma 
+
+  (* Used by the typeclasses *)
+  val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map
+
+  (* Goal represented as a type, doesn't take into account section variables *)
+  val abstract_type : Evd.evar_map -> goal -> Term.types 
+
+end
diff --git a/proofs/logic.ml b/proofs/logic.ml
index d837dca5..a363c6bb 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: logic.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Pp
 open Util
 open Names
@@ -21,7 +20,6 @@ open Reductionops
 open Inductive
 open Inductiveops
 open Typing
-open Proof_trees
 open Proof_type
 open Typeops
 open Type_errors
@@ -48,18 +46,18 @@ exception RefinerError of refiner_error
 open Pretype_errors
 
 let rec catchable_exception = function
-  | Stdpp.Exc_located(_,e) -> catchable_exception e
+  | Loc.Exc_located(_,e) -> catchable_exception e
   | LtacLocated(_,e) -> catchable_exception e
-  | Util.UserError _ | TypeError _
+  | Util.UserError _ | TypeError _ | PretypeError (_,_,TypingError _)
   | RefinerError _ | Indrec.RecursionSchemeError _
-  | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _)
+  | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _)
   (* reduction errors *)
   | Tacred.ReductionTacticError _ 
   (* unification errors *)
-  | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
+  | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
 		   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
 		   |CannotFindWellTypedAbstraction _|OccurCheck _
-		   |UnsolvableImplicit _)) -> true
+		   |UnsolvableImplicit _|AbstractionOverMeta _)) -> true
   | Typeclasses_errors.TypeClassError
       (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
   | _ -> false
@@ -327,53 +325,59 @@ let goal_type_of env sigma c =
   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
-  let hyps = goal.evar_hyps in
-  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 _ = conv_leq_goal env sigma trm t'ty conclty in
-      (goalacc,t'ty)
-  else
-*)
+  let env = Goal.V82.env sigma goal in
+  let hyps = Goal.V82.hyps sigma goal in
+  let mk_goal hyps concl =
+    Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal)
+  in
   match kind_of_term trm with
     | Meta _ ->
 	let conclty = nf_betaiota sigma conclty in
 	  if !check && occur_meta conclty then
 	    raise (RefinerError (MetaInType conclty));
-	  (mk_goal hyps conclty)::goalacc, conclty
+	  let (gl,ev,sigma) = mk_goal hyps conclty in
+	  gl::goalacc, conclty, sigma, ev
 
-    | Cast (t,_, ty) ->
+    | Cast (t,k, ty) ->
 	check_typability env sigma ty;
 	check_conv_leq_goal env sigma trm ty conclty;
-	mk_refgoals sigma goal goalacc ty t
+	let res = mk_refgoals sigma goal goalacc ty t in
+	(** we keep the casts (in particular VMcast) except
+	    when they are annotating metas *)
+	if isMeta t then begin
+	  assert (k <> VMcast);
+	  res
+	end else
+	  let (gls,cty,sigma,trm) = res in
+	  (gls,cty,sigma,mkCast(trm,k,ty))
 
     | App (f,l) ->
-	let (acc',hdty) =
+	let (acc',hdty,sigma,applicand) =
 	  match kind_of_term f with
 	    | Ind _ | Const _
 		when (isInd f or has_polymorphic_type (destConst f)) ->
 		(* Sort-polymorphism of definition and inductive types *)
 		goalacc,
-                type_of_global_reference_knowing_conclusion env sigma f conclty
+                type_of_global_reference_knowing_conclusion env sigma f conclty,
+		sigma, f
 	    | _ ->
 		mk_hdgoals sigma goal goalacc f
 	in
-	let (acc'',conclty') =
+	let (acc'',conclty',sigma, args) =
 	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
 	check_conv_leq_goal env sigma trm conclty' conclty;
-        (acc'',conclty')
+        (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args))
 
-    | Case (_,p,c,lf) ->
-	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
+    | Case (ci,p,c,lf) ->
+	let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in
 	check_conv_leq_goal env sigma trm conclty' conclty;
-	let acc'' =
+	let (acc'',sigma, rbranches) =
 	  array_fold_left2
-            (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
-            acc' lbrty lf
+            (fun (lacc,sigma,bacc) ty fi ->
+	       let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc))
+            (acc',sigma,[]) lbrty lf
 	in
-	(acc'',conclty')
+	(acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches)))
 
     | _ ->
 	if occur_meta trm then
@@ -381,70 +385,77 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
 
       	let t'ty = goal_type_of env sigma trm in
 	check_conv_leq_goal env sigma trm t'ty conclty;
-        (goalacc,t'ty)
+        (goalacc,t'ty,sigma, trm)
 
-(* Same as mkREFGOALS but without knowing te type of the term. Therefore,
+(* Same as mkREFGOALS but without knowing the type of the term. Therefore,
  * Metas should be casted. *)
 
 and mk_hdgoals sigma goal goalacc trm =
-  let env = evar_env goal in
-  let hyps = goal.evar_hyps in
-  let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
+  let env = Goal.V82.env sigma goal in
+  let hyps = Goal.V82.hyps sigma goal in
+  let mk_goal hyps concl = 
+    Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
   match kind_of_term trm with
     | Cast (c,_, ty) when isMeta c ->
 	check_typability env sigma ty;
-	(mk_goal hyps (nf_betaiota sigma ty))::goalacc,ty
+	let (gl,ev,sigma) = mk_goal hyps (nf_betaiota sigma ty) in
+	gl::goalacc,ty,sigma,ev
 
     | Cast (t,_, ty) ->
 	check_typability env sigma ty;
 	mk_refgoals sigma goal goalacc ty t
 
     | App (f,l) ->
-	let (acc',hdty) =
+	let (acc',hdty,sigma,applicand) =
 	  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)
+	   (goalacc,type_of_global_reference_knowing_parameters env sigma f l,sigma,f)
 	  else mk_hdgoals sigma goal goalacc f
 	in
-	mk_arggoals sigma goal acc' hdty (Array.to_list l)
+	let (acc'',conclty',sigma, args) =
+	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
+	(acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args))
 
-    | Case (_,p,c,lf) ->
-	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
-	let acc'' =
+    | Case (ci,p,c,lf) ->
+	let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in
+	let (acc'',sigma,rbranches) =
 	  array_fold_left2
-            (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
-            acc' lbrty lf
+            (fun (lacc,sigma,bacc) ty fi ->
+	       let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc))
+            (acc',sigma,[]) lbrty lf
 	in
-	(acc'',conclty')
+	(acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches)))
 
     | _ ->
 	if !check && occur_meta trm then
 	  anomaly "refine called with a dependent meta";
-	goalacc, goal_type_of env sigma trm
+	goalacc, goal_type_of env sigma trm, sigma, trm
 
 and mk_arggoals sigma goal goalacc funty = function
-  | [] -> goalacc,funty
+  | [] -> goalacc,funty,sigma, []
   | harg::tlargs as allargs ->
-      let t = whd_betadeltaiota (evar_env goal) sigma funty in
+      let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in
       match kind_of_term t with
 	| Prod (_,c1,b) ->
-	    let (acc',hargty) = mk_refgoals sigma goal goalacc c1 harg in
-	    mk_arggoals sigma goal acc' (subst1 harg b) tlargs
+	    let (acc',hargty,sigma,arg') = mk_refgoals sigma goal goalacc c1 harg in
+	    let (acc'',fty, sigma', args) =
+	      mk_arggoals sigma goal acc' (subst1 harg b) tlargs in
+	    (acc'',fty,sigma',arg'::args)
 	| LetIn (_,c1,_,b) ->
 	    mk_arggoals sigma goal goalacc (subst1 c1 b) allargs
 	| _ -> raise (RefinerError (CannotApply (t,harg)))
 
 and mk_casegoals sigma goal goalacc p c =
-  let env = evar_env goal in
-  let (acc',ct) = mk_hdgoals sigma goal goalacc c in
-  let (acc'',pt) = mk_hdgoals sigma goal acc' p in
+  let env = Goal.V82.env sigma goal in
+  let (acc',ct,sigma,c') = mk_hdgoals sigma goal goalacc c in
+  let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in
   let indspec =
-    try find_mrectype env sigma ct
+    try Tacred.find_hnf_rectype env sigma ct
     with Not_found -> anomaly "mk_casegoals" in
   let (lbrty,conclty) =
     type_case_branches_with_names env indspec p c in
-  (acc'',lbrty,conclty)
+  (acc'',lbrty,conclty,sigma,p',c')
 
 
 let convert_hyp sign sigma (id,b,bt as d) =
@@ -462,18 +473,6 @@ let convert_hyp sign sigma (id,b,bt as d) =
        d) in
   reorder_val_context env sign' !reorder
 
-(* Normalizing evars in a goal. Called by tactic Local_constraints
-   (i.e. when the sigma of the proof tree changes). Detect if the
-   goal is unchanged *)
-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
-	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
-
 
 
 (************************************************************************)
@@ -481,10 +480,12 @@ let norm_goal sigma gl =
 (* Primitive tactics are handled here *)
 
 let prim_refiner r sigma goal =
-  let env = evar_env goal in
-  let sign = goal.evar_hyps in
-  let cl = goal.evar_concl in
-  let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
+  let env = Goal.V82.env sigma goal in
+  let sign = Goal.V82.hyps sigma goal in
+  let cl = Goal.V82.concl sigma goal in
+  let mk_goal hyps concl = 
+    Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) 
+  in
   match r with
     (* Logical rules *)
     | Intro id ->
@@ -492,19 +493,23 @@ let prim_refiner r sigma goal =
 	  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)
+	       let (sg,ev,sigma) = mk_goal (push_named_context_val (id,None,c1) sign)
 			  (subst1 (mkVar id) b) in
+               let sigma = 
+		 Goal.V82.partial_solution sigma goal (mkNamedLambda id c1 ev) in
 	       ([sg], sigma)
 	   | LetIn (_,c1,t1,b) ->
-	       let sg =
+	       let (sg,ev,sigma) =
 		 mk_goal (push_named_context_val (id,Some c1,t1) sign)
 		   (subst1 (mkVar id) b) in
+	       let sigma = 
+		 Goal.V82.partial_solution sigma goal (mkNamedLetIn id c1 t1 ev) in
 	       ([sg], sigma)
 	   | _ ->
 	       raise (RefinerError IntroNeedsProduct))
 
     | Cut (b,replace,id,t) ->
-        let sg1 = mk_goal sign (nf_betaiota sigma t) in
+        let (sg1,ev1,sigma) = mk_goal sign (nf_betaiota sigma t) in
 	let sign,cl,sigma =
 	  if replace then
 	    let nexthyp = get_hyp_after id (named_context_of_val sign) in
@@ -516,7 +521,10 @@ let prim_refiner r sigma goal =
             (if !check && mem_named_context id (named_context_of_val sign) then
 	      error ("Variable " ^ string_of_id id ^ " is already declared.");
 	     push_named_context_val (id,None,t) sign,cl,sigma) in
-        let sg2 = mk_goal sign cl in
+        let (sg2,ev2,sigma) = 
+	  Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in
+	let oterm = Term.mkApp (Term.mkNamedLambda id t ev2 , [| ev1 |]) in
+	let sigma = Goal.V82.partial_solution sigma goal oterm in
         if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma)
 
     | FixRule (f,n,rest,j) ->
@@ -546,9 +554,24 @@ let prim_refiner r sigma goal =
 		  ("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
+	      Goal.list_map (fun sigma (_,_,c) ->
+				                   let (gl,ev,sig')=
+				                     Goal.V82.mk_goal sigma sign c
+						             (Goal.V82.extra sigma goal)
+						   in ((gl,ev),sig'))
+		                              all sigma
 	in
-	  (mk_sign sign all, sigma)
+	let (gls_evs,sigma) =  mk_sign sign all in
+	let (gls,evs) = List.split gls_evs in
+	let ids = List.map pi1 all in
+	let evs = List.map (Term.subst_vars (List.rev ids)) evs in
+	let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in
+	let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
+	let typarray = Array.of_list (List.map pi3 all) in
+	let bodies = Array.of_list evs in
+	let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in
+	let sigma = Goal.V82.partial_solution sigma goal oterm in
+	(gls,sigma)
 
     | Cofix (f,others,j) ->
      	let rec check_is_coind env cl =
@@ -573,32 +596,56 @@ let prim_refiner r sigma goal =
               with
               |	Not_found ->
                   mk_sign (push_named_context_val (f,None,ar) sign) oth)
-	  | [] -> List.map (fun (_,c) -> mk_goal sign c) all
+	  | [] -> Goal.list_map (fun sigma(_,c) ->
+				                       let (gl,ev,sigma) =
+				                         Goal.V82.mk_goal sigma sign c
+							   (Goal.V82.extra sigma goal)
+						       in
+				                       ((gl,ev),sigma))
+	                                             all sigma                                      
      	in
-	  (mk_sign sign all, sigma)
+	let (gls_evs,sigma) =  mk_sign sign all in
+	let (gls,evs) = List.split gls_evs in
+	let (ids,types) = List.split all in
+	let evs = List.map (Term.subst_vars (List.rev ids)) evs in
+	let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
+	let typarray = Array.of_list types in
+	let bodies = Array.of_list evs in
+	let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in
+	let sigma = Goal.V82.partial_solution sigma goal oterm in
+        (gls,sigma)
 
     | Refine c ->
 	check_meta_variables c;
-	let (sgl,cl') = mk_refgoals sigma goal [] cl c in
+	let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in
 	let sgl = List.rev sgl in
+	let sigma = Goal.V82.partial_solution sigma goal oterm in
 	  (sgl, sigma)
 
     (* Conversion rules *)
-    | Convert_concl (cl',_) ->
+    | Convert_concl (cl',k) ->
 	check_typability env sigma cl';
 	if (not !check) || is_conv_leq env sigma cl' cl then
-          let sg = mk_goal sign cl' in
+          let (sg,ev,sigma) = mk_goal sign cl' in
+	  let ev = if k<>DEFAULTcast then mkCast(ev,k,cl) else ev in
+	  let sigma = Goal.V82.partial_solution sigma goal ev in
           ([sg], sigma)
 	else
 	  error "convert-concl rule passed non-converting term"
 
     | Convert_hyp (id,copt,ty) ->
-	([mk_goal (convert_hyp sign sigma (id,copt,ty)) cl], sigma)
+	let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
+	([gl], sigma)
 
     (* And now the structural rules *)
     | Thin ids ->
 	let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in
-	  ([mk_goal hyps concl], nsigma)
+	let (gl,ev,sigma) =
+	  Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal)
+	in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
+	  ([gl], sigma)
 
     | ThinBody ids ->
 	let clear_aux env id =
@@ -607,7 +654,8 @@ let prim_refiner r sigma goal =
             env'
 	in
 	let sign' = named_context_val (List.fold_left clear_aux env ids) in
-     	let sg = mk_goal sign' cl in
+     	let (sg,ev,sigma) = mk_goal sign' cl in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
      	  ([sg], sigma)
 
     | Move (withdep, hfrom, hto) ->
@@ -615,11 +663,15 @@ let prim_refiner r sigma goal =
 	  split_sign hfrom hto (named_context_of_val sign) in
   	let hyps' =
 	  move_hyp withdep toleft (left,declfrom,right) hto in
-  	  ([mk_goal hyps' cl], sigma)
+	let (gl,ev,sigma) = mk_goal hyps' cl in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
+  	  ([gl], sigma)
 
     | Order ord ->
         let hyps' = reorder_val_context env sign ord in
-        ([mk_goal hyps' cl], sigma)
+	let (gl,ev,sigma) = mk_goal hyps' cl in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
+        ([gl], sigma)
 
     | Rename (id1,id2) ->
         if !check & id1 <> id2 &&
@@ -627,12 +679,19 @@ let prim_refiner r sigma goal =
           error ((string_of_id id2)^" is already used.");
         let sign' = rename_hyp id1 id2 sign in
         let cl' = replace_vars [id1,mkVar id2] cl in
-          ([mk_goal sign' cl'], sigma)
+	let (gl,ev,sigma) = mk_goal sign' cl' in
+	let ev = Term.replace_vars [(id2,mkVar id1)] ev in
+	let sigma = Goal.V82.partial_solution sigma goal ev in
+          ([gl], sigma)
 
     | Change_evars ->
-        match norm_goal sigma goal with
-	    Some ngl -> ([ngl],sigma)
-          | None -> ([goal], sigma)
+	(* spiwack: a priori [Change_evars] is now devoid of operational content.
+	    The new proof engine keeping the evar_map up to date at all time.
+	    As a compatibility mesure I leave the rule. 
+	    It is possible that my assumption is wrong and some uses of 
+	    [Change_evars] are not subsumed by the new engine. In which
+	    case something has to be done here. (Feb. 2010) *)
+	([goal],sigma)
 
 (************************************************************************)
 (************************************************************************)
@@ -644,27 +703,6 @@ type variable_proof_status = ProofVar | SectionVar of identifier
 
 type proof_variable = name * variable_proof_status
 
-let subst_proof_vars =
-  let rec aux p vars =
-    let _,subst =
-      List.fold_left (fun (n,l) var ->
-        let t = match var with
-          | Anonymous,_ -> l
-          | Name id, ProofVar -> (id,mkRel n)::l
-          | Name id, SectionVar id' -> (id,mkVar id')::l in
-        (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 ->
-      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 rec aux n = function
     | (Name id,ProofVar)::l when x = id -> n
@@ -672,77 +710,3 @@ let proof_variable_index x =
     | [] -> raise Not_found
   in
   aux 1
-
-let prim_extractor subfun vl pft =
-  let cl = pft.goal.evar_concl in
-    match pft.ref with
-      | Some (Prim (Intro id), [spf]) ->
-	  (match kind_of_term (strip_outer_cast cl) with
-	    | Prod (_,ty,_) ->
-		let cty = subst_proof_vars vl ty in
-		  mkLambda (Name id, cty, subfun (add_proof_var id vl) spf)
-	    | LetIn (_,b,ty,_) ->
-		let cb = subst_proof_vars vl b in
-		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,
-                    subfun (add_proof_var id vl) spf2)
-
-      | Some (Prim (FixRule (f,n,others,j)),spfl) ->
-	  let firsts,lasts = list_chop j others in
-	  let all = Array.of_list (firsts@(f,n,cl)::lasts) in
-	  let lcty = Array.map (fun (_,_,ar) -> subst_proof_vars vl ar) all in
-	  let names = Array.map (fun (f,_,_) -> Name f) all in
-	  let vn = Array.map (fun (_,n,_) -> n-1) all in
-	  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))
-
-      | Some (Prim (Cofix (f,others,j)),spfl) ->
-	  let firsts,lasts = list_chop j others in
-	  let all = Array.of_list (firsts@(f,cl)::lasts) in
-	  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
-	  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
-	    plain_instance metamap cc
-
-      (* Structural and conversion rules do not produce any proof *)
-      | Some (Prim (Convert_concl (t,k)),[pf]) ->
-	  if k = DEFAULTcast then subfun vl pf
-	  else mkCast (subfun vl pf,k,subst_proof_vars vl cl)
-      | Some (Prim (Convert_hyp _),[pf]) ->
-	  subfun vl pf
-
-      | 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
-
-      | Some (Prim (Rename (id1,id2)),[pf]) ->
-	  subfun (rebind id1 id2 vl) pf
-
-      | Some (Prim Change_evars, [pf]) ->
-	  subfun vl pf
-
-      | Some _ -> anomaly "prim_extractor"
-
-      | None-> error "prim_extractor handed incomplete proof"
-
diff --git a/proofs/logic.mli b/proofs/logic.mli
index da2566a7..420e6374 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -1,28 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: logic.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Sign
 open Evd
 open Environ
 open Proof_type
-(*i*)
 
-(* This suppresses check done in [prim_refiner] for the tactic given in
+(** This suppresses check done in [prim_refiner] for the tactic given in
    argument; works by side-effect *)
 
 val with_check    : tactic -> tactic
 
-(* [without_check] respectively means:\\
+(** [without_check] respectively means:\\
   [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\\
@@ -32,19 +28,16 @@ val with_check    : tactic -> tactic
   no check that the name exist and that its type is convertible\\
 *)
 
-(* The primitive refiner. *)
+(** The primitive refiner. *)
 
 val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map
 
 type proof_variable
 
-val prim_extractor :
-  (proof_variable list -> proof_tree -> constr)
-  -> proof_variable list -> proof_tree -> constr
 
 val proof_variable_index : identifier -> proof_variable list -> int
 
-(*s Refiner errors. *)
+(** {6 Refiner errors. } *)
 
 type refiner_error =
 
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index a9799f38..3d507f35 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pfedit.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,322 +18,139 @@ open Environ
 open Evd
 open Typing
 open Refiner
-open Proof_trees
 open Tacexpr
 open Proof_type
 open Lib
 open Safe_typing
 
-(*********************************************************************)
-(* Managing the proofs state                                         *)
-(* 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 : lemma_possible_guards;
-  top_goal : goal;
-  top_strength : Decl_kinds.goal_kind;
-  top_hook : declaration_hook }
-
-let proof_edits =
-  (Edit.empty() : (identifier,pftreestate,proof_topstate) Edit.t)
-
-let get_all_proof_names () = Edit.dom proof_edits
-
-let msg_proofs use_resume =
-  match Edit.dom proof_edits with
-    | [] -> (spc () ++ str"(No proof-editing in progress).")
-    | l ->  (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++
-               (prlist_with_sep pr_spc pr_id (get_all_proof_names ())) ++
-	       str"." ++
-               (if use_resume then (fnl () ++ str"Use \"Resume\" first.")
-              	else (mt ()))
-)
-
-let undo_default = 50
-let undo_limit = ref undo_default
-
-(*********************************************************************)
-(*    Functions for decomposing and modifying the proof state        *)
-(*********************************************************************)
+let refining = Proof_global.there_are_pending_proofs
+let check_no_pending_proofs = Proof_global.check_no_pending_proof
 
-let get_state () =
-  match Edit.read proof_edits with
-    | None -> errorlabstrm "Pfedit.get_state"
-          (str"No focused proof" ++ msg_proofs true)
-    | Some(_,pfs,ts) -> (pfs,ts)
+let get_current_proof_name = Proof_global.get_current_proof_name
+let get_all_proof_names = Proof_global.get_all_proof_names
 
-let get_topstate ()    = snd(get_state())
-let get_pftreestate () = fst(get_state())
+type lemma_possible_guards = Proof_global.lemma_possible_guards
 
-let get_end_tac () = let ts = get_topstate () in ts.top_end_tac
+let delete_proof = Proof_global.discard
+let delete_current_proof = Proof_global.discard_current
+let delete_all_proofs = Proof_global.discard_all
 
-let get_goal_context n =
-  let pftree = get_pftreestate () in
-  let goal = nth_goal_of_pftreestate n pftree in
-  (project goal, pf_env goal)
+let undo n = 
+  let p = Proof_global.give_me_the_proof () in
+  for i = 1 to n do
+    Proof.undo p
+  done
 
-let get_current_goal_context () = get_goal_context 1
-
-let set_current_proof = Edit.focus proof_edits
-
-let resume_proof (loc,id) =
+let current_proof_depth () =
   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 p = Proof_global.give_me_the_proof () in
+    Proof.V82.depth p
+  with Proof_global.NoCurrentProof -> -1
 
-let suspend_proof () =
-  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 ->
-	Edit.focus proof_edits p
-
-let get_current_proof_name () =
-  match Edit.read proof_edits with
-    | None ->
-        errorlabstrm "Pfedit.get_proof"
-          (str"No focused proof" ++ msg_proofs true)
-    | Some(na,_,_) -> na
-
-let add_proof (na,pfs,ts) =
-  Edit.create proof_edits (na,pfs,ts,!undo_limit+1)
-
-let delete_proof_gen = Edit.delete proof_edits
-
-let delete_proof (loc,id) =
-  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 =
+(* [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d
+   is the depth of the focus stack). *)
+let undo_todepth n =
   try
-    Edit.mutate proof_edits (fun _ pfs -> f pfs)
-  with Invalid_argument "Edit.mutate" ->
-    errorlabstrm "Pfedit.mutate"
-      (str"No focused proof" ++ msg_proofs true)
+    undo ((current_proof_depth ()) - n )
+  with Proof_global.NoCurrentProof  when n=0 -> ()
 
-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 set_undo _ = ()
+let get_undo _ = None
 
-let restart_proof () =
-  match Edit.read proof_edits with
-    | None ->
-	errorlabstrm "Pfedit.restart"
-          (str"No focused proof to restart" ++ msg_proofs true)
-    | 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 pts = get_pftreestate () in
-  is_complete_proof (proof_of_pftreestate pts) &
-  not (is_top_pftreestate pts)
-
-let tree_solved () =
-  let pts = get_pftreestate () in
-  is_complete_proof (proof_of_pftreestate pts)
-
-let top_tree_solved () =
-  let pts = get_pftreestate () in
-  is_complete_proof (proof_of_pftreestate (top_of_tree pts))
-
-(*********************************************************************)
-(*                 Undo functions                                    *)
-(*********************************************************************)
-
-let set_undo = function
-  | None -> undo_limit := undo_default
-  | Some n ->
-      if n>=0 then
-	undo_limit := n
-      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
-       subtree - this solution only works properly if undoing one step *)
-    if subtree_solved() then  Edit.undo proof_edits 1
-  with (Invalid_argument "Edit.undo") ->
-    errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true)
-
-(* Undo current focused proof to reach depth [n]. This is used in
-   [vernac_backtrack]. *)
-let undo_todepth n =
-  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() =
-  try
-    Edit.depth proof_edits
-  with (Invalid_argument "Edit.depth") -> -1
+let start_proof id str hyps c ?init_tac ?compute_guard hook = 
+  let goals = [ (Global.env_of_context hyps , c) ] in
+  let init_tac = Option.map Proofview.V82.tactic init_tac in
+  Proof_global.start_proof id str goals ?compute_guard hook;
+  Option.iter Proof_global.run_tactic init_tac
 
-(*********************************************************************)
-(*                  Proof cooking                                    *)
-(*********************************************************************)
+let restart_proof () =
+  let p = Proof_global.give_me_the_proof () in
+  try while true do
+    Proof.undo p
+  done with Proof.EmptyUndoStack -> ()
+
+let resume_last_proof () = Proof_global.resume_last ()
+let resume_proof (_,id) = Proof_global.resume id
+let suspend_proof ()  =  Proof_global.suspend ()
+
+let cook_proof hook =
+  let prf = Proof_global.give_me_the_proof () in
+  hook prf;
+  match Proof_global.close_proof () with
+  | (i,([e],cg,str,h)) -> (i,(e,cg,str,h))
+  | _ -> Util.anomaly "Pfedit.cook_proof: more than one proof term."
 
 let xml_cook_proof = ref (fun _ -> ())
 let set_xml_cook_proof f = xml_cook_proof := f
 
-let cook_proof k =
-  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
-  let pfterm = extract_pftreestate pfs in
-  !xml_cook_proof (strength,pfs);
-  k pfs;
-  (ident,
-   ({ const_entry_body = pfterm;
-      const_entry_type = Some concl;
-      const_entry_opaque = true;
-      const_entry_boxed = false},
-    ts.top_compute_guard, strength, ts.top_hook))
-
-let current_proof_statement () =
-  let ts = get_topstate() in
-  (get_current_proof_name (), ts.top_strength,
-   ts.top_goal.evar_concl, ts.top_hook)
-
-(*********************************************************************)
-(*              Abort   functions                                    *)
-(*********************************************************************)
+let get_pftreestate () =
+  Proof_global.give_me_the_proof ()
 
-let refining () = [] <> (Edit.dom proof_edits)
+let set_end_tac tac =
+  let tac = Proofview.V82.tactic tac in
+  Proof_global.set_endline_tactic tac
+
+let set_used_variables l =
+  Proof_global.set_used_variables l
+let get_used_variables () =
+  Proof_global.get_used_variables ()
+
+exception NoSuchGoal
+let _ = Errors.register_handler begin function
+  | NoSuchGoal -> Util.error "No such goal."
+  | _ -> raise Errors.Unhandled
+end
+let get_nth_V82_goal i =
+  let p = Proof_global.give_me_the_proof () in
+  let { it=goals ; sigma = sigma } = Proof.V82.subgoals p in
+  try
+    { it=(List.nth goals (i-1)) ; sigma=sigma }
+  with Failure _ -> raise NoSuchGoal
+    
+let get_goal_context_gen i =
+  try
+    let { it=goal ; sigma=sigma } =  get_nth_V82_goal i in
+    (sigma, Refiner.pf_env { it=goal ; sigma=sigma })
+  with Proof_global.NoCurrentProof -> Util.error "No focused proof."
 
-let check_no_pending_proofs () =
-  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).")
+let get_goal_context i =
+  try get_goal_context_gen i
+  with NoSuchGoal -> Util.error "No such goal."
 
-let delete_current_proof () = delete_proof_gen (get_current_proof_name ())
+let get_current_goal_context () =
+  try get_goal_context_gen 1
+  with NoSuchGoal ->
+    (* spiwack: returning empty evar_map, since if there is no goal, under focus,
+        there is no accessible evar either *)
+    (Evd.empty, Global.env ())
 
-let delete_all_proofs () = Edit.clear proof_edits
+let current_proof_statement () =
+  match Proof_global.V82.get_current_initial_conclusions () with
+    | (id,([concl],strength,hook)) -> id,strength,concl,hook
+    | _ -> Util.anomaly "Pfedit.current_proof_statement: more than one statement"
+
+let solve_nth ?(with_end_tac=false) gi tac = 
+  try 
+    let tac = Proofview.V82.tactic tac in
+    let tac = if with_end_tac then 
+                Proof_global.with_end_tac tac
+              else
+		tac
+    in
+    Proof_global.run_tactic (Proofview.tclFOCUS gi gi tac) 
+  with 
+    | Proof_global.NoCurrentProof  -> Util.error "No focused proof"
+    | Proofview.IndexOutOfRange | Failure "list_chop" -> 
+	let msg = str "No such goal: " ++ int gi ++ str "." in
+	Util.errorlabstrm "" msg
+
+let by = solve_nth 1
+
+let instantiate_nth_evar_com n com = 
+  let pf = Proof_global.give_me_the_proof () in
+  Proof.V82.instantiate_evar n com pf
 
-(*********************************************************************)
-(*   Modifying the end tactic of the current profftree               *)
-(*********************************************************************)
-let set_end_tac tac =
-  let top = get_topstate () in
-  top.top_end_tac <- Some tac
-
-(*********************************************************************)
-(*              Modifying the current prooftree                      *)
-(*********************************************************************)
-
-let start_proof na str sign concl ?init_tac ?(compute_guard=[]) hook =
-  let top_goal = mk_goal sign concl None in
-  let ts = {
-    top_end_tac = None;
-    top_init_tac = init_tac;
-    top_compute_guard = compute_guard;
-    top_goal = top_goal;
-    top_strength = str;
-    top_hook = hook}
-  in
-  start(na,ts);
-  set_current_proof na
-
-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
-    error "cannot apply a tactic when we are descended behind a tactic-node"
-
-let by tac = mutate (solve_pftreestate tac)
-
-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
-   [path].
-
-   ALGORITHM: The algorithm works on reversed paths. One just has to remove
-   the common part on the reversed paths.
-
-*)
-
-let common_ancestor l1 l2 =
-  let rec common_aux l1 l2 =
-    match l1, l2 with
-      | a1::l1', a2::l2' when a1 = a2 -> common_aux 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))
-
-let rec traverse_down = function
-  | [] -> (function pf -> pf)
-  | n::l -> (function pf -> Refiner.traverse n (traverse_down l pf))
-
-let traverse_to path =
-  let up_and_down path pfs =
-    let cursor = cursor_of_pftreestate pfs in
-    let down_list, up_count = common_ancestor path cursor in
-    traverse_down down_list (traverse_up up_count pfs)
-  in
-  mutate (up_and_down path)
-
-(* traverse the proof tree until it reach the nth subgoal *)
-let traverse_nth_goal n = mutate (nth_unproven n)
-
-let traverse_prev_unproven () = mutate prev_unproven
-
-let traverse_next_unproven () = mutate next_unproven
-
-(* The goal focused on *)
-let focus_n = ref 0
-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 () =
-  mutate top_of_tree
-
-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 *)
@@ -355,7 +170,26 @@ let build_constant_by_tactic id sign typ tac =
     delete_current_proof ();
     raise e
 
-let build_by_tactic typ tac =
+let build_by_tactic env typ tac =
   let id = id_of_string ("temporary_proof"^string_of_int (next())) in
-  let sign = Decls.clear_proofs (Global.named_context ()) in
+  let sign = val_of_named_context (named_context env) in
   (build_constant_by_tactic id sign typ tac).const_entry_body
+
+(**********************************************************************)
+(* Support for resolution of evars in tactic interpretation, including
+   resolution by application of tactics *)
+
+let implicit_tactic = ref None
+
+let declare_implicit_tactic tac = implicit_tactic := Some tac
+
+let solve_by_implicit_tactic env sigma (evk,args) =
+  let evi = Evd.find_undefined sigma evk in
+  match (!implicit_tactic, snd (evar_source evk sigma)) with
+  | Some tac, (ImplicitArg _ | QuestionMark _)
+      when
+	Sign.named_context_equal (Environ.named_context_of_val evi.evar_hyps)
+	(Environ.named_context env) ->
+      (try build_by_tactic env evi.evar_concl (tclCOMPLETE tac)
+       with e when Logic.catchable_exception e -> raise Exit)
+  | _ -> raise Exit
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index 05c329c1..7297b975 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pfedit.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Pp
 open Names
@@ -18,190 +15,179 @@ open Environ
 open Decl_kinds
 open Tacmach
 open Tacexpr
-(*i*)
 
-(*s Several proofs can be opened simultaneously but at most one is
+(** Several proofs can be opened simultaneously but at most one is
    focused at some time. The following functions work by side-effect
    on current set of open proofs. In this module, ``proofs'' means an
    open proof (something started by vernacular command [Goal], [Lemma]
    or [Theorem]), and ``goal'' means a subgoal of the current focused
    proof *)
 
-(*s [refining ()] tells if there is some proof in progress, even if a not
+(** {6 ... } *)
+(** [refining ()] tells if there is some proof in progress, even if a not
    focused one *)
 
 val refining : unit -> bool
 
-(* [check_no_pending_proofs ()] fails if there is still some proof in
+(** [check_no_pending_proofs ()] fails if there is still some proof in
    progress *)
 
 val check_no_pending_proofs : unit -> unit
 
-(*s [delete_proof name] deletes proof of name [name] or fails if no proof
+(** {6 ... } *)
+(** [delete_proof name] deletes proof of name [name] or fails if no proof
     has this name *)
 
 val delete_proof : identifier located -> unit
 
-(* [delete_current_proof ()] deletes current focused proof or fails if
+(** [delete_current_proof ()] deletes current focused proof or fails if
     no proof is focused *)
 
 val delete_current_proof : unit -> unit
 
-(* [delete_all_proofs ()] deletes all open proofs if any *)
+(** [delete_all_proofs ()] deletes all open proofs if any *)
 
 val delete_all_proofs : unit -> unit
 
-(*s [undo n] undoes the effect of the last [n] tactics applied to the
+(** {6 ... } *)
+(** [undo n] undoes the effect of the last [n] tactics applied to the
     current proof; it fails if no proof is focused or if the ``undo''
     stack is exhausted *)
 
 val undo : int -> unit
 
-(* Same as undo, but undoes the current proof stack to reach depth
-   [n]. This is used in [vernac_backtrack]. *)
-val undo_todepth : int -> unit
+(** [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d
+   is the depth of the undo stack). *)
+val undo_todepth : int -> unit 
 
-(* Returns the depth of the current focused proof stack, this is used
+(** Returns the depth of the current focused proof stack, this is used
    to put informations in coq prompt (in emacs mode). *)
 val current_proof_depth: unit -> int
 
-(* [set_undo (Some n)] sets the size of the ``undo'' stack; [set_undo None]
-   sets the size to the default value (12) *)
-
-val set_undo : int option -> unit
-val get_undo : unit -> int option
-
-(*s [start_proof s str env t hook tac] starts a proof of name [s] and
+(** {6 ... } *)
+(** [start_proof s str env t hook tac] starts a proof of name [s] and
     conclusion [t]; [hook] is optionally a function to be applied at
     proof end (e.g. to declare the built constructions as a coercion
     or a setoid morphism); init_tac is possibly a tactic to
     systematically apply at initialization time (e.g. to start the
     proof of mutually dependent theorems) *)
 
-type lemma_possible_guards = int list list
+type lemma_possible_guards = Proof_global.lemma_possible_guards
 
 val start_proof :
   identifier -> goal_kind -> named_context_val -> constr ->
   ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> 
   declaration_hook -> unit
 
-(* [restart_proof ()] restarts the current focused proof from the beginning
+(** [restart_proof ()] restarts the current focused proof from the beginning
    or fails if no proof is focused *)
 
 val restart_proof : unit -> unit
 
-(*s [resume_last_proof ()] focus on the last unfocused proof or fails
+(** {6 ... } *)
+(** [resume_last_proof ()] focus on the last unfocused proof or fails
    if there is no suspended proofs *)
 
 val resume_last_proof : unit -> unit
 
-(* [resume_proof name] focuses on the proof of name [name] or
-   raises [UserError] if no proof has name [name] *)
+(** [resume_proof name] focuses on the proof of name [name] or
+   raises [NoSuchProof] if no proof has name [name]. 
+
+    It doesn't [suspend_proof ()] before. *)
 
 val resume_proof : identifier located -> unit
 
-(* [suspend_proof ()] unfocuses the current focused proof or
+(** [suspend_proof ()] unfocuses the current focused proof or
    failed with [UserError] if no proof is currently focused *)
 
 val suspend_proof : unit -> unit
 
-(*s [cook_proof opacity] turns the current proof (assumed completed) into
+(** {6 ... } *)
+(** [cook_proof opacity] turns the current proof (assumed completed) into
     a constant with its name, kind and possible hook (see [start_proof]);
     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) ->
+val cook_proof : (Proof.proof -> unit) ->
   identifier *
-  (Entries.definition_entry * lemma_possible_guards * goal_kind * 
-   declaration_hook)
+    (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
+(** To export completed proofs to xml *)
+val set_xml_cook_proof : (goal_kind * Proof.proof -> unit) -> unit
 
-(*s [get_pftreestate ()] returns the current focused pending proof or
+(** {6 ... } *)
+(** [get_Proof.proof ()] returns the current focused pending proof or
    raises [UserError "no focused proof"] *)
 
-val get_pftreestate : unit -> pftreestate
+val get_pftreestate : unit -> Proof.proof
 
-(* [get_end_tac ()] returns the current tactic to apply to all new subgoal *)
-
-val get_end_tac : unit -> tactic option
-
-(* [get_goal_context n] returns the context of the [n]th subgoal of
+(** [get_goal_context n] returns the context of the [n]th subgoal of
    the current focused proof or raises a [UserError] if there is no
    focused proof or if there is no more subgoals *)
 
 val get_goal_context : int -> Evd.evar_map * env
 
-(* [get_current_goal_context ()] works as [get_goal_context 1] *)
+(** [get_current_goal_context ()] works as [get_goal_context 1] *)
 
 val get_current_goal_context : unit -> Evd.evar_map * env
 
-(* [current_proof_statement] *)
+(** [current_proof_statement] *)
 
 val current_proof_statement :
   unit -> identifier * goal_kind * types * declaration_hook
 
-(*s [get_current_proof_name ()] return the name of the current focused
+(** {6 ... } *)
+(** [get_current_proof_name ()] return the name of the current focused
     proof or failed if no proof is focused *)
 
 val get_current_proof_name : unit -> identifier
 
-(* [get_all_proof_names ()] returns the list of all pending proof names *)
+(** [get_all_proof_names ()] returns the list of all pending proof names *)
 
 val get_all_proof_names : unit -> identifier list
 
-(*s [set_end_tac tac] applies tactic [tac] to all subgoal generate
+(** {6 ... } *)
+(** [set_end_tac tac] applies tactic [tac] to all subgoal generate
     by [solve_nth] *)
 
 val set_end_tac : tactic -> unit
 
-(*s [solve_nth n tac] applies tactic [tac] to the [n]th subgoal of the
+(** {6 ... } *)
+(** [set_used_variables l] declares that section variables [l] will be
+    used in the proof *)
+val set_used_variables : identifier list -> unit
+val get_used_variables : unit -> Sign.section_context option
+
+(** {6 ... } *)
+(** [solve_nth n tac] applies tactic [tac] to the [n]th subgoal of the
    current focused proof or raises a UserError if no proof is focused or
    if there is no [n]th subgoal *)
 
-val solve_nth : int -> tactic -> unit
+val solve_nth : ?with_end_tac:bool -> int -> tactic -> unit
 
-(* [by tac] applies tactic [tac] to the 1st subgoal of the current
+(** [by tac] applies tactic [tac] to the 1st subgoal of the current
    focused proof or raises a UserError if there is no focused proof or
    if there is no more subgoals *)
 
 val by : tactic -> unit
 
-(* [instantiate_nth_evar_com n c] instantiate the [n]th undefined
+(** [instantiate_nth_evar_com n c] instantiate the [n]th undefined
    existential variable of the current focused proof by [c] or raises a
    UserError if no proof is focused or if there is no such [n]th
    existential variable *)
 
 val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit
 
-(*s To deal with subgoal focus *)
-
-val make_focus : int -> unit
-val focus : unit -> int
-val focused_goal : unit -> int
-val subtree_solved : unit -> bool
-val tree_solved : unit -> bool
-val top_tree_solved : unit -> bool
+(** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *)
 
-val reset_top_of_tree : unit -> unit
-val reset_top_of_script : unit -> unit
-
-val traverse : int -> unit
-val traverse_nth_goal : int -> unit
-val traverse_next_unproven : unit -> unit
-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
+val build_constant_by_tactic : identifier -> named_context_val -> types -> tactic ->
+  Entries.definition_entry
+val build_by_tactic : env -> types -> tactic -> constr
 
+(** Declare the default tactic to fill implicit arguments *)
 
-(* [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *)
+val declare_implicit_tactic : tactic -> unit
 
-val build_constant_by_tactic : identifier -> named_context_val -> types -> tactic ->
-  Entries.definition_entry
-val build_by_tactic : types -> tactic -> constr
+(* Raise Exit if cannot solve *)
+val solve_by_implicit_tactic : env -> Evd.evar_map -> existential -> constr
diff --git a/proofs/proof.ml b/proofs/proof.ml
new file mode 100644
index 00000000..72730495
--- /dev/null
+++ b/proofs/proof.ml
@@ -0,0 +1,458 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Module defining the last essential tiles of interactive proofs.
+   The features of the Proof module are undoing and focusing.
+   A proof is a mutable object, it contains a proofview, and some information
+   to be able to undo actions, and to unfocus the current view. All three
+   of these being meant to evolve.
+   - Proofview: a proof is primarily the data of the current view.
+     That which is shown to the user (as a remainder, a proofview
+     is mainly the logical state of the proof, together with the
+     currently focused goals).
+   - Focus: a proof has a focus stack: the top of the stack contains
+     the context in which to unfocus the current view to a view focused
+     with the rest of the stack.
+     In addition, this contains, for each of the focus context,  a 
+     "focus kind" and a "focus condition" (in practice, and for modularity,
+     the focus kind is actually stored inside the condition). To unfocus, one
+     needs to know the focus kind, and the condition (for instance "no condition" or
+     the proof under focused must be complete) must be met.
+   - Undo: since proofviews and focus stacks are immutable objects, 
+     it could suffice to hold the previous states, to allow to return to the past.
+     However, we also allow other modules to do actions that can be undone.
+     Therefore the undo stack stores action to be ran to undo.
+*)
+
+open Term
+
+type _focus_kind = int
+type 'a focus_kind = _focus_kind
+type focus_info = Obj.t
+type unfocusable =
+  | Cannot
+  | Loose
+  | Strict
+type _focus_condition = 
+    (_focus_kind -> Proofview.proofview -> unfocusable) *
+    (_focus_kind -> focus_info -> focus_info)
+type 'a focus_condition = _focus_condition
+
+let next_kind = ref 0
+let new_focus_kind () =
+  let r = !next_kind in
+  incr next_kind;
+  r
+
+(* Auxiliary function to define conditions:
+   [check kind1 kind2 inf] returns [inf] if [kind1] and [kind2] match.
+   Otherwise it raises [CheckNext] *)
+exception CheckNext
+(* no handler: confined to this module. *)
+let check kind1 kind2 inf =
+  if kind1=kind2 then inf else raise CheckNext
+
+(* To be authorized to unfocus one must meet the condition prescribed by
+    the action which focused.*)
+(* spiwack: we could consider having a list of authorized focus_kind instead
+    of just one, if anyone needs it *)
+(* [no_cond] only checks that the unfocusing command uses the right
+    [focus_kind]. *)
+
+module Cond = struct
+  (* first attempt at an algebra of condition *)
+  (* semantics:
+     - [Cannot] means that the condition is not met
+     - [Strict] that the condition is meant
+     - [Loose] that the condition is not quite meant
+       but authorises to unfocus provided a condition
+       of a previous focus on the stack is (strictly)
+       met.
+  *)
+  let bool b =
+    if b then fun _ _ -> Strict
+    else fun _ _ -> Cannot
+  let loose c k p = match c k p with
+    | Cannot -> Loose
+    | c -> c
+  let cloose l c =
+    if l then loose c
+    else c
+  let (&&&) c1 c2 k p=
+    match c1 k p , c2 k p with
+    | Cannot , _ 
+    | _ , Cannot -> Cannot
+    | Strict, Strict -> Strict
+    | _ , _ -> Loose
+  let kind k0 k p = bool (k0=k) k p 
+  let pdone k p = bool (Proofview.finished p) k p
+end
+
+open Cond
+let no_cond ~loose_end k0 =
+  cloose loose_end (kind k0)
+let no_cond ?(loose_end=false) k = no_cond ~loose_end k , check k
+(* [done_cond] checks that the unfocusing command uses the right [focus_kind]
+    and that the focused proofview is complete. *)
+let done_cond ~loose_end k0 =
+  (cloose loose_end (kind k0)) &&& pdone
+let done_cond ?(loose_end=false) k = done_cond ~loose_end k , check k
+
+
+(* Subpart of the type of proofs. It contains the parts of the proof which
+   are under control of the undo mechanism *)
+type proof_state = {
+  (* Current focused proofview *)
+  proofview: Proofview.proofview;
+  (* History of the focusings, provides information on how
+     to unfocus the proof and the extra information stored while focusing.
+     The list is empty when the proof is fully unfocused. *)
+  focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list;
+  (* Extra information which can be freely used to create new behaviours. *)
+  intel: Store.t
+}
+
+type proof_info = {
+  mutable endline_tactic : unit Proofview.tactic ;
+  mutable section_vars : Sign.section_context option;
+  initial_conclusions : Term.types list
+}
+
+type undo_action = 
+  | State of proof_state
+  | Effect of (unit -> unit)
+
+type proof = { (* current proof_state *)
+               mutable state : proof_state;
+               (* The undo stack *)
+               mutable undo_stack : undo_action list;
+	       (* secondary undo stacks used for transactions *)
+	       mutable transactions : undo_action list list;
+	       info : proof_info
+             }
+
+
+(*** General proof functions ***)
+
+let rec unroll_focus pv = function
+  | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk
+  | [] -> pv
+
+(* spiwack: a proof is considered completed even if its still focused, if the focus
+                   doesn't hide any goal.
+   Unfocusing is handled in {!return}. *)
+let is_done p =
+  Proofview.finished p.state.proofview && 
+  Proofview.finished (unroll_focus p.state.proofview p.state.focus_stack)
+
+(* spiwack: for compatibility with <= 8.2 proof engine *)
+let has_unresolved_evar p =
+  Proofview.V82.has_unresolved_evar p.state.proofview
+
+(* Returns the list of partial proofs to initial goals *)
+let partial_proof p =
+  List.map fst (Proofview.return p.state.proofview)
+
+
+
+(*** The following functions implement the basic internal mechanisms
+     of proofs, they are not meant to be exported in the .mli ***)
+
+(* An auxiliary function to push a {!focus_context} on the focus stack. *)
+let push_focus cond inf context pr =
+  pr.state <- { pr.state with focus_stack = (cond,inf,context)::pr.state.focus_stack }
+
+exception FullyUnfocused
+let _ = Errors.register_handler begin function
+  | FullyUnfocused -> Util.error "The proof is not focused"
+  | _ -> raise Errors.Unhandled
+end
+(* An auxiliary function to read the kind of the next focusing step *)
+let cond_of_focus pr =
+  match pr.state.focus_stack with
+  | (cond,_,_)::_ -> cond
+  | _ -> raise FullyUnfocused
+
+(* An auxiliary function to pop and read the last {!Proofview.focus_context} 
+   on the focus stack. *)
+let pop_focus pr =
+  match pr.state.focus_stack with
+  | focus::other_focuses -> 
+      pr.state <- { pr.state with focus_stack = other_focuses }; focus
+  | _ -> 
+      raise FullyUnfocused
+
+(* Auxiliary function to push a [proof_state] onto the undo stack. *)
+let push_undo save pr =
+  match pr.transactions with
+  | [] -> pr.undo_stack <- save::pr.undo_stack
+  | stack::trans' -> pr.transactions <- (save::stack)::trans'
+
+(* Auxiliary function to pop and read a [save_state] from the undo stack. *)
+exception EmptyUndoStack
+let _ = Errors.register_handler begin function
+  | EmptyUndoStack -> Util.error "Cannot undo: no more undo information"
+  | _ -> raise Errors.Unhandled
+end
+let pop_undo pr =
+  match pr.transactions , pr.undo_stack with
+  | [] , state::stack -> pr.undo_stack <- stack; state
+  | (state::stack)::trans', _ -> pr.transactions <- stack::trans'; state
+  | _ -> raise EmptyUndoStack
+
+
+(* This function focuses the proof [pr] between indices [i] and [j] *)
+let _focus cond inf i j pr =
+  let (focused,context) = Proofview.focus i j pr.state.proofview in
+  push_focus cond inf context pr;
+  pr.state <- { pr.state with proofview = focused }
+
+(* This function unfocuses the proof [pr], it raises [FullyUnfocused],
+   if the proof is already fully unfocused.
+   This function does not care about the condition of the current focus. *)
+let _unfocus pr =
+  let (_,_,fc) = pop_focus pr in
+  pr.state <- { pr.state with proofview = Proofview.unfocus fc pr.state.proofview }
+
+
+let set_used_variables l p =
+  p.info.section_vars <- Some l
+
+let get_used_variables p = p.info.section_vars
+
+(*** Endline tactic ***)
+
+(* spiwack this is an information about the UI, it might be a good idea to move
+   it to the Proof_global module *)
+
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+let set_endline_tactic tac p =
+ p.info.endline_tactic <- tac
+
+let with_end_tac pr tac =
+  Proofview.tclTHEN tac pr.info.endline_tactic
+
+(*** The following functions define the safety mechanism of the
+     proof system, they may be unsafe if not used carefully. There is
+     currently no reason to export them in the .mli ***)
+
+(* This functions saves the current state into a [proof_state]. *)
+let save_state { state = ps } = State ps
+
+(* This function stores the current proof state in the undo stack. *)
+let save pr =
+  push_undo (save_state pr) pr
+
+(* This function restores a state, presumably from the top of the undo stack. *)
+let restore_state save pr = 
+  match save with
+  | State save -> pr.state <- save
+  | Effect undo -> undo ()
+
+(* Interpretes the Undo command. *)
+let undo pr = 
+  (* On a single line, since the effects commute *)
+  restore_state (pop_undo pr) pr
+
+(* Adds an undo effect to the undo stack. Use it with care, errors here might result
+    in inconsistent states. *)
+let add_undo effect pr =
+  push_undo (Effect effect) pr
+
+
+
+(*** Transactions ***)
+
+let init_transaction pr =
+  pr.transactions <- []::pr.transactions
+
+let commit_stack pr stack =
+  let push s = push_undo s pr in
+  List.iter push (List.rev stack)
+
+(* Invariant: [commit] should be called only when a transaction
+   is open. It closes the current transaction. *)
+let commit pr =
+  match pr.transactions with
+  | stack::trans' ->
+    pr.transactions <- trans';
+    commit_stack pr stack
+  | [] -> assert false
+
+(* Invariant: [rollback] should be called only when a transaction
+   is open. It closes the current transaction. *)
+let rec rollback pr =
+  try
+    undo pr;
+    rollback pr
+  with EmptyUndoStack ->
+    match pr.transactions with
+    | []::trans' -> pr.transactions <- trans'
+    | _ -> assert false
+
+
+let transaction pr t =
+  init_transaction pr;
+  try t (); commit pr
+  with e -> rollback pr; raise e
+
+
+(* Focus command (focuses on the [i]th subgoal) *)
+(* spiwack: there could also, easily be a focus-on-a-range tactic, is there 
+   a need for it? *)
+let focus cond inf i pr =
+  save pr;
+  _focus cond (Obj.repr inf) i i pr
+
+(* Unfocus command.
+   Fails if the proof is not focused. *)
+exception CannotUnfocusThisWay
+let _ = Errors.register_handler begin function
+  | CannotUnfocusThisWay ->
+    Util.error "This proof is focused, but cannot be unfocused this way"
+  | _ -> raise Errors.Unhandled
+end
+
+let rec unfocus kind pr () =
+  let starting_point = save_state pr in
+  let cond = cond_of_focus pr in
+  match fst cond kind pr.state.proofview with
+  | Cannot -> raise CannotUnfocusThisWay
+  | Strict -> 
+    (_unfocus pr;
+     push_undo starting_point pr)
+  | Loose ->
+    begin try
+	    _unfocus pr;
+	    push_undo starting_point pr;
+	    unfocus kind pr ()
+      with FullyUnfocused -> raise CannotUnfocusThisWay
+    end
+
+let unfocus kind pr =
+  transaction pr (unfocus kind pr)
+      
+let get_at_point kind ((_,get),inf,_) = get kind inf
+exception NoSuchFocus
+(* no handler: should not be allowed to reach toplevel. *)
+exception GetDone of Obj.t
+(* no handler: confined to this module. *)
+let get_in_focus_stack kind stack =
+  try
+    List.iter begin fun pt ->
+      try 
+	raise (GetDone (get_at_point kind pt))
+      with CheckNext -> ()
+    end stack;
+    raise NoSuchFocus
+  with GetDone x -> x
+let get_at_focus kind pr =
+  Obj.magic (get_in_focus_stack kind pr.state.focus_stack)
+
+let no_focused_goal p =
+  Proofview.finished p.state.proofview
+
+(*** Proof Creation/Termination ***)
+
+let end_of_stack_kind = new_focus_kind ()
+let end_of_stack = done_cond end_of_stack_kind
+
+let start goals =
+  let pr = 
+    { state = { proofview = Proofview.init goals ;
+	        focus_stack = [] ;
+	        intel = Store.empty} ;
+      undo_stack = [] ;
+      transactions = [] ;
+      info = { endline_tactic = Proofview.tclUNIT ();
+               initial_conclusions = List.map snd goals;
+               section_vars = None }
+    }
+  in
+  _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr;
+  pr
+
+exception UnfinishedProof
+exception HasUnresolvedEvar
+let _ = Errors.register_handler begin function
+  | UnfinishedProof -> Util.error "Some goals have not been solved."
+  | HasUnresolvedEvar -> Util.error "Some existential variables are uninstantiated."
+  | _ -> raise Errors.Unhandled
+end
+let return p =
+  if not (is_done p) then
+    raise UnfinishedProof
+  else if has_unresolved_evar p then 
+    (* spiwack: for compatibility with <= 8.3 proof engine *)
+    raise HasUnresolvedEvar
+  else
+    unfocus end_of_stack_kind p;
+    Proofview.return p.state.proofview
+
+(*** Function manipulation proof extra informations ***)
+
+let get_proof_info pr =
+  pr.state.intel
+
+let set_proof_info info pr =
+  save pr;
+  pr.state <- { pr.state with intel=info }
+
+
+(*** Tactics ***)
+
+let run_tactic env tac pr =
+  let starting_point = save_state pr in
+  let sp = pr.state.proofview in
+  try
+    let tacticced_proofview = Proofview.apply env tac sp in
+    pr.state <- { pr.state with proofview = tacticced_proofview };
+    push_undo starting_point pr
+  with e -> 
+    restore_state starting_point pr;
+    raise e
+
+(*** Commands ***)
+
+let in_proof p k =
+  Proofview.in_proofview p.state.proofview k
+
+
+(*** Compatibility layer with <=v8.2 ***)
+module V82 = struct
+  let subgoals p =
+    Proofview.V82.goals p.state.proofview
+
+  let background_subgoals p =
+    Proofview.V82.goals (unroll_focus p.state.proofview p.state.focus_stack)
+
+  let get_initial_conclusions p = 
+    p.info.initial_conclusions
+
+  let depth p = List.length p.undo_stack
+
+  let top_goal p = 
+    let { Evd.it=gls ; sigma=sigma } = 
+	Proofview.V82.top_goals p.state.proofview
+    in
+    { Evd.it=List.hd gls ; sigma=sigma }
+
+  let top_evars p =
+    Proofview.V82.top_evars p.state.proofview
+
+  let instantiate_evar n com pr =
+    let starting_point = save_state pr in
+    let sp = pr.state.proofview in
+    try
+      let new_proofview = Proofview.V82.instantiate_evar n com sp in
+      pr.state <- { pr.state with proofview = new_proofview };
+      push_undo starting_point pr
+    with e -> 
+      restore_state starting_point pr;
+      raise e
+end
diff --git a/proofs/proof.mli b/proofs/proof.mli
new file mode 100644
index 00000000..12af18f4
--- /dev/null
+++ b/proofs/proof.mli
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Module defining the last essential tiles of interactive proofs.
+   The features of the Proof module are undoing and focusing.
+   A proof is a mutable object, it contains a proofview, and some information
+   to be able to undo actions, and to unfocus the current view. All three
+   of these being meant to evolve.
+   - Proofview: a proof is primarily the data of the current view.
+     That which is shown to the user (as a remainder, a proofview
+     is mainly the logical state of the proof, together with the
+     currently focused goals).
+   - Focus: a proof has a focus stack: the top of the stack contains
+     the context in which to unfocus the current view to a view focused
+     with the rest of the stack.
+     In addition, this contains, for each of the focus context,  a 
+     "focus kind" and a "focus condition" (in practice, and for modularity,
+     the focus kind is actually stored inside the condition). To unfocus, one
+     needs to know the focus kind, and the condition (for instance "no condition" or
+     the proof under focused must be complete) must be met.
+   - Undo: since proofviews and focus stacks are immutable objects, 
+     it could suffice to hold the previous states, to allow to return to the past.
+     However, we also allow other modules to do actions that can be undone.
+     Therefore the undo stack stores action to be ran to undo.
+*)
+
+open Term
+
+(* Type of a proof. *)
+type proof
+
+
+(*** General proof functions ***)
+
+val start : (Environ.env * Term.types) list -> proof
+
+(* Returns [true] if the considered proof is completed, that is if no goal remain
+    to be considered (this does not require that all evars have been solved). *)
+val is_done : proof -> bool
+
+(* Returns the list of partial proofs to initial goals. *)
+val partial_proof : proof -> Term.constr list
+
+(* Returns the proofs (with their type) of the initial goals.
+    Raises [UnfinishedProof] is some goals remain to be considered.
+    Raises [HasUnresolvedEvar] if some evars have been left undefined. *)
+exception UnfinishedProof
+exception HasUnresolvedEvar
+val return : proof -> (Term.constr * Term.types) list
+
+(* Interpretes the Undo command. Raises [EmptyUndoStack] if 
+    the undo stack is empty. *)
+exception EmptyUndoStack
+val undo : proof -> unit
+
+(* Adds an undo effect to the undo stack. Use it with care, errors here might result
+    in inconsistent states.
+   An undo effect is meant to undo an effect on a proof (a canonical example
+   of which is {!Proofglobal.set_proof_mode} which changes the current parser for
+   tactics). Make sure it will work even if the effects have been only partially
+   applied at the time of failure. *)
+val add_undo : (unit -> unit) -> proof -> unit
+
+(*** Focusing actions ***)
+
+(* ['a focus_kind] is the type used by focusing and unfocusing
+    commands to synchronise. Focusing and unfocusing commands use
+    a particular ['a focus_kind], and if they don't match, the unfocusing command
+    will fail.
+    When focusing with an ['a focus_kind], an information of type ['a] is
+    stored at the focusing point. An example use is the "induction" tactic
+    of the declarative mode where sub-tactics must be aware of the current
+    induction argument. *)
+type 'a focus_kind
+val new_focus_kind : unit -> 'a focus_kind
+
+(* To be authorized to unfocus one must meet the condition prescribed by
+    the action which focused.
+    Conditions always carry a focus kind, and inherit their type parameter
+    from it.*)
+type 'a focus_condition 
+(* [no_cond] only checks that the unfocusing command uses the right
+    [focus_kind].
+   If [loose_end] (default [false]) is [true], then if the [focus_kind]
+   doesn't match, then unfocusing can occur, provided it unfocuses
+   an earlier focus.
+   For instance bullets can be unfocused in the following situation
+   [{- solve_goal. }] because they use a loose-end condition. *)
+val no_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition
+(* [done_cond] checks that the unfocusing command uses the right [focus_kind]
+    and that the focused proofview is complete.
+   If [loose_end] (default [false]) is [true], then if the [focus_kind]
+   doesn't match, then unfocusing can occur, provided it unfocuses
+   an earlier focus.
+   For instance bullets can be unfocused in the following situation
+   [{ - solve_goal. }] because they use a loose-end condition.  *)
+val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition
+
+(* focus command (focuses on the [i]th subgoal) *)
+(* spiwack: there could also, easily be a focus-on-a-range tactic, is there 
+   a need for it? *)
+val focus : 'a focus_condition -> 'a -> int -> proof -> unit
+
+exception FullyUnfocused
+exception CannotUnfocusThisWay
+(* Unfocusing command.
+   Raises [FullyUnfocused] if the proof is not focused.
+   Raises [CannotUnfocusThisWay] if the proof the unfocusing condition
+     is not met. *)
+val unfocus : 'a focus_kind -> proof -> unit
+
+(* [get_at_focus k] gets the information stored at the closest focus point
+    of kind [k].
+    Raises [NoSuchFocus] if there is no focus point of kind [k]. *)
+exception NoSuchFocus
+val get_at_focus : 'a focus_kind -> proof -> 'a
+
+(* returns [true] if there is no goal under focus. *)
+val no_focused_goal : proof -> bool
+
+(*** Function manipulation proof extra informations ***)
+
+val get_proof_info : proof -> Store.t
+
+val set_proof_info : Store.t -> proof -> unit
+
+(* Sets the section variables assumed by the proof *)
+val set_used_variables : Sign.section_context -> proof -> unit
+val get_used_variables : proof -> Sign.section_context option
+
+(*** Endline tactic ***)
+
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+val set_endline_tactic : unit Proofview.tactic -> proof -> unit
+
+val with_end_tac : proof -> unit Proofview.tactic -> unit Proofview.tactic
+
+(*** Tactics ***)
+
+val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit
+
+
+(*** Transactions ***)
+
+(* A transaction chains several commands into a single one. For instance,
+   a focusing command and a tactic. Transactions are such that if
+   any of the atomic action fails, the whole transaction fails.
+
+   During a transaction, the undo visible undo stack is constituted only
+   of the actions performed done during the transaction.
+
+   [transaction p f] can be called on an [f] using, itself, [transaction p].*)
+val transaction : proof -> (unit -> unit) -> unit
+
+
+(*** Commands ***)
+
+val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a
+
+(*** Compatibility layer with <=v8.2 ***)
+module V82 : sig
+  val subgoals : proof -> Goal.goal list Evd.sigma
+
+  (* All the subgoals of the proof, including those which are not focused. *)
+  val background_subgoals : proof -> Goal.goal list Evd.sigma
+
+  val get_initial_conclusions : proof -> Term.types list 
+
+  val depth : proof -> int 
+
+  val top_goal : proof -> Goal.goal Evd.sigma
+  
+  (* returns the existential variable used to start the proof *)
+  val top_evars : proof -> Evd.evar list
+
+  (* Implements the Existential command *)
+  val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit
+end
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
new file mode 100644
index 00000000..2745270a
--- /dev/null
+++ b/proofs/proof_global.ml
@@ -0,0 +1,427 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(***********************************************************************)
+(*                                                                     *)
+(*      This module defines proof facilities relevant to the           *)
+(*      toplevel. In particular it defines the global proof            *)
+(*      environment.                                                   *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Pp
+open Names
+
+(*** Proof Modes ***)
+
+(* Type of proof modes :
+    - A function [set] to set it *from standard mode*
+    - A function [reset] to reset the *standard mode* from it *)
+type proof_mode = {
+  name : string ;
+  set : unit -> unit ;
+  reset : unit -> unit
+}
+
+let proof_modes = Hashtbl.create 6
+let find_proof_mode n =
+  try Hashtbl.find proof_modes n
+  with Not_found ->
+    Util.error (Format.sprintf "No proof mode named \"%s\"." n)
+
+let register_proof_mode ({ name = n } as m) = Hashtbl.add proof_modes n m
+(* initial mode: standard mode *)
+let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) }
+let _ = register_proof_mode standard
+
+(* Default proof mode, to be set at the beginning of proofs. *)
+let default_proof_mode = ref standard
+
+let _ =
+  Goptions.declare_string_option {Goptions.
+    optsync = true ;
+    optdepr = false;
+    optname = "default proof mode" ;
+    optkey = ["Default";"Proof";"Mode"] ;
+    optread = begin fun () -> 
+                               let { name = name } = !default_proof_mode in name 
+                     end;
+    optwrite = begin fun n -> 
+                                default_proof_mode := find_proof_mode n
+                      end
+  }
+
+(*** Proof Global Environment ***)
+
+(* local shorthand *)
+type nproof = identifier*Proof.proof
+
+(* Extra info on proofs. *)
+type lemma_possible_guards = int list list
+type proof_info = { 
+  strength : Decl_kinds.goal_kind ;
+  compute_guard :  lemma_possible_guards; 
+  hook :Tacexpr.declaration_hook ;
+  mode : proof_mode
+}
+
+(* Invariant: a proof is at most in one of current_proof and suspended. And the 
+   domain of proof_info is the union of that of current_proof and suspended.*)
+(* The head of [!current_proof] is the actual current proof, the other ones are to
+    be resumed when the current proof is closed, aborted or suspended. *)
+let current_proof = ref ([]:nproof list)
+let suspended = ref ([] : nproof list)
+let proof_info = ref (Idmap.empty : proof_info Idmap.t)
+
+(* Current proof_mode, for bookkeeping *)
+let current_proof_mode = ref !default_proof_mode
+
+(* combinators for proof modes *)
+let update_proof_mode () = 
+  match !current_proof with
+  | (id,_)::_ ->  
+      let { mode = m } = Idmap.find id !proof_info in
+      !current_proof_mode.reset ();
+      current_proof_mode := m;
+      !current_proof_mode.set ()
+  | _ -> 
+      !current_proof_mode.reset (); 
+      current_proof_mode := standard
+
+(* combinators for the current_proof and suspended lists *)
+let push a l = l := a::!l;
+  update_proof_mode ()
+
+exception NoSuchProof
+let _ = Errors.register_handler begin function
+  | NoSuchProof -> Util.error "No such proof."
+  | _ -> raise Errors.Unhandled
+end
+let rec extract id l = 
+  let rec aux = function
+    | ((id',_) as np)::l when id_ord id id' = 0 -> (np,l)
+    | np::l -> let (np', l) = aux l in (np' , np::l)
+    | [] -> raise NoSuchProof
+  in
+  let (np,l') = aux !l in
+  l := l';
+  update_proof_mode ();
+  np
+
+exception NoCurrentProof
+let _ = Errors.register_handler begin function
+  | NoCurrentProof -> Util.error "No focused proof (No proof-editing in progress)."
+  | _ -> raise Errors.Unhandled
+end
+let extract_top l =
+  match !l with
+  | np::l' -> l := l' ; update_proof_mode (); np
+  | [] -> raise NoCurrentProof	
+let find_top l =
+  match !l with
+  | np::_ -> np
+  | [] -> raise NoCurrentProof
+
+let rotate_top l1 l2 =
+  let np = extract_top l1 in
+  push np l2
+
+let rotate_find id l1 l2 =
+  let np = extract id l1 in
+  push np l2
+  
+
+(* combinators for the proof_info map *)
+let add id info m =
+  m := Idmap.add id info !m
+let remove id m =
+  m := Idmap.remove id !m
+
+(*** Proof Global manipulation ***)
+
+let get_all_proof_names () =
+    List.map fst !current_proof @
+    List.map fst !suspended
+
+let give_me_the_proof () = 
+  snd (find_top current_proof)
+
+let get_current_proof_name () =
+  fst (find_top current_proof)
+
+(* spiwack: it might be considered to move error messages away.
+    Or else to remove special exceptions from Proof_global.
+    Arguments for the former: there is no reason Proof_global is only
+    accessed directly through vernacular commands. Error message should be 
+   pushed to external layers, and so we should be able to have a finer
+   control on error message on complex actions. *)
+let msg_proofs use_resume =
+  match get_all_proof_names () with
+    | [] -> (spc () ++ str"(No proof-editing in progress).")
+    | l ->  (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++
+               (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l) ++
+	       str"." ++
+               (if use_resume then (fnl () ++ str"Use \"Resume\" first.")
+              	else (mt ()))
+	    )
+
+
+let there_is_a_proof () = !current_proof <> []
+let there_are_suspended_proofs () = !suspended <> []
+let there_are_pending_proofs () = 
+  there_is_a_proof () || 
+  there_are_suspended_proofs ()
+let check_no_pending_proof () = 
+  if not (there_are_pending_proofs ()) then
+    ()
+  else begin
+    Util.error (Pp.string_of_ppcmds
+      (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++
+       str"Use \"Abort All\" first or complete proof(s)."))
+  end
+
+
+let suspend () =
+  rotate_top current_proof suspended
+
+let resume_last () =
+  rotate_top suspended current_proof
+
+let resume id =
+  rotate_find id suspended current_proof
+
+let discard_gen id =
+  try 
+    ignore (extract id current_proof);
+    remove id proof_info
+  with NoSuchProof -> ignore (extract id suspended)
+
+let discard (loc,id) = 
+  try
+    discard_gen id
+  with NoSuchProof ->
+    Util.user_err_loc
+      (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false)
+
+let discard_current () =
+  let (id,_) = extract_top current_proof in
+  remove id proof_info
+ 
+let discard_all () =
+  current_proof := []; 
+  suspended := [];
+  proof_info := Idmap.empty
+
+(* [set_proof_mode] sets the proof mode to be used after it's called. It is
+    typically called by the Proof Mode command. *)
+(* Core component.
+    No undo handling.
+    Applies to proof [id], and proof mode [m]. *)
+let set_proof_mode m id = 
+  let info = Idmap.find id !proof_info in
+  let info = { info with mode = m } in
+  proof_info := Idmap.add id info !proof_info;
+  update_proof_mode ()
+(* Complete function.
+    Handles undo.
+    Applies to current proof, and proof mode name [mn]. *)
+let set_proof_mode mn =
+  let m = find_proof_mode mn in
+  let id = get_current_proof_name () in
+  let pr = give_me_the_proof () in
+  Proof.add_undo begin let curr = !current_proof_mode in fun () ->
+    set_proof_mode curr id ; update_proof_mode ()
+  end pr ;
+  set_proof_mode m id
+
+(* [start_proof s str env t hook tac] starts a proof of name [s] and
+    conclusion [t]; [hook] is optionally a function to be applied at
+    proof end (e.g. to declare the built constructions as a coercion
+    or a setoid morphism); init_tac is possibly a tactic to
+    systematically apply at initialization time (e.g. to start the
+    proof of mutually dependent theorems).
+    It raises exception [ProofInProgress] if there is a proof being
+    currently edited. *)
+let start_proof  id str goals ?(compute_guard=[]) hook =
+  (* arnaud: ajouter une vérification pour la présence de id dans le proof_global *)
+  let p = Proof.start goals in
+  add id { strength=str ; 
+	        compute_guard=compute_guard ; 
+		hook=hook ;
+	        mode = ! default_proof_mode } proof_info ;
+  push (id,p) current_proof
+
+(* arnaud: à enlever *)
+let run_tactic tac = 
+  let p = give_me_the_proof () in
+  let env = Global.env () in
+  Proof.run_tactic env tac p
+
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+let set_endline_tactic tac =
+  let p = give_me_the_proof () in
+  Proof.set_endline_tactic tac p
+
+let set_used_variables l =
+  let p = give_me_the_proof () in
+  let env = Global.env () in
+  let ids = List.fold_right Idset.add l Idset.empty in
+  let ctx = Environ.keep_hyps env ids in
+  Proof.set_used_variables ctx p
+
+let get_used_variables () =
+  Proof.get_used_variables (give_me_the_proof ())
+
+let with_end_tac tac =
+  let p = give_me_the_proof () in
+  Proof.with_end_tac p tac
+
+let close_proof () =
+  (* spiwack: for now close_proof doesn't actually discard the proof, it is done
+      by [Command.save]. *)
+  try 
+    let id = get_current_proof_name () in
+    let p = give_me_the_proof () in
+    let proofs_and_types = Proof.return p in
+    let section_vars = Proof.get_used_variables p in
+    let entries = List.map
+      (fun (c,t) -> { Entries.const_entry_body = c;
+                      const_entry_secctx = section_vars;
+                      const_entry_type = Some t;
+		      const_entry_opaque = true })
+      proofs_and_types
+    in
+    let { compute_guard=cg ; strength=str ; hook=hook } =
+      Idmap.find id !proof_info
+    in
+    (id, (entries,cg,str,hook))
+  with 
+    |  Proof.UnfinishedProof ->
+	 Util.error "Attempt to save an incomplete proof"
+    | Proof.HasUnresolvedEvar ->
+	Util.error "Attempt to save a proof with existential variables still non-instantiated"
+
+
+(**********************************************************)
+(*                                                                                                  *)
+(*                              Utility functions                                          *)
+(*                                                                                                  *)
+(**********************************************************)
+
+let maximal_unfocus k p =
+  begin try while Proof.no_focused_goal p do
+    Proof.unfocus k p
+  done
+  with Proof.FullyUnfocused | Proof.CannotUnfocusThisWay -> ()
+  end
+
+
+(**********************************************************)
+(*                                                        *)
+(*                                 Bullets                *)
+(*                                                        *)
+(**********************************************************)
+
+module Bullet = struct
+
+  open Store.Field
+
+
+  type t = Vernacexpr.bullet
+
+  type behavior = {
+    name : string;
+    put : Proof.proof -> t -> unit
+  }
+
+  let behaviors = Hashtbl.create 4
+  let register_behavior b = Hashtbl.add behaviors b.name b
+
+  (*** initial modes ***)
+  let none = {
+    name = "None";
+    put = fun _ _ -> ()
+  }
+  let _ = register_behavior none
+
+  module Strict = struct
+    (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *)
+    let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind)
+    let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind
+
+    let get_bullets pr =
+      try Proof.get_at_focus bullet_kind pr
+      with Proof.NoSuchFocus -> []
+
+    let has_bullet bul pr =
+      let rec has_bullet = function
+	| b'::_ when bul=b' -> true
+	| _::l -> has_bullet l
+	| [] -> false
+      in
+      has_bullet (get_bullets pr)
+
+    (* precondition: the stack is not empty *)
+    let pop pr =
+      match get_bullets pr with
+      | b::_ ->
+	Proof.unfocus bullet_kind pr;
+	(*returns*) b
+      | _ -> assert false
+
+    let push b pr =
+      Proof.focus bullet_cond (b::get_bullets pr) 1 pr
+
+    let put p bul =
+      if has_bullet bul p then
+	Proof.transaction p begin fun () ->
+	  while bul <> pop p do () done;
+	  push bul p
+	end
+      else 
+	push bul p
+
+    let strict = {
+      name = "Strict Subproofs";
+      put = put
+    }
+    let _ = register_behavior strict
+  end
+
+  (* Current bullet behavior, controled by the option *)
+  let current_behavior = ref Strict.strict
+    
+  let _ =
+    Goptions.declare_string_option {Goptions.
+      optsync = true;
+      optdepr = false;
+      optname = "bullet behavior";
+      optkey = ["Bullet";"Behavior"];
+      optread = begin fun () ->
+	(!current_behavior).name
+      end;
+      optwrite = begin fun n ->
+	current_behavior := Hashtbl.find behaviors n
+      end
+    }
+
+  let put p b =
+    (!current_behavior).put p b
+end
+
+
+module V82 = struct
+  let get_current_initial_conclusions () =
+    let p = give_me_the_proof () in
+    let id = get_current_proof_name () in
+    let { strength=str ; hook=hook } = 
+      Idmap.find id !proof_info
+    in
+    (id,(Proof.V82.get_initial_conclusions p, str, hook))
+end
+
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
new file mode 100644
index 00000000..ed6a60c7
--- /dev/null
+++ b/proofs/proof_global.mli
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module defines proof facilities relevant to the
+     toplevel. In particular it defines the global proof
+     environment. *)
+
+(** Type of proof modes :
+    - A name
+    - A function [set] to set it *from standard mode*
+    - A function [reset] to reset the *standard mode* from it 
+
+*)
+type proof_mode = {
+  name : string ;
+  set : unit -> unit ;
+  reset : unit -> unit
+}
+
+(** Registers a new proof mode which can then be adressed by name
+    in [set_default_proof_mode].
+    One mode is already registered - the standard mode - named "No",
+    It corresponds to Coq default setting are they are set when coqtop starts. *)
+val register_proof_mode : proof_mode -> unit
+
+val there_is_a_proof : unit -> bool
+val there_are_pending_proofs : unit -> bool
+val check_no_pending_proof : unit -> unit
+
+val get_current_proof_name : unit -> Names.identifier
+val get_all_proof_names : unit -> Names.identifier list
+
+val discard : Names.identifier Util.located -> unit
+val discard_current : unit -> unit
+val discard_all : unit -> unit
+
+(** [set_proof_mode] sets the proof mode to be used after it's called. It is
+    typically called by the Proof Mode command. *)
+val set_proof_mode : string -> unit
+
+exception NoCurrentProof
+val give_me_the_proof : unit -> Proof.proof
+
+
+(** [start_proof s str goals ~init_tac ~compute_guard hook] starts 
+    a proof of name [s] and
+    conclusion [t]; [hook] is optionally a function to be applied at
+    proof end (e.g. to declare the built constructions as a coercion
+    or a setoid morphism). *)
+type lemma_possible_guards = int list list
+val start_proof : Names.identifier -> 
+                          Decl_kinds.goal_kind ->
+                          (Environ.env * Term.types) list  ->
+                          ?compute_guard:lemma_possible_guards -> 
+                          Tacexpr.declaration_hook -> 
+                          unit
+
+val close_proof : unit -> 
+                           Names.identifier * 
+                          (Entries.definition_entry list * 
+			    lemma_possible_guards * 
+			    Decl_kinds.goal_kind * 
+			    Tacexpr.declaration_hook)
+
+exception NoSuchProof
+
+val suspend : unit -> unit
+val resume_last : unit -> unit
+
+val resume : Names.identifier -> unit
+(** @raise NoSuchProof if it doesn't find one. *)
+
+(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is 
+   no current proof. *)
+val run_tactic : unit Proofview.tactic -> unit
+
+(** Sets the tactic to be used when a tactic line is closed with [...] *)
+val set_endline_tactic : unit Proofview.tactic -> unit
+
+(** Sets the section variables assumed by the proof *)
+val set_used_variables : Names.identifier list -> unit
+val get_used_variables : unit -> Sign.section_context option
+
+(** Appends the endline tactic of the current proof to a tactic. *)
+val with_end_tac : unit Proofview.tactic -> unit Proofview.tactic
+
+(**********************************************************)
+(*                                                                                                  *)
+(*                              Utility functions                                          *)
+(*                                                                                                  *)
+(**********************************************************)
+
+(** [maximal_unfocus k p] unfocuses [p] until [p] has at least a
+    focused goal or that the last focus isn't of kind [k]. *)
+val maximal_unfocus : 'a Proof.focus_kind -> Proof.proof -> unit
+
+(**********************************************************)
+(*                                                        *)
+(*                                 Bullets                *)
+(*                                                        *)
+(**********************************************************)
+
+module Bullet : sig
+  type t = Vernacexpr.bullet
+
+  (** A [behavior] is the data of a put function which
+      is called when a bullet prefixes a tactic, together
+      with a name to identify it. *)
+  type behavior = {
+    name : string;
+    put : Proof.proof -> t -> unit
+  }
+
+  (** A registered behavior can then be accessed in Coq
+      through the command [Set Bullet Behavior "name"].
+
+      Two modes are registered originally:
+      * "Strict Subproofs":
+        - If this bullet follows another one of its kind, defocuses then focuses
+          (which fails if the focused subproof is not complete).
+        - If it is the first bullet of its kind, then focuses a new subproof.
+      * "None": bullets don't do anything *)
+  val register_behavior : behavior -> unit
+
+  (** Handles focusing/defocusing with bullets:
+       *)
+  val put : Proof.proof -> t -> unit
+end
+
+module V82 : sig
+  val get_current_initial_conclusions : unit -> Names.identifier *(Term.types list * Decl_kinds.goal_kind * Tacexpr.declaration_hook)
+end
diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml
deleted file mode 100644
index 8fe1a4c2..00000000
--- a/proofs/proof_trees.ml
+++ /dev/null
@@ -1,107 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: proof_trees.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Closure
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Sign
-open Evd
-open Environ
-open Evarutil
-open Decl_expr
-open Proof_type
-open Tacred
-open Typing
-open Libnames
-open Nametab
-
-(*
-let is_bind = function
-  | Tacexpr.Cbindings _ -> true
-  | _ -> false
-*)
-
-(* Functions on goals *)
-
-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_source = (dummy_loc,GoalEvar); 
-    evar_extra = extra }
-
-(* Functions on proof trees *)
-
-let ref_of_proof pf =
-  match pf.ref with
-    | None -> failwith "rule_of_proof"
-    | Some r -> r
-
-let rule_of_proof pf =
-  let (r,_) = ref_of_proof pf in r
-
-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
-  | Some (Nested (_,pf), _) -> pf
-  | _ -> failwith "subproof_of_proof"
-
-let status_of_proof pf = pf.open_subgoals
-
-let is_complete_proof pf = pf.open_subgoals = 0
-
-let is_leaf_proof pf = (pf.ref = None)
-
-let is_tactic_proof pf = match pf.ref with
-  | Some (Nested (Tactic _,_),_) -> true
-  | _ -> false
-
-
-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) *)
-
-let is_dem_rule  = function
-    Decl_proof _  -> true
-  | _ -> false
-
-let is_proof_instr = function
-    Nested(Proof_instr (_,_),_) -> true
-  | _ -> false
-
-let is_focussing_command = function
-    Decl_proof b -> b
-  | Nested (Proof_instr (b,_),_) -> b
-  | _ -> false
-
-
-(*********************************************************************)
-(*                  Pretty printing functions                        *)
-(*********************************************************************)
-
-open Pp
-
-let db_pr_goal g =
-  let env = evar_env g in
-  let penv = print_named_context env in
-  let pc = print_constr_env env g.evar_concl in
-  str"  " ++ hv 0 (penv ++ fnl () ++
-                   str "============================" ++ fnl ()  ++
-                   str" "  ++ pc) ++ fnl ()
-
diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli
deleted file mode 100644
index 9e9f5e63..00000000
--- a/proofs/proof_trees.mli
+++ /dev/null
@@ -1,48 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: proof_trees.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
-open Util
-open Names
-open Term
-open Sign
-open Evd
-open Environ
-open Proof_type
-(*i*)
-
-(* This module declares readable constraints, and a few utilities on
-   constraints and proof trees *)
-
-val mk_goal : named_context_val -> constr -> Dyn.t option -> goal
-
-val rule_of_proof     : proof_tree -> rule
-val ref_of_proof      : proof_tree -> (rule * proof_tree list)
-val children_of_proof : proof_tree -> proof_tree list
-val goal_of_proof     : proof_tree -> goal
-val subproof_of_proof : proof_tree -> proof_tree
-val status_of_proof   : proof_tree -> int
-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_displayed  : env -> constr -> identifier -> int option
-val pf_lookup_index_as_renamed : env -> constr -> int -> int option
-
-val is_proof_instr : rule -> bool
-val is_focussing_command : rule -> bool
-
-(*s Pretty printing functions. *)
-
-(*i*)
-open Pp
-(*i*)
-
-val db_pr_goal : goal -> std_ppcmds
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
index 46fce6ae..e256794a 100644
--- a/proofs/proof_type.ml
+++ b/proofs/proof_type.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (*i*)
 open Environ
 open Evd
@@ -16,8 +14,8 @@ open Libnames
 open Term
 open Util
 open Tacexpr
-open Decl_expr
-open Rawterm
+(* open Decl_expr *)
+open Glob_term
 open Genarg
 open Nametab
 open Pattern
@@ -26,6 +24,10 @@ open Pattern
 (* This module defines the structure of proof tree and the tactic type. So, it
    is used by Proof_tree and Refiner *)
 
+type goal = Goal.goal
+
+type tactic = goal sigma -> goal list sigma 
+
 type prim_rule =
   | Intro of identifier
   | Cut of bool * bool * identifier * types
@@ -42,7 +44,6 @@ type prim_rule =
   | Change_evars
 
 type proof_tree = {
-  open_subgoals : int;
   goal : goal;
   ref : (rule * proof_tree list) option }
 
@@ -54,13 +55,6 @@ and rule =
 
 and compound_rule=
   | Tactic of tactic_expr * bool
-  | Proof_instr of bool*proof_instr (* the boolean is for focus restrictions *)
-
-and goal = evar_info
-
-and tactic = goal sigma -> (goal list sigma * validation)
-
-and validation = (proof_tree list -> proof_tree)
 
 and tactic_expr =
   (constr,
@@ -100,7 +94,7 @@ type ltac_call_kind =
   | LtacNameCall of ltac_constant
   | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
   | LtacVarCall of identifier * glob_tactic_expr
-  | LtacConstrInterp of rawconstr *
+  | LtacConstrInterp of glob_constr *
       (extended_patvar_map * (identifier * identifier option) list)
 
 type ltac_trace = (int * loc * ltac_call_kind) list
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index 417f75da..2b0a10ba 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Environ
 open Evd
 open Names
@@ -16,16 +13,18 @@ open Libnames
 open Term
 open Util
 open Tacexpr
-open Decl_expr
-open Rawterm
+open Glob_term
 open Genarg
 open Nametab
 open Pattern
-(*i*)
 
-(* This module defines the structure of proof tree and the tactic type. So, it
+(** This module defines the structure of proof tree and the tactic type. So, it
    is used by [Proof_tree] and [Refiner] *)
 
+type goal = Goal.goal
+
+type tactic = goal sigma -> goal list sigma
+
 type prim_rule =
   | Intro of identifier
   | Cut of bool * bool * identifier * types
@@ -41,42 +40,39 @@ type prim_rule =
   | Rename of identifier * identifier
   | Change_evars
 
-(* The type [goal sigma] is the type of subgoal. It has the following form
-\begin{verbatim}
-   it    = { evar_concl = [the conclusion of the subgoal]
+(** The type [goal sigma] is the type of subgoal. It has the following form
+{v   it    = \{ evar_concl = [the conclusion of the subgoal]
              evar_hyps = [the hypotheses of the subgoal]
              evar_body = Evar_Empty;
-             evar_info = { pgm    : [The Realizer pgm if any]
-                           lc     : [Set of evar num occurring in subgoal] }}
-   sigma = { stamp = [an int chardacterizing the ed field, for quick compare]
+             evar_info = \{ pgm    : [The Realizer pgm if any]
+                           lc     : [Set of evar num occurring in subgoal] \}\}
+   sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare]
              ed : [A set of existential variables depending in the subgoal]
                number of first evar,
-               it = { evar_concl = [the type of first evar]
+               it = \{ evar_concl = [the type of first evar]
                       evar_hyps = [the context of the evar]
                       evar_body = [the body of the Evar if any]
-                      evar_info = { pgm    : [Useless ??]
+                      evar_info = \{ pgm    : [Useless ??]
                                     lc     : [Set of evars occurring
-                                              in the type of evar] } };
+                                              in the type of evar] \} \};
                ...
                number of last evar,
-               it = { evar_concl = [the type of evar]
+               it = \{ evar_concl = [the type of evar]
                       evar_hyps = [the context of the evar]
                       evar_body = [the body of the Evar if any]
-                      evar_info = { pgm    : [Useless ??]
+                      evar_info = \{ pgm    : [Useless ??]
                                     lc     : [Set of evars occurring
-                                              in the type of evar] } } }
-   }
-\end{verbatim}
+                                              in the type of evar] \} \} \} v}
 *)
 
-(*s Proof trees.
+(** {6 ... } *)
+(** Proof trees.
   [ref] = [None] if the goal has still to be proved,
   and [Some (r,l)] if the rule [r] was applied to the goal
   and gave [l] as subproofs to be completed.
   if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof
   that the goal can be proven if the goals in [l] are solved. *)
 type proof_tree = {
-  open_subgoals : int;
   goal : goal;
   ref : (rule * proof_tree list) option }
 
@@ -87,15 +83,8 @@ and rule =
   | Daimon
 
 and compound_rule=
-  (* the boolean of Tactic tells if the default tactic is used *)
+  (** the boolean of Tactic tells if the default tactic is used *)
   | Tactic of tactic_expr * bool
-  | Proof_instr of bool * proof_instr
-
-and goal = evar_info
-
-and tactic = goal sigma -> (goal list sigma * validation)
-
-and validation = (proof_tree list -> proof_tree)
 
 and tactic_expr =
   (constr,
@@ -135,7 +124,7 @@ type ltac_call_kind =
   | LtacNameCall of ltac_constant
   | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
   | LtacVarCall of identifier * glob_tactic_expr
-  | LtacConstrInterp of rawconstr *
+  | LtacConstrInterp of glob_constr *
       (extended_patvar_map * (identifier * identifier option) list)
 
 type ltac_trace = (int * loc * ltac_call_kind) list
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 05b86b1a..66001e77 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -1,12 +1,15 @@
+Goal
+Evar_refiner
+Proofview
+Proof
+Proof_global
 Tacexpr
 Proof_type
 Redexpr
-Proof_trees
 Logic
 Refiner
-Evar_refiner
 Tacmach
 Pfedit
 Tactic_debug
+Clenv
 Clenvtac
-Decl_mode
diff --git a/proofs/proofview.ml b/proofs/proofview.ml
new file mode 100644
index 00000000..0d50d521
--- /dev/null
+++ b/proofs/proofview.ml
@@ -0,0 +1,507 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Compat
+
+(* The proofview datastructure is a pure datastructure underlying the notion
+   of proof (namely, a proof is a proofview which can evolve and has safety
+   mechanisms attached).
+   The general idea of the structure is that it is composed of a chemical
+   solution: an unstructured bag of stuff which has some relations with 
+   one another, which represents the various subnodes of the proof, together
+   with a comb: a datastructure that gives order to some of these nodes, 
+   namely the open goals. 
+   The natural candidate for the solution is an {!Evd.evar_map}, that is
+   a calculus of evars. The comb is then a list of goals (evars wrapped 
+   with some extra information, like possible name anotations).
+   There is also need of a list of the evars which initialised the proofview
+   to be able to return information about the proofview. *)
+
+(* Type of proofviews. *)
+type proofview = {
+     initial : (Term.constr * Term.types) list;
+     solution : Evd.evar_map;
+     comb : Goal.goal list
+     }
+
+(* Initialises a proofview, the argument is a list of environement, 
+   conclusion types, and optional names, creating that many initial goals. *)
+let init = 
+  let rec aux = function
+  | [] ->  { initial = [] ; 
+	     solution = Evd.empty ;
+	     comb = []
+	   }
+  | (env,typ)::l -> let { initial = ret ; solution = sol ; comb = comb } =
+                           aux l
+                         in
+                         let ( new_defs , econstr ) = 
+			   Evarutil.new_evar sol env typ
+			 in
+			 let (e,_) = Term.destEvar econstr in
+			 let gl = Goal.build e in
+			 { initial = (econstr,typ)::ret;
+			   solution = new_defs ;
+			   comb = gl::comb }
+  in
+  fun l -> let v = aux l in
+    (* Marks all the goal unresolvable for typeclasses. *)
+    { v with solution = Typeclasses.mark_unresolvables v.solution }
+
+(* Returns whether this proofview is finished or not. That is,
+   if it has empty subgoals in the comb. There could still be unsolved
+   subgoaled, but they would then be out of the view, focused out. *)
+let finished = function
+  | {comb = []} -> true
+  | _  -> false
+
+(* Returns the current value of the proofview partial proofs. *)
+let return { initial=init; solution=defs }  =
+  List.map (fun (c,t) -> (Evarutil.nf_evar defs c , t)) init
+
+(* spiwack: this function should probably go in the Util section,
+    but I'd rather have Util (or a separate module for lists)
+    raise proper exceptions before *)
+(* [IndexOutOfRange] occurs in case of malformed indices
+   with respect to list lengths. *)
+exception IndexOutOfRange
+(* no handler: should not be allowed to reach toplevel *)
+
+(* [list_goto i l] returns a pair of lists [c,t] where
+   [c] has length [i] and is the reversed of the [i] first
+   elements of [l], and [t] is the rest of the list.
+   The idea is to navigate through the list, [c] is then
+   seen as the context of the current position. 
+   Raises [IndexOutOfRange] if [i > length l]*)
+let list_goto = 
+  let rec aux acc index = function
+    | l when index = 0-> (acc,l)
+    | [] -> raise IndexOutOfRange
+    | a::q -> aux (a::acc) (index-1) q
+  in
+  fun i l ->
+    if i < 0 then
+      raise IndexOutOfRange
+    else
+      aux [] i l
+
+(* Type of the object which allow to unfocus a view.*)
+(* First component is a reverse list of what comes before
+   and second component is what goes after (in the expected
+   order) *)
+type focus_context = Goal.goal list * Goal.goal list
+
+(* This (internal) function extracts a sublist between two indices, and
+   returns this sublist together with its context:
+   if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
+   original list.
+   The focused list has lenght [j-i-1] and contains the goals from
+   number [i] to number [j] (both included) the first goal of the list
+   being numbered [1].
+   [focus_sublist i j l] raises [IndexOutOfRange] if
+   [i > length l], or [j > length l] or [ j < i ].  *)
+let focus_sublist i j l =
+  let (left,sub_right) = list_goto (i-1) l in
+  let (sub, right) = 
+    try 
+      Util.list_chop (j-i+1) sub_right 
+    with Failure "list_chop" -> 
+      Util.errorlabstrm "nth_unproven" (Pp.str"No such unproven subgoal")
+  in
+  (sub, (left,right))
+
+(* Inverse operation to the previous one. *)
+let unfocus_sublist (left,right) s =
+  List.rev_append left (s@right)
+
+
+(* [focus i j] focuses a proofview on the goals from index [i] to index [j] 
+   (inclusive). (i.e. goals number [i] to [j] become the only goals of the
+   returned proofview). The first goal has index 1.
+   It returns the focus proof, and a context for the focus trace. *)
+let focus i j sp =
+  let (new_comb, context) = focus_sublist i j sp.comb in
+  ( { sp with comb = new_comb } , context )
+
+(* Unfocuses a proofview with respect to a context. *)
+let undefined defs l =
+  Option.List.flatten (List.map (Goal.advance defs) l)
+let unfocus c sp =
+  { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) }
+
+
+(* The tactic monad:
+   - Tactics are objects which apply a transformation to all
+     the subgoals of the current view at the same time. By opposed
+     to the old vision of applying it to a single goal. It mostly 
+     allows to consider tactic like [reorder] to reorder the goals
+     in the current view (which might be useful for the tactic designer)
+     (* spiwack: the ordering of goals, though, is perhaps a bit
+        brittle. It would be much more interesting to find a more
+        robust way to adress goals, I have no idea at this time 
+        though*) 
+     or global automation tactic for dependent subgoals (instantiating
+     an evar has influences on the other goals of the proof in progress,
+     not being able to take that into account causes the current eauto
+     tactic to fail on some instances where it could succeed).
+   - Tactics are a monad ['a tactic], in a sense a tactic can be 
+     seens as a function (without argument) which returns a value
+     of type 'a and modifies the environement (in our case: the view).
+     Tactics of course have arguments, but these are given at the 
+     meta-level as OCaml functions.
+     Most tactics, in the sense we are used to, return [ () ], that is
+     no really interesting values. But some might pass information 
+     around; the [(>>--)] and [(>>==)] bind-like construction are the
+     main ingredients of this information passing. 
+     (* spiwack: I don't know how much all this relates to F. Kirchner and 
+        C. Muñoz. I wasn't able to understand how they used the monad
+        structure in there developpement.
+     *)
+     The tactics seen in Coq's Ltac are (for now at least) only 
+     [unit tactic], the return values are kept for the OCaml toolkit.
+     The operation or the monad are [Proofview.tclUNIT] (which is the 
+     "return" of the tactic monad) [Proofview.tclBIND] (which is
+     the "bind", also noted [(>=)]) and [Proofview.tclTHEN] (which is a
+     specialized bind on unit-returning tactics).
+*)
+
+(* type of tactics *)
+(* spiwack: double-continuation backtracking monads are reasonable
+    folklore for "search" implementations (including Tac interactive prover's
+    tactics). Yet it's quite hard to wrap your head around these.
+    I recommand reading a few times the "Backtracking, Interleaving, and Terminating
+    Monad Transformers" paper by O. Kiselyov, C. Chen, D. Fridman.  
+    The peculiar shape of the monadic type is reminiscent of that of the continuation
+    monad transformer.
+    A good way to get a feel of what's happening is to look at what happens when
+    executing [apply (tclUNIT ())]. 
+    The disjunction function is unlike that of the LogicT paper, because we want and 
+    need to backtrack over state as well as values. Therefore we cannot be
+    polymorphic over the inner monad. *)
+type proof_step = { goals : Goal.goal list ; defs : Evd.evar_map }
+type +'a result = { proof_step : proof_step ;
+		                content : 'a }
+
+(* nb=non-backtracking *)
+type +'a nb_tactic  = proof_step -> 'a result
+
+(* double-continutation backtracking *)
+(* "sk" stands for "success continuation", "fk" for "failure continuation" *)
+type 'r fk = exn -> 'r
+type (-'a,'r) sk = 'a -> 'r fk -> 'r
+type +'a tactic0 = { go : 'r. ('a, 'r nb_tactic) sk -> 'r nb_tactic fk -> 'r nb_tactic }
+
+(* We obtain a tactic by parametrizing with an environment *)
+(* spiwack: alternatively the environment could be part of the "nb_tactic" state
+    monad. As long as we do not intend to change the environment during a tactic,
+    it's probably better here. *)
+type +'a tactic = Environ.env -> 'a tactic0
+
+(* unit of [nb_tactic] *)
+let nb_tac_unit a step = { proof_step = step ; content = a }
+
+(* Applies a tactic to the current proofview. *)
+let apply env t sp  = 
+  let start = { goals = sp.comb ; defs = sp.solution } in
+  let res = (t env).go (fun a _ step -> nb_tac_unit a step) (fun e _ -> raise e) start in
+  let next = res.proof_step in
+  {sp with
+     solution = next.defs ;
+     comb = next.goals
+  }
+
+(*** tacticals ***)
+
+
+(* Unit of the tactic monad *)
+let tclUNIT a _ = { go = fun sk fk step -> sk a fk step }
+
+(* Bind operation of the tactic monad *)
+let tclBIND t k env = { go = fun sk fk step ->
+  (t env).go (fun a fk -> (k a env).go sk fk) fk step
+}
+
+(* Interpretes the ";" (semicolon) of Ltac.
+   As a monadic operation, it's a specialized "bind"
+   on unit-returning tactic (meaning "there is no value to bind") *)
+let tclTHEN t1 t2 env = { go = fun sk fk step ->
+  (t1 env).go (fun () fk -> (t2 env).go sk fk) fk step
+}
+
+(* [tclIGNORE t] has the same operational content as [t],
+   but drops the value at the end. *)
+let tclIGNORE tac env = { go = fun sk fk step ->
+  (tac env).go (fun _ fk -> sk () fk) fk step
+}
+
+(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t1 fails. 
+    No interleaving for the moment. *)
+(* spiwack: compared to the LogicT paper, we backtrack at the same state
+    where [t1] has been called, not the state where [t1] failed. *)
+let tclOR t1 t2 env = { go = fun sk fk step ->
+  (t1 env).go sk (fun _ _ -> (t2 env).go sk fk step) step
+}
+
+(* [tclZERO e] always fails with error message [e]*)
+let tclZERO e env = { go = fun _ fk step -> fk e step }
+
+
+(* Focusing operation on proof_steps. *)
+let focus_proof_step i j ps =
+  let (new_subgoals, context) = focus_sublist i j ps.goals in
+  ( { ps with goals = new_subgoals } , context )
+
+(* Unfocusing operation of proof_steps. *)
+let unfocus_proof_step c ps =
+  { ps with 
+     goals = undefined ps.defs (unfocus_sublist c ps.goals) 
+  }
+
+(* Focuses a tactic at a range of subgoals, found by their indices. *)
+(* arnaud: bug if 0 goals ! *)
+let tclFOCUS i j t env = { go = fun sk fk step ->
+  let (focused,context) = focus_proof_step i j step in
+  (t env).go (fun a fk step -> sk a fk (unfocus_proof_step context step)) fk focused
+}
+
+(* Dispatch tacticals are used to apply a different tactic to each goal under
+    consideration. They come in two flavours:
+    [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic].
+    [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns
+    and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g]
+    corresponds to that of the tactic which created [g].
+    It is to be noted that the return value of [tclDISPATCHS ts] makes only
+    sense in the goals immediatly built by it, and would cause an anomaly
+    is used otherwise. *)
+exception SizeMismatch
+let _ = Errors.register_handler begin function
+  | SizeMismatch -> Util.error "Incorrect number of goals."
+  | _ -> raise Errors.Unhandled
+end
+(* spiwack: we use an parametrised function to generate the dispatch tacticals.
+    [tclDISPATCHGEN] takes a [null] argument to generate the return value
+    if there are no goal under focus, and a [join] argument to explain how
+    the return value at two given lists of subgoals are combined when
+    both lists are being concatenated.
+    [join] and [null] need be some sort of comutative monoid. *)
+let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step ->
+  match tacs,step.goals with
+  | [] , [] -> (tclUNIT null env).go sk fk step
+  | t::tacs , first::goals -> 
+      (tclDISPATCHGEN null join tacs env).go
+	begin fun x fk step -> 
+	  match Goal.advance step.defs first with
+	  | None -> sk x fk step
+	  | Some first ->
+	    (t env).go 
+	      begin fun y fk step' -> 
+		sk (join x y) fk { step' with 
+			                   goals = step'.goals@step.goals
+				         }
+	      end 
+	      fk 
+	      { step with goals = [first] }
+	end
+	fk
+	{ step with goals = goals }
+  | _ -> raise SizeMismatch
+}
+
+(* takes a tactic which can raise exception and makes it pure by *failing* 
+    on with these exceptions. Does not catch anomalies. *)
+let purify t = 
+  let t' env = { go = fun sk fk step -> try (t env).go (fun x -> sk (Util.Inl x)) fk step
+     	                                                     with Util.Anomaly _ as e -> raise e
+							           | e -> sk (Util.Inr e) fk step
+	       }
+  in
+  tclBIND t' begin function
+    | Util.Inl x -> tclUNIT x
+    | Util.Inr e -> tclZERO e
+  end
+let tclDISPATCHGEN null join tacs = purify (tclDISPATCHGEN null join tacs)
+
+let unitK () () = ()
+let tclDISPATCH = tclDISPATCHGEN () unitK
+
+let extend_to_list =
+  let rec copy n x l =
+    if n < 0 then raise SizeMismatch
+    else if n = 0 then l
+    else copy (n-1) x (x::l)
+  in
+  fun startxs rx endxs l ->
+    let ns = List.length startxs in
+    let ne = List.length endxs in
+    let n = List.length l in
+    startxs@(copy (n-ne-ns) rx endxs)
+let tclEXTEND tacs1 rtac tacs2 env = { go = fun sk fk step -> 
+  let tacs = extend_to_list tacs1 rtac tacs2 step.goals in
+  (tclDISPATCH tacs env).go sk fk step
+}
+
+(* [tclGOALBIND] and [tclGOALBINDU] are sorts of bind which take a
+    [Goal.sensitive] as a first argument, the tactic then acts on each goal separately.
+    Allows backtracking between goals. *)
+let list_of_sensitive s k env step =
+  Goal.list_map begin fun defs g ->
+    let (a,defs) = Goal.eval s env defs g in
+    (k a) , defs
+  end step.goals step.defs
+(* In form of a tactic *)
+let list_of_sensitive s k env = { go = fun sk fk step ->
+  let (tacs,defs) = list_of_sensitive s k env step in
+  sk tacs fk { step with defs = defs } 
+}
+
+(* This is a helper function for the dispatching tactics (like [tclGOALBIND] and
+    [tclDISPATCHS]). It takes an ['a sensitive] value, and returns a tactic
+    whose return value is, again, ['a sensitive] but only has value in the
+    (unmodified) goals under focus. *)
+let here_s b env = { go = fun sk fk step ->
+  sk (Goal.bind (Goal.here_list step.goals b) (fun b -> b)) fk step
+}
+
+let rec tclGOALBIND s k = 
+  (* spiwack: the first line ensures that the value returned by the tactic [k] will
+      not "escape its scope". *)
+  let k a = tclBIND (k a) here_s in
+  purify begin 
+    tclBIND (list_of_sensitive s k) begin fun tacs ->
+      tclDISPATCHGEN Goal.null Goal.plus tacs
+    end 
+  end
+
+(* spiwack: this should probably be moved closer to the [tclDISPATCH] tactical. *)
+let tclDISPATCHS tacs = 
+  let tacs = 
+    List.map begin fun tac -> 
+      tclBIND tac here_s
+    end tacs 
+  in
+  purify begin 
+    tclDISPATCHGEN Goal.null Goal.plus tacs
+  end
+
+let rec tclGOALBINDU s k = 
+  purify begin 
+    tclBIND (list_of_sensitive s k) begin fun tacs ->
+      tclDISPATCHGEN () unitK tacs
+    end
+  end
+
+(* spiwack: up to a few details, same errors are in the Logic module.
+    this should be maintained synchronized, probably. *)
+open Pretype_errors
+let rec catchable_exception = function
+  | Loc.Exc_located(_,e) -> catchable_exception e
+  | Util.UserError _
+  | Type_errors.TypeError _ | PretypeError (_,_,TypingError _)
+  | Indrec.RecursionSchemeError _
+  | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _)
+  (* unification errors *)
+  | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
+		   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
+		   |CannotFindWellTypedAbstraction _
+		   |UnsolvableImplicit _)) -> true
+  | Typeclasses_errors.TypeClassError 
+      (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
+  | _ -> false
+
+(* No backtracking can happen here, hence, as opposed to the dispatch tacticals,
+    everything is done in one step. *)
+let sensitive_on_step s env step =
+  let wrap g ((defs, partial_list) as partial_res) = 
+    match Goal.advance defs g with
+    | None ->partial_res
+    | Some g ->
+      let {Goal.subgoals = sg } , d' = Goal.eval s env defs g in
+      (d',sg::partial_list)
+  in
+  let ( new_defs , combed_subgoals ) = 
+    List.fold_right wrap step.goals (step.defs,[])
+  in
+  { defs = new_defs;
+     goals = List.flatten combed_subgoals }
+let tclSENSITIVE s =
+  purify begin
+    fun env -> { go = fun sk fk step -> sk () fk (sensitive_on_step s env step) }
+  end
+
+
+(*** Commands ***)
+
+let in_proofview p k =
+  k p.solution
+
+module Notations = struct
+  let (>-) = Goal.bind
+  let (>>-) = tclGOALBINDU
+  let (>>--) = tclGOALBIND
+  let (>=) = tclBIND
+  let (>>=) t k = t >= fun s -> s >>- k
+  let (>>==) t k = t >= fun s -> s >>-- k
+  let (<*>) = tclTHEN
+  let (<+>) = tclOR
+end
+
+(*** Compatibility layer with <= 8.2 tactics ***)
+module V82 = struct
+  type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma
+
+  let tactic tac _ = { go = fun sk fk ps ->
+    (* spiwack: we ignore the dependencies between goals here, expectingly
+         preserving the semantics of <= 8.2 tactics *)
+    let tac evd gl = 
+      let glsigma  = tac { Evd.it = gl ; Evd.sigma = evd }  in
+      let sigma = glsigma.Evd.sigma in
+      let g = glsigma.Evd.it in
+      ( g , sigma )
+    in
+    (* Old style tactics expect the goals normalized with respect to evars. *)
+    let (initgoals,initevd) = 
+      Goal.list_map Goal.V82.nf_evar ps.goals ps.defs
+    in
+    let (goalss,evd) = Goal.list_map tac initgoals initevd in
+    let sgs = List.flatten goalss in
+    sk () fk { defs = evd ; goals = sgs }
+}
+
+  let has_unresolved_evar pv =
+    Evd.has_undefined pv.solution
+
+  (* Returns the open goals of the proofview together with the evar_map to 
+     interprete them. *)
+  let goals { comb = comb ; solution = solution } = 
+    { Evd.it = comb ; sigma = solution}
+
+  let top_goals { initial=initial ; solution=solution } = 
+    let goals = List.map (fun (t,_) -> Goal.V82.build (fst (Term.destEvar t))) initial in
+    { Evd.it = goals ; sigma=solution }
+
+  let top_evars { initial=initial } =
+    let evars_of_initial (c,_) =
+      Util.Intset.elements (Evarutil.evars_of_term c)
+    in
+    List.flatten (List.map evars_of_initial initial)
+
+  let instantiate_evar n com pv =
+    let (evk,_) = 
+      let evl = Evarutil.non_instantiated pv.solution in
+     if (n <= 0) then
+	Util.error "incorrect existential variable index"
+      else if List.length evl < n then
+	  Util.error "not so many uninstantiated existential variables"
+      else
+	List.nth evl (n-1) 
+    in
+    { pv with
+	solution = Evar_refiner.instantiate_pf_com evk com pv.solution }
+
+  let purify = purify
+end
diff --git a/proofs/proofview.mli b/proofs/proofview.mli
new file mode 100644
index 00000000..24da9d77
--- /dev/null
+++ b/proofs/proofview.mli
@@ -0,0 +1,213 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The proofview datastructure is a pure datastructure underlying the notion
+   of proof (namely, a proof is a proofview which can evolve and has safety
+   mechanisms attached).
+   The general idea of the structure is that it is composed of a chemical
+   solution: an unstructured bag of stuff which has some relations with 
+   one another, which represents the various subnodes of the proof, together
+   with a comb: a datastructure that gives order to some of these nodes, 
+   namely the open goals. 
+   The natural candidate for the solution is an {!Evd.evar_map}, that is
+   a calculus of evars. The comb is then a list of goals (evars wrapped 
+   with some extra information, like possible name anotations).
+   There is also need of a list of the evars which initialised the proofview
+   to be able to return information about the proofview. *)
+
+open Term
+
+type proofview 
+
+(* Initialises a proofview, the argument is a list of environement, 
+   conclusion types, creating that many initial goals. *)
+val init : (Environ.env * Term.types) list -> proofview
+
+(* Returns whether this proofview is finished or not.That is,
+   if it has empty subgoals in the comb. There could still be unsolved
+   subgoaled, but they would then be out of the view, focused out. *)
+val finished : proofview -> bool
+
+(* Returns the current value of the proofview partial proofs. *)
+val return : proofview -> (constr*types) list
+
+
+(*** Focusing operations ***)
+
+(* [IndexOutOfRange] occurs in case of malformed indices
+   with respect to list lengths. *)
+exception IndexOutOfRange
+
+(* Type of the object which allow to unfocus a view.*)
+type focus_context
+
+(* [focus i j] focuses a proofview on the goals from index [i] to index [j] 
+   (inclusive). (i.e. goals number [i] to [j] become the only goals of the
+   returned proofview).
+   It returns the focus proof, and a context for the focus trace. *)
+val focus : int -> int -> proofview -> proofview * focus_context
+
+(* Unfocuses a proofview with respect to a context. *)
+val unfocus : focus_context -> proofview -> proofview
+
+(* The tactic monad:
+   - Tactics are objects which apply a transformation to all
+     the subgoals of the current view at the same time. By opposed
+     to the old vision of applying it to a single goal. It mostly 
+     allows to consider tactic like [reorder] to reorder the goals
+     in the current view (which might be useful for the tactic designer)
+     (* spiwack: the ordering of goals, though, is actually rather
+        brittle. It would be much more interesting to find a more
+        robust way to adress goals, I have no idea at this time 
+        though*) 
+     or global automation tactic for dependent subgoals (instantiating
+     an evar has influences on the other goals of the proof in progress,
+     not being able to take that into account causes the current eauto
+     tactic to fail on some instances where it could succeed).
+   - Tactics are a monad ['a tactic], in a sense a tactic can be 
+     seens as a function (without argument) which returns a value
+     of type 'a and modifies the environement (in our case: the view).
+     Tactics of course have arguments, but these are given at the 
+     meta-level as OCaml functions.
+     Most tactics in the sense we are used to return [ () ], that is
+     no really interesting values. But some might, to pass information 
+     around; for instance [Proofview.freeze] allows to store a certain
+     goal sensitive value "at the present time" (which means, considering the
+     structure of the dynamics of proofs, [Proofview.freeze s] will have,
+     for every current goal [gl], and for any of its descendent [g'] in 
+     the future the same value in [g'] that in [gl]). 
+     (* spiwack: I don't know how much all this relates to F. Kirchner and 
+        C. Muñoz. I wasn't able to understand how they used the monad
+        structure in there developpement.
+     *)
+     The tactics seen in Coq's Ltac are (for now at least) only 
+     [unit tactic], the return values are kept for the OCaml toolkit.
+     The operation or the monad are [Proofview.tclIDTAC] (which is the 
+     "return" of the tactic monad) [Proofview.tclBIND] (which is
+     the "bind") and [Proofview.tclTHEN] (which is a specialized
+     bind on unit-returning tactics).
+*)
+
+
+type +'a tactic 
+
+(* Applies a tactic to the current proofview. *)
+val apply : Environ.env -> 'a tactic -> proofview -> proofview
+
+(*** tacticals ***)
+
+(* Unit of the tactic monad *)
+val tclUNIT : 'a -> 'a tactic
+
+(* Bind operation of the tactic monad *)
+val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+
+(* Interprets the ";" (semicolon) of Ltac.
+   As a monadic operation, it's a specialized "bind"
+   on unit-returning tactic (meaning "there is no value to bind") *)
+val tclTHEN : unit tactic -> 'a tactic -> 'a tactic
+
+(* [tclIGNORE t] has the same operational content as [t],
+   but drops the value at the end. *)
+val tclIGNORE : 'a tactic -> unit tactic
+
+(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t2 fails. 
+    No interleaving at this point. *)
+val tclOR : 'a tactic -> 'a tactic -> 'a tactic
+
+(* [tclZERO] always fails *)
+val tclZERO : exn -> 'a tactic
+
+(* Focuses a tactic at a range of subgoals, found by their indices. *)
+val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
+
+(* Dispatch tacticals are used to apply a different tactic to each goal under
+    consideration. They come in two flavours:
+    [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic].
+    [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns
+    and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g]
+    corresponds to that of the tactic which created [g].
+    It is to be noted that the return value of [tclDISPATCHS ts] makes only
+    sense in the goals immediatly built by it, and would cause an anomaly
+    is used otherwise. *)
+val tclDISPATCH : unit tactic list -> unit tactic
+val tclDISPATCHS : 'a Goal.sensitive tactic list -> 'a Goal.sensitive tactic
+
+(* [tclEXTEND b r e] is a variant to [tclDISPATCH], where the [r] tactic
+    is "repeated" enough time such that every goal has a tactic assigned to it
+    ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r]
+    is applied to every goal in between. *)
+val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic
+
+(* A sort of bind which takes a [Goal.sensitive] as a first argument, 
+    the tactic then acts on each goal separately.
+    Allows backtracking between goals. *)
+val tclGOALBIND : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
+val tclGOALBINDU : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic
+
+(* [tclSENSITIVE] views goal-type tactics as a special kind of tactics.*)
+val tclSENSITIVE : Goal.subgoals Goal.sensitive -> unit tactic 
+
+
+(*** Commands ***)
+
+val in_proofview : proofview -> (Evd.evar_map -> 'a) -> 'a
+
+
+
+
+
+(* Notations for building tactics. *)
+module Notations : sig
+  (* Goal.bind *)
+  val (>-) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive) -> 'b Goal.sensitive
+  (* tclGOALBINDU *)
+  val (>>-) : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic
+  (* tclGOALBIND *)
+  val (>>--) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
+
+  (* tclBIND *)
+  val (>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+
+  (* [(>>=)] (and its goal sensitive variant [(>>==)]) "binds" in one step the
+      tactic monad and the goal-sensitive monad.
+      It is strongly advised to use it everytieme an ['a Goal.sensitive tactic]
+      needs a bind, since it usually avoids to delay the interpretation of the
+      goal sensitive value to a location where it does not make sense anymore. *)
+  val (>>=) : 'a Goal.sensitive tactic -> ('a -> unit tactic) -> unit tactic
+  val (>>==) : 'a Goal.sensitive tactic -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
+
+  (* tclTHEN *)
+  val (<*>) : unit tactic -> 'a tactic -> 'a tactic
+  (* tclOR *)
+  val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+end
+
+(*** Compatibility layer with <= 8.2 tactics ***)
+module V82 : sig
+  type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma 
+  val tactic : tac -> unit tactic
+
+  val has_unresolved_evar : proofview -> bool
+
+  (* Returns the open goals of the proofview together with the evar_map to 
+     interprete them. *)
+  val goals : proofview -> Goal.goal list Evd.sigma
+
+  val top_goals : proofview -> Goal.goal list Evd.sigma
+  
+  (* returns the existential variable used to start the proof *)
+  val top_evars : proofview -> Evd.evar list
+    
+  (* Implements the Existential command *)
+  val instantiate_evar : int -> Topconstr.constr_expr -> proofview -> proofview
+
+  (* spiwack: [purify] might be useful while writing tactics manipulating exception 
+     explicitely or from the [V82] submodule (neither being advised, though *)
+  val purify : 'a tactic -> 'a tactic
+end
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 7290a92f..0430a239 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: redexpr.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Term
 open Declarations
 open Libnames
-open Rawterm
+open Glob_term
 open Pattern
 open Reductionops
 open Tacred
@@ -40,12 +38,13 @@ let set_strategy_one ref l  =
         Csymtable.set_opaque_const sp
     | ConstKey sp, _ ->
         let cb = Global.lookup_constant sp in
-        if cb.const_body <> None & cb.const_opaque then
-          errorlabstrm "set_transparent_const"
-            (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
+	(match cb.const_body with
+	  | OpaqueDef _ ->
+            errorlabstrm "set_transparent_const"
+              (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) =
@@ -87,7 +86,10 @@ let discharge_strategy (_,(local,obj)) =
   if local then None else
   map_strategy disch_ref obj
 
-let (inStrategy,outStrategy) =
+type strategy_obj =
+    bool * (Conv_oracle.level * evaluable_global_reference list) list
+
+let inStrategy : strategy_obj -> obj =
   declare_object {(default_object "STRATEGY") with
                     cache_function = (fun (_,obj) -> cache_strategy obj);
 		    load_function = (fun _ (_,obj) -> cache_strategy obj);
@@ -213,7 +215,7 @@ let subst_red_expr subs e =
     (Pattern.subst_pattern subs)
     e
 
-let (inReduction,_) =
+let inReduction : bool * string * red_expr -> obj =
   declare_object
     {(default_object "REDUCTION") with
        cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e);
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index 9eaa91cc..ae82153d 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: redexpr.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Term
 open Closure
 open Pattern
-open Rawterm
+open Glob_term
 open Reductionops
 open Termops
 
@@ -22,23 +20,24 @@ type red_expr =
 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 *)
 
-(* Adding a custom reduction (function to be use at the ML level)
+(** [true] if we should use the vm to verify the reduction *)
+
+(** 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).
+(** 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. *)
+(** Opaque and Transparent commands. *)
 
-(* Sets the expansion strategy of a constant. When the boolean is
+(** Sets the expansion strategy of a constant. When the boolean is
    true, the effect is non-synchronous (i.e. it does not survive
    section and module closure). *)
 val set_strategy :
   bool -> (Conv_oracle.level * evaluable_global_reference list) list -> unit
 
-(* call by value normalisation function using the virtual machine *)
+(** call by value normalisation function using the virtual machine *)
 val cbv_vm : reduction_function
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index a540eef6..5cd85547 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refiner.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Pp
 open Util
 open Term
@@ -18,183 +17,20 @@ open Sign
 open Environ
 open Reductionops
 open Type_errors
-open Proof_trees
 open Proof_type
 open Logic
 
-type transformation_tactic = proof_tree -> (goal list * validation)
-
-let hypotheses gl = gl.evar_hyps
-let conclusion gl = gl.evar_concl
 
 let sig_it x = x.it
 let project x = x.sigma
 
-let pf_status pf = pf.open_subgoals
-
-let is_complete pf = (0 = (pf_status pf))
-
-let on_open_proofs f pf = if is_complete pf then pf else f pf
-
-let and_status = List.fold_left (+) 0
-
 (* Getting env *)
 
-let pf_env gls = Global.env_of_context (sig_it gls).evar_hyps
-let pf_hyps gls = named_context_of_val (sig_it gls).evar_hyps
-
-
-let descend n p =
-  match p.ref with
-    | None        -> error "It is a leaf."
-    | Some(r,pfl) ->
-    	if List.length pfl >= n then
-	  (match list_chop (n-1) pfl with
-	     | left,(wanted::right) ->
-		 (wanted,
-		  (fun pfl' ->
-		    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
-	  error "Too few subproofs"
-
-
-(* [mapshape [ l1 ; ... ; lk ] [ v1 ; ... ; vk ] [ p_1 ; .... ; p_(l1+...+lk) ]]
-   gives
-   [ (v1 [p_1 ... p_l1]) ; (v2 [ p_(l1+1) ... p_(l1+l2) ]) ; ... ;
-   (vk [ p_(l1+...+l(k-1)+1) ... p_(l1+...lk) ]) ]
- *)
-
-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
-	(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
-   validation *)
-
-let rec frontier p =
-  match p.ref with
-    | None ->
-	([p.goal],
-	 (fun lp' ->
-	    let p' = List.hd lp' in
-            if Evd.eq_evar_info p'.goal p.goal then
-	      p'
-            else
-	      errorlabstrm "Refiner.frontier"
-                (str"frontier was handed back a ill-formed proof.")))
-    | Some(r,pfl) ->
-    	let gll,vl = List.split(List.map frontier pfl) in
-    	(List.flatten gll,
-         (fun retpfl ->
-            let pfl' = mapshape (List.map List.length gll) vl retpfl in
-              { p with
-		  open_subgoals = and_status (List.map pf_status pfl');
-		  ref = Some(r,pfl')}))
-
-(* TODO LEM: I might have to make sure that these hooks are called
-   only when called from solve_nth_pftreestate; I can build the hook
-   call into the "f", then.
- *)
-let solve_hook = ref ignore
-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 ->
-        let p' = f p in
-        if Evd.eq_evar_info p'.goal p.goal then
-	  begin
-	    !solve_hook p';
-	    p'
-	  end
-        else
-	  errorlabstrm "Refiner.frontier_map"
-            (str"frontier_map was handed back a ill-formed proof.")
-    | Some(r,pfl) ->
-        let (_,rpfl') =
-          List.fold_left
-            (fun (n,acc) p -> (n-p.open_subgoals,frontier_map_rec f n p::acc))
-            (n,[]) pfl in
-        let pfl' = List.rev rpfl' in
-        { p with
-	    open_subgoals = and_status (List.map pf_status pfl');
-            ref = Some(r,pfl')}
-
-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");
-  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 ->
-        let p' = f i p in
-        if Evd.eq_evar_info p'.goal p.goal then
-	  begin
-	    !solve_hook p';
-	    p'
-	  end
-        else
-	  errorlabstrm "Refiner.frontier_mapi"
-            (str"frontier_mapi was handed back a ill-formed proof.")
-    | Some(r,pfl) ->
-        let (_,rpfl') =
-          List.fold_left
-            (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
-	    open_subgoals = and_status (List.map pf_status pfl');
-            ref = Some(r,pfl')}
-
-let frontier_mapi f p = frontier_mapi_rec f 1 p
-
-(* [list_pf p] is the lists of goals to be solved in order to complete the
-   proof [p] *)
-
-let list_pf p = fst (frontier p)
-
-let rec nb_unsolved_goals pf = pf.open_subgoals
-
-(* leaf g is the canonical incomplete proof of a goal g *)
-
-let leaf g =
-  { open_subgoals = 1;
-    goal = g;
-    ref = None }
-
-(* refiner r is a tactic applying the rule r *)
-
-let check_subproof_connection gl spfl =
-  list_for_all2eq (fun g pf -> Evd.eq_evar_info g pf.goal) gl spfl
-
-let abstract_operation syntax semantics gls =
-  let (sgl_sigma,validation) = semantics gls in
-  let hidden_proof = validation (List.map leaf sgl_sigma.it) in
-  (sgl_sigma,
-  fun spfl ->
-    assert (check_subproof_connection sgl_sigma.it spfl);
-    { open_subgoals = and_status (List.map pf_status spfl);
-      goal = gls.it;
-      ref = Some(Nested(syntax,hidden_proof),spfl)})
+let pf_env gls = Global.env_of_context (Goal.V82.hyps (project gls) (sig_it gls))
+let pf_hyps gls = named_context_of_val (Goal.V82.hyps (project gls) (sig_it gls))
+
+let abstract_operation syntax semantics =
+  semantics
 
 let abstract_tactic_expr ?(dflt=false) te tacfun gls =
   abstract_operation (Tactic(te,dflt)) tacfun gls
@@ -207,16 +43,11 @@ let abstract_extended_tactic ?(dflt=false) s args =
   abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args))
 
 let refiner = function
-  | Prim pr as r ->
+  | Prim pr ->
       let prim_fun = prim_refiner pr in
 	(fun goal_sigma ->
           let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in
-	    ({it=sgl; sigma = sigma'},
-            (fun spfl ->
-	      assert (check_subproof_connection sgl spfl);
-              { open_subgoals = and_status (List.map pf_status spfl);
-		goal = goal_sigma.it;
-		ref = Some(r,spfl) })))
+	  {it=sgl; sigma = sigma'})
 
 
   | Nested (_,_) | Decl_proof _ ->
@@ -226,83 +57,15 @@ let refiner = function
 
   | Daimon ->
       fun gls ->
-	({it=[];sigma=gls.sigma},
-	 fun spfl ->
-	   assert (spfl=[]);
-	   { open_subgoals = 0;
-             goal = gls.it;
-             ref = Some(Daimon,[])})
+	{it=[];sigma=gls.sigma}
 
 
 let norm_evar_tac gl = refiner (Prim Change_evars) gl
 
-let norm_evar_proof sigma pf =
-  let nf_subgoal i sgl =
-    let (gll,v) = norm_evar_tac {it=sgl.goal;sigma=sigma} in
-      v (List.map leaf gll.it) in
-    frontier_mapi nf_subgoal pf
-
-(* [extract_open_proof : proof_tree -> constr * (int * constr) list]
-   takes a (not necessarly complete) proof and gives a pair (pfterm,obl)
-   where pfterm is the constr corresponding to the proof
-   and [obl] is an [int*constr list] [ (m1,c1) ; ... ; (mn,cn)]
-   where the mi are metavariables numbers, and ci are their types.
-   Their proof should be completed in order to complete the initial proof *)
-
-let extract_open_proof sigma pf =
-  let next_meta =
-    let meta_cnt = ref 0 in
-    let rec f () =
-      incr meta_cnt;
-      if Evd.mem sigma (existential_of_int !meta_cnt) then f ()
-      else !meta_cnt
-    in f
-  in
-  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
-            (fun id ->
-               try let n = proof_variable_index id vl in (n,id)
-	       with Not_found -> failwith "caught")
-            (ids_of_named_context (named_context_of_val goal.evar_hyps)) in
-	let sorted_rels =
-	  Sort.list (fun (n1,_) (n2,_) -> n1 > n2 ) visible_rels in
-        let sorted_env =
-          List.map (fun (n,id) -> (n,lookup_named_val id goal.evar_hyps))
-            sorted_rels in
-	let abs_concl =
-          List.fold_right (fun (_,decl) c -> mkNamedProd_or_LetIn decl c)
-            sorted_env goal.evar_concl	in
-        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)
-
-    | _ -> anomaly "Bug: a case has been forgotten in proof_extractor"
-  in
-  let pfterm = proof_extractor [] pf in
-  (pfterm, List.rev !open_obligations)
-
 (*********************)
 (*   Tacticals       *)
 (*********************)
 
-(* unTAC : tactic -> goal sigma -> proof sigma *)
-
-let unTAC tac g =
-  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
 
@@ -310,13 +73,9 @@ 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
+  let glsigma = tac (repackage r g) in
   r := glsigma.sigma;
-  (glsigma.it,v)
-
-let idtac_valid = function
-    [pf] -> pf
-  | _ -> anomaly "Refiner.idtac_valid"
+  glsigma.it
 
 (* [goal_goal_list : goal sigma -> goal list sigma] *)
 let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma}
@@ -325,7 +84,7 @@ let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma}
 let tclNORMEVAR = norm_evar_tac
 
 (* identity tactic without any message *)
-let tclIDTAC gls = (goal_goal_list gls, idtac_valid)
+let tclIDTAC gls = goal_goal_list gls
 
 (* the message printing identity tactic *)
 let tclIDTAC_MESSAGE s gls =
@@ -344,23 +103,22 @@ let tclFAIL_lazy lvl s g = raise (FailError (lvl,s))
 
 let start_tac gls =
   let (sigr,g) = unpackage gls in
-  (sigr,[g],idtac_valid)
+  (sigr,[g])
 
-let finish_tac (sigr,gl,p) = (repackage sigr gl, p)
+let finish_tac (sigr,gl) = repackage sigr gl
 
-(* Apply [taci.(i)] on the first n subgoals and [tac] on the others *)
-let thens3parts_tac tacfi tac tacli (sigr,gs,p) =
+(* Apply [tacfi.(i)] on the first n subgoals, [tacli.(i)] on the last
+   m subgoals, and [tac] on the others *)
+let thens3parts_tac tacfi tac tacli (sigr,gs) =
   let nf = Array.length tacfi in
   let nl = Array.length tacli in
   let ng = List.length gs in
   if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
-  let gll,pl =
-    List.split
+  let gll =
       (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,
-   compose p (mapshape (List.map List.length gll) pl))
+    (sigr,List.flatten gll)
 
 (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *)
 let thensf_tac taci tac = thens3parts_tac taci tac [||]
@@ -369,10 +127,10 @@ let thensf_tac taci tac = thens3parts_tac taci tac [||]
 let thensl_tac tac taci = thens3parts_tac [||] tac taci
 
 (* Apply [tac i] on the ith subgoal (no subgoals number check) *)
-let thensi_tac tac (sigr,gs,p) =
-  let gll,pl =
-    List.split (list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs) in
-  (sigr, List.flatten gll, compose p (mapshape (List.map List.length gll) pl))
+let thensi_tac tac (sigr,gs) =
+  let gll =
+    list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs in
+  (sigr, List.flatten gll)
 
 let then_tac tac = thensf_tac [||] tac
 
@@ -382,7 +140,7 @@ let non_existent_goal n =
 
 (* Apply tac on the i-th goal (if i>0). If i<0, then start counting from
    the last goal (i=-1). *)
-let theni_tac i tac ((_,gl,_) as subgoals) =
+let theni_tac i tac ((_,gl) as subgoals) =
   let nsg = List.length gl in
   let k = if i < 0 then nsg + i + 1 else i in
   if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.")
@@ -451,42 +209,29 @@ let rec tclTHENLIST = function
 let tclMAP tacfun l =
   List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC
 
-(* various progress criterions *)
-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) ||
-  (not (same_goal (List.hd gls.it) ptree.it))
-
-let progress gls ptree =
-  (progress_evar_map ptree.sigma gls.sigma) ||
-  (weak_progress gls ptree)
-
+(* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves
+the goal unchanged *)
+let tclWEAK_PROGRESS tac ptree =
+  let rslt = tac ptree in
+  if Goal.V82.weak_progress rslt ptree then rslt
+  else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.")
 
 (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves
 the goal unchanged *)
 let tclPROGRESS tac ptree =
   let rslt = tac ptree in
-  if progress (fst rslt) ptree then rslt
+  if Goal.V82.progress rslt ptree then rslt
   else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.")
 
-(* 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
-  if weak_progress (fst rslt) ptree then rslt
-  else errorlabstrm "Refiner.tclWEAK_PROGRESS" (str"Failed to progress.")
-
-
 (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals,
    one of them being identical to the original goal *)
 let tclNOTSAMEGOAL (tac : tactic) goal =
+  let same_goal gls1 evd2 gl2 =
+    Goal.V82.same_goal gls1.sigma gls1.it evd2 gl2
+  in
   let rslt = tac goal in
-  let gls = (fst rslt).it in
-  if List.exists (same_goal goal.it) gls
+  let {it=gls;sigma=sigma} = rslt in
+  if List.exists (same_goal goal sigma) gls
   then errorlabstrm "Refiner.tclNOTSAMEGOAL"
       (str"Tactic generated a subgoal identical to the original goal.")
   else rslt
@@ -494,15 +239,15 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
 let catch_failerror e =
   if catchable_exception e then check_for_interrupt ()
   else match e with
-  | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_))
-  | Stdpp.Exc_located(_, LtacLocated (_,FailError (0,_)))  ->
+  | FailError (0,_) | Loc.Exc_located(_, FailError (0,_))
+  | Loc.Exc_located(_, LtacLocated (_,FailError (0,_)))  ->
       check_for_interrupt ()
   | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
-  | Stdpp.Exc_located(s,FailError (lvl,s')) ->
-      raise (Stdpp.Exc_located(s,FailError (lvl - 1, s')))
-  | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s')))  ->
+  | Loc.Exc_located(s,FailError (lvl,s')) ->
+      raise (Loc.Exc_located(s,FailError (lvl - 1, s')))
+  | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s')))  ->
       raise
-       (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1,s'))))
+       (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1,s'))))
   | e -> raise e
 
 (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *)
@@ -525,9 +270,9 @@ let tclORELSE_THEN t1 t2then t2else gls =
     with e -> catch_failerror e; None
   with
     | None -> t2else gls
-    | Some (sgl,v) ->
+    | Some sgl ->
         let (sigr,gl) = unpackage sgl in
-        finish_tac (then_tac t2then  (sigr,gl,v))
+        finish_tac (then_tac t2then  (sigr,gl))
 
 (* TRY f tries to apply f, and if it fails, leave the goal unchanged *)
 let tclTRY f = (tclORELSE0 f tclIDTAC)
@@ -587,6 +332,27 @@ let tclDO n t =
   in
   dorec n
 
+(* Fails if a tactic hasn't finished after a certain amount of time *)
+
+exception TacTimeout
+
+let tclTIMEOUT n t g =
+  let timeout_handler _ = raise TacTimeout in
+  let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
+  ignore (Unix.alarm n);
+  let restore_timeout () =
+    ignore (Unix.alarm 0);
+    Sys.set_signal Sys.sigalrm psh
+  in
+  try
+    let res = t g in
+    restore_timeout ();
+    res
+  with
+    | TacTimeout | Loc.Exc_located(_,TacTimeout) ->
+      restore_timeout ();
+      errorlabstrm "Refiner.tclTIMEOUT" (str"Timeout!")
+    | e -> restore_timeout (); raise e
 
 (* Beware: call by need of CAML, g is needed *)
 let rec tclREPEAT t g =
@@ -601,14 +367,12 @@ let rec tclREPEAT_MAIN t g =
 
 (*s Tactics handling a list of goals. *)
 
-type validation_list = proof_tree list -> proof_tree list
-
-type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+type tactic_list = (goal list sigma) -> (goal list sigma)
 
 (* Functions working on goal list for correct backtracking in Prolog *)
 
 let tclFIRSTLIST = tclFIRST
-let tclIDTAC_list gls = (gls, fun x -> x)
+let tclIDTAC_list gls = gls
 
 (* first_goal : goal list sigma -> goal sigma *)
 
@@ -628,286 +392,20 @@ 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),
-       fun pfl -> let (pfg,pfrest) = list_chop n pfl in (p pfg)::pfrest)
+      let gl = apply_sig_tac sigr tac g1 in
+      repackage sigr (gl@rest)
   | _ -> error "apply_tac_list"
 
 let then_tactic_list tacl1 tacl2 glls =
-  let (glls1,pl1) = tacl1 glls in
-  let (glls2,pl2) = tacl2 glls1 in
-  (glls2, compose pl1 pl2)
+  let glls1 = tacl1 glls in
+  let glls2 = tacl2 glls1 in
+  glls2
 
 (* Transform a tactic_list into a tactic *)
 
 let tactic_list_tactic tac gls =
-    let (glres,vl) = tac (goal_goal_list gls) in
-    (glres, compose idtac_valid vl)
-
-
-
-(* 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
-   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
-   or -1 when the move is done behind a registered tactic in which
-   case the validation corresponds to a constant function giving back
-   the original proof-tree. *)
-
-type pftreestate = {
-  tpf      : proof_tree ;
-  tpfsigma : evar_map;
-  tstack   : (int * validation) list }
-
-let proof_of_pftreestate pts = pts.tpf
-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 =
-  { it = goal_of_proof pts.tpf; sigma = pts.tpfsigma }
-
-let nth_goal_of_pftreestate n pts =
-  let goals = fst (frontier pts.tpf) in
-  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
-  | 0 -> (* go to the parent *)
-      (match  pts.tstack with
-	 | [] -> error "traverse: no ancestors"
-	 | (_,v)::tl ->
-             let pf = v [pts.tpf] in
-             let pf = norm_evar_proof pts.tpfsigma pf in
-	     { tpf = pf;
-	       tstack = tl;
-	       tpfsigma = pts.tpfsigma })
-  | -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
-	     { 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
-      { tpf = npf;
-        tpfsigma = pts.tpfsigma;
-        tstack = (n,v):: pts.tstack }
-
-let change_constraints_pftreestate newgc pts = { pts with tpfsigma = newgc }
-
-let app_tac sigr tac p =
-  let (gll,v) = tac {it=p.goal;sigma= !sigr} in
-  sigr := gll.sigma;
-  v (List.map leaf gll.it)
-
-(* modify proof state at current position *)
-
-let map_pftreestate f pts =
-  let sigr = ref pts.tpfsigma in
-  let tpf' = f sigr pts.tpf in
-  let tpf'' =
-    if !sigr == pts.tpfsigma then tpf' else norm_evar_proof !sigr tpf' in
-  { tpf      = tpf'';
-    tpfsigma = !sigr;
-    tstack   = pts.tstack }
-
-(* solve the nth subgoal with tactic tac *)
-
-let solve_nth_pftreestate n tac =
-  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.
-   This is a gross approximation as it does not attempt to clean correctly
-   the global constraints given in tpfsigma. *)
-
-let weak_undo_pftreestate pts =
-  let pf = leaf pts.tpf.goal in
-  { tpf = pf;
-    tpfsigma = pts.tpfsigma;
-    tstack = pts.tstack }
-
-(* Gives a new proof (a leaf) of a goal gl *)
-let mk_pftreestate g =
-  { tpf      = leaf g;
-    tstack   = [];
-    tpfsigma = Evd.empty }
-
-(* Extracts a constr from a proof-tree state ; raises an error if the
-   proof is not complete or the state does not correspond to the head
-   of the proof-tree *)
-
-let extract_open_pftreestate pts =
-  extract_open_proof pts.tpfsigma pts.tpf
-
-let extract_pftreestate pts =
-  if pts.tstack <> [] then
-    errorlabstrm "extract_pftreestate" (str"Proof blocks need to be closed");
-  let pfterm,subgoals = extract_open_pftreestate pts in
-  let exl = Evarutil.non_instantiated pts.tpfsigma in
-  if subgoals <> [] or exl <> [] then
-    errorlabstrm "extract_proof"
-      (if subgoals <> [] then
-        str "Attempt to save an incomplete proof"
-      else
-        str "Attempt to save a proof with existential variables still non-instantiated");
-  let env = Global.env_of_context pts.tpf.goal.evar_hyps in
-  nf_betaiota_preserving_vm_cast env pts.tpfsigma pfterm
-  (* strong whd_betaiotaevar env pts.tpfsigma pfterm *)
-  (***
-  local_strong (Evarutil.whd_ise (ts_it pts.tpfsigma)) pfterm
-  ***)
-(* Focus on the first leaf proof in a proof-tree state *)
-
-let rec first_unproven pts =
-  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 ->
-	   if not(is_complete_proof pf) then n else failwith "caught")
-	1 (children_of_proof pf)
-    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
-  if is_complete_proof pf then
-    errorlabstrm "last_unproven" (str"No unproven subgoals");
-  if is_leaf_proof pf then
-    pts
-  else
-    let children = (children_of_proof pf) in
-    let nchilds = List.length children in
-    let childnum =
-      list_try_find_i
-        (fun n pf ->
-           if not(is_complete_proof pf) then n else failwith "caught")
-        1 (List.rev children)
-    in
-    last_unproven (traverse (nchilds-childnum+1) pts)
-
-let rec nth_unproven n pts =
-  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
-    else
-      errorlabstrm "nth_unproven" (str"Not enough unproven subgoals")
-  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
-	    process (i+1) (k-k1) rest
-	  else
-	    nth_unproven k (traverse i pts)
-    in
-    process 1 n children
-
-let rec node_prev_unproven loc pts =
-  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
-	  let child = List.nth (children_of_proof pf) (loc - 2) in
-	  if is_complete_proof child then
-	    node_prev_unproven (loc - 1) pts
-	  else
-	    first_unproven (traverse (loc - 1) pts)
-
-let rec node_next_unproven loc pts =
-  let pf = proof_of_pftreestate pts in
-  match cursor_of_pftreestate pts with
-    | [] -> first_unproven pts
-    | n::l ->
-	if is_complete_proof pf ||
-           loc = (List.length (children_of_proof pf)) then
-             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
-	  last_unproven(traverse (loc + 1) pts)
-
-let next_unproven pts =
-  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
-    node_next_unproven (List.length (children_of_proof pf)) pts
-
-let prev_unproven pts =
-  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
-    node_prev_unproven 1 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) ->
-	  {pt with ref=Some (f oldrule,l)}
-      | _ -> invalid_arg "change_rule" in
-    map_pftreestate mark_top pts
-
-let match_rule p pts =
-  match (proof_of_pftreestate pts).ref with
-      Some (r,_) -> p r
-    | None -> false
-
-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
-	pts
-      else
-	up_until_matching_rule p one_up
-
-let rec up_to_matching_rule p pts =
-  if match_rule p pts then
-    pts
-  else
-    if is_top_pftreestate pts then
-      raise Not_found
-    else
-      let one_up = traverse 0 pts in
-      	up_to_matching_rule p one_up
+    let glres = tac (goal_goal_list gls) in
+    glres
 
 (* Change evars *)
 let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma}
@@ -918,42 +416,24 @@ 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 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 ->
-    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
+  msgnl (hov 0 (str "Warning: info is currently not working"));
+  tac gls
 
 (* Check that holes in arguments have been resolved *)
 
-let check_evars env sigma evm gl =
+let check_evars env sigma extsigma 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
+    Evd.fold_undefined (fun evk evi acc ->
+      if Evd.is_undefined extsigma evk & not (Evd.mem origsigma evk) then
+	evi::acc
+      else
+	acc)
+      sigma []
   in
-  if rest <> Evd.empty then
-    let (evk,evi) = List.hd (Evd.to_list rest) in
-    let (loc,k) = evar_source evk rest in
+  if rest <> [] then
+    let evi = List.hd rest in
+    let (loc,k) = evi.evar_source in
     let evi = Evarutil.nf_evar_info sigma evi in
     Pretype_errors.error_unsolvable_implicit loc env sigma evi k None
 
@@ -962,5 +442,5 @@ let tclWITHHOLES accept_unresolved_holes tac sigma 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;
+      check_evars (pf_env gl) (res).sigma sigma gl;
     res
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 8167bfb2..75fd6d3d 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refiner.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Sign
 open Evd
-open Proof_trees
 open Proof_type
 open Tacexpr
-(*i*)
+open Logic
 
-(* The refiner (handles primitive rules and high-level tactics). *)
+(** The refiner (handles primitive rules and high-level tactics). *)
 
 val sig_it  : 'a sigma -> 'a
 val project : 'a sigma -> evar_map
@@ -28,14 +24,14 @@ val pf_hyps : goal sigma -> named_context
 val unpackage : 'a sigma -> evar_map ref * 'a
 val repackage : evar_map ref -> 'a -> 'a sigma
 val apply_sig_tac :
-  evar_map ref -> (goal sigma -> (goal list) sigma * validation) -> goal -> (goal list) * validation
-
-type transformation_tactic = proof_tree -> (goal list * validation)
+  evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list
 
-(*s Hiding the implementation of tactics. *)
+(** {6 Hiding the implementation of tactics. } *)
 
-(* [abstract_tactic tac] hides the (partial) proof produced by [tac] under
+(** [abstract_tactic tac] hides the (partial) proof produced by [tac] under
    a single proof node. The boolean tells if the default tactic is used. *)
+(* spiwack: currently here for compatibility, abstract_operation 
+    is a second projection *)
 val abstract_operation : compound_rule -> tactic -> tactic
 val abstract_tactic : ?dflt:bool -> atomic_tactic_expr -> tactic -> tactic
 val abstract_tactic_expr : ?dflt:bool -> tactic_expr -> tactic -> tactic
@@ -43,100 +39,84 @@ val abstract_extended_tactic :
   ?dflt:bool -> string -> typed_generic_argument list -> tactic -> tactic
 
 val refiner : rule -> tactic
-val frontier : transformation_tactic
-val list_pf : proof_tree -> goal list
-val unTAC : tactic -> goal sigma -> proof_tree sigma
-
-
-(* Install a hook frontier_map and frontier_mapi call on the new node they create *)
-val set_solve_hook : (Proof_type.proof_tree -> unit) -> unit
-(* [frontier_map f n p] applies f on the n-th open subgoal of p and
-   rebuilds proof-tree.
-   n=1 for first goal, n negative counts from the right *)
-val frontier_map :
-  (proof_tree -> proof_tree) -> int -> proof_tree -> proof_tree
-
-(* [frontier_mapi f p] applies (f i) on the i-th open subgoal of p. *)
-val frontier_mapi :
-  (int -> proof_tree -> proof_tree) -> proof_tree -> proof_tree
 
-(*s Tacticals. *)
+(** {6 Tacticals. } *)
 
-(* [tclNORMEVAR] forces propagation of evar constraints *)
+(** [tclNORMEVAR] forces propagation of evar constraints *)
 val tclNORMEVAR       : tactic
 
-(* [tclIDTAC] is the identity tactic without message printing*)
+(** [tclIDTAC] is the identity tactic without message printing*)
 val tclIDTAC          : tactic
 val tclIDTAC_MESSAGE  : Pp.std_ppcmds -> tactic
 
-(* [tclEVARS sigma] changes the current evar map *)
+(** [tclEVARS sigma] changes the current evar map *)
 val tclEVARS : evar_map -> tactic
 
-(* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
+(** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
    [tac2] to every resulting subgoals *)
 val tclTHEN          : tactic -> tactic -> tactic
 
-(* [tclTHENLIST [t1;..;tn]] applies [t1] THEN [t2] ... THEN [tn]. More
+(** [tclTHENLIST [t1;..;tn]] applies [t1] THEN [t2] ... THEN [tn]. More
    convenient than [tclTHEN] when [n] is large *)
 val tclTHENLIST      : tactic list -> tactic
 
-(* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+(** [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) *)
+(** [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
 
-(* [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+(** [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
    to the last resulting subgoal (previously called [tclTHENL]) *)
 val tclTHENLAST         : tactic -> tactic -> tactic
 
-(* [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+(** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
    to the first resulting subgoal *)
 val tclTHENFIRST         : tactic -> tactic -> tactic
 
-(* [tclTHENS tac1 [|t1 ; ... ; tn|] gls] applies the tactic [tac1] to
+(** [tclTHENS tac1 [|t1 ; ... ; tn|] gls] applies the tactic [tac1] to
    [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises
    an error if the number of resulting subgoals is not [n] *)
 val tclTHENSV         : tactic -> tactic array -> tactic
 
-(* Same with a list of tactics *)
+(** Same with a list of tactics *)
 val tclTHENS         : tactic -> tactic list -> tactic
 
-(* [tclTHENST] is renamed [tclTHENSFIRSTn]
+(** [tclTHENST] is renamed [tclTHENSFIRSTn]
 val tclTHENST        : tactic -> tactic array -> tactic -> tactic
 *)
 
-(* [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls]
+(** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls]
    applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to
    the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m]
    subgoals and [tac2] to the rest of the subgoals in the middle. Raises an
    error if the number of resulting subgoals is strictly less than [n+m] *)
 val tclTHENS3PARTS     : tactic -> tactic array -> tactic -> tactic array -> tactic
 
-(* [tclTHENSLASTn tac1 [t1 ; ... ; tn] tac2 gls] applies [t1],...,[tn] on the
+(** [tclTHENSLASTn tac1 [t1 ; ... ; tn] tac2 gls] applies [t1],...,[tn] on the
    last [n] resulting subgoals and [tac2] on the remaining first subgoals *)
 val tclTHENSLASTn     : tactic -> tactic -> tactic array -> tactic
 
-(* [tclTHENSFIRSTn tac1 [t1 ; ... ; tn] tac2 gls] first applies [tac1], then
+(** [tclTHENSFIRSTn tac1 [t1 ; ... ; tn] tac2 gls] first applies [tac1], then
    applies [t1],...,[tn] on the first [n] resulting subgoals and
    [tac2] for the remaining last subgoals (previously called tclTHENST) *)
 val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic
 
-(* [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
+(** [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
    applies [t1],...,[tn] on the last [n] resulting subgoals and leaves
    unchanged the other subgoals *)
 val tclTHENLASTn    : tactic -> tactic array -> tactic
 
-(* [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
+(** [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
    applies [t1],...,[tn] on the first [n] resulting subgoals and leaves
    unchanged the other subgoals (previously called [tclTHENSI]) *)
 val tclTHENFIRSTn   : tactic -> tactic array -> tactic
 
-(* A special exception for levels for the Fail tactic *)
+(** A special exception for levels for the Fail tactic *)
 exception FailError of int * Pp.std_ppcmds Lazy.t
 
-(* Takes an exception and either raise it at the next
+(** Takes an exception and either raise it at the next
    level or do nothing. *)
 val catch_failerror  : exn -> unit
 
@@ -153,29 +133,28 @@ 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 tclTIMEOUT       : int -> tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclINFO          : tactic -> tactic
 
-(* [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
+(** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
    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]
+(** [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1]
    has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed.
    Equivalent to [(tac1;try tac2)||tac2] *)
 
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
-(*s Tactics handling a list of goals. *)
+(** {6 Tactics handling a list of goals. } *)
 
-type validation_list = proof_tree list -> proof_tree list
-
-type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+type tactic_list = goal list sigma -> goal list sigma
 
 val tclFIRSTLIST       : tactic_list list -> tactic_list
 val tclIDTAC_list      : tactic_list
@@ -185,63 +164,8 @@ 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
+(** [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. *)
-
-type pftreestate
-
-val proof_of_pftreestate : pftreestate -> proof_tree
-val cursor_of_pftreestate : pftreestate -> int list
-val is_top_pftreestate : pftreestate -> bool
-val match_rule : (rule -> bool) -> pftreestate -> bool
-val evc_of_pftreestate : pftreestate -> evar_map
-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 :
-  (evar_map ref -> proof_tree -> proof_tree) -> pftreestate -> pftreestate
-val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate
-val solve_pftreestate : tactic -> pftreestate -> pftreestate
-
-(* a weak version of logical undoing, that is really correct only *)
-(* if there are no existential variables.                         *)
-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.meta_type_map
-val extract_pftreestate : pftreestate -> constr
-val first_unproven : pftreestate -> pftreestate
-val last_unproven : pftreestate -> pftreestate
-val nth_unproven : int -> pftreestate -> pftreestate
-val node_prev_unproven : int -> pftreestate -> pftreestate
-val node_next_unproven : int -> pftreestate -> pftreestate
-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) ->
-  pftreestate -> pftreestate
-val up_to_matching_rule : (rule -> bool) ->
-  pftreestate -> pftreestate
-val change_rule : (rule -> rule) -> pftreestate -> pftreestate
-val change_constraints_pftreestate
-  : evar_map -> pftreestate -> pftreestate
-
-
-(*s Pretty-printers. *)
-
-(*i*)
-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 563d073a..b8279b8f 100644
--- a/proofs/tacexpr.ml
+++ b/proofs/tacexpr.ml
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacexpr.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Topconstr
 open Libnames
 open Nametab
-open Rawterm
+open Glob_term
 open Util
 open Genarg
 open Pattern
@@ -29,7 +27,7 @@ type split_flag = bool     (* true = exists           false = split *)
 type hidden_flag = bool    (* true = internal use     false = user-level *)
 type letin_flag = bool     (* true = use local def    false = use Leibniz *)
 
-type raw_red_flag =
+type glob_red_flag =
   | FBeta
   | FIota
   | FZeta
@@ -107,14 +105,6 @@ type 'id gclause =
 
 let nowhere = {onhyps=Some[]; concl_occs=no_occurrences_expr}
 
-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 \"in\" clause (one hypothesis or the conclusion)"
-
 type 'constr induction_clause =
   ('constr with_bindings induction_arg list * 'constr with_bindings option *
    (intro_pattern_expr located option * intro_pattern_expr located option))
@@ -201,7 +191,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr =
   | TacRight of evars_flag * 'constr bindings
   | TacSplit of evars_flag * split_flag * 'constr bindings list
   | TacAnyConstructor of evars_flag * 'tac option
-  | TacConstructor of evars_flag * int or_metaid * 'constr bindings
+  | TacConstructor of evars_flag * int or_var * 'constr bindings
 
   (* Conversion *)
   | TacReduce of ('constr,'cst,'pat) red_expr_gen * 'id gclause
@@ -239,6 +229,7 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr =
   | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
   | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
   | TacDo of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacTimeout of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
   | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
   | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
   | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * identifier option
@@ -249,7 +240,7 @@ and ('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
+  | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg located
 
 and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast =
   identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
@@ -272,8 +263,8 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg =
 
 (* Globalized tactics *)
 and glob_tactic_expr =
-    (rawconstr_and_expr,
-     rawconstr_and_expr * constr_pattern,
+    (glob_constr_and_expr,
+     glob_constr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
@@ -317,8 +308,8 @@ type raw_red_expr =
     (constr_expr, reference or_by_notation, constr_expr) red_expr_gen
 
 type glob_atomic_tactic_expr =
-    (rawconstr_and_expr,
-     rawconstr_and_expr * constr_pattern,
+    (glob_constr_and_expr,
+     glob_constr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
@@ -327,8 +318,8 @@ type glob_atomic_tactic_expr =
      glevel) gen_atomic_tactic_expr
 
 type glob_tactic_arg =
-    (rawconstr_and_expr,
-     rawconstr_and_expr * constr_pattern,
+    (glob_constr_and_expr,
+     glob_constr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
@@ -339,7 +330,7 @@ type glob_tactic_arg =
 type glob_generic_argument = glevel generic_argument
 
 type glob_red_expr =
-    (rawconstr_and_expr, evaluable_global_reference or_var, constr_pattern)
+    (glob_constr_and_expr, evaluable_global_reference or_var, constr_pattern)
     red_expr_gen
 
 type typed_generic_argument = tlevel generic_argument
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 3939a78b..5475daa8 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacmach.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -21,7 +19,6 @@ open Evd
 open Typing
 open Redexpr
 open Tacred
-open Proof_trees
 open Proof_type
 open Logic
 open Refiner
@@ -34,7 +31,6 @@ let re_sig it gc = { it = it; sigma = gc }
 (**************************************************************)
 
 type 'a sigma   = 'a Evd.sigma;;
-type validation = Proof_type.validation;;
 type tactic     = Proof_type.tactic;;
 
 let unpackage = Refiner.unpackage
@@ -46,7 +42,7 @@ let project  = Refiner.project
 let pf_env   = Refiner.pf_env
 let pf_hyps  = Refiner.pf_hyps
 
-let pf_concl gls = (sig_it gls).evar_concl
+let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls)
 let pf_hyps_types gls  =
   let sign = Environ.named_context (pf_env gls) in
   List.map (fun (id,_,x) -> (id, x)) sign
@@ -123,11 +119,11 @@ let pf_matches                  = pf_apply Matching.matches_conv
 (* Tactics handling a list of goals *)
 (************************************)
 
-type transformation_tactic = proof_tree -> (goal list * validation)
+type transformation_tactic = proof_tree -> goal list 
 
 type validation_list = proof_tree list -> proof_tree list
 
-type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+type tactic_list = Refiner.tactic_list 
 
 let first_goal         = first_goal
 let goal_goal_list     = goal_goal_list
@@ -138,37 +134,6 @@ let tclFIRSTLIST       = tclFIRSTLIST
 let tclIDTAC_list      = tclIDTAC_list
 
 
-(********************************************************)
-(* Functions for handling the state of the proof editor *)
-(********************************************************)
-
-type pftreestate = Refiner.pftreestate
-
-let proof_of_pftreestate    = proof_of_pftreestate
-let cursor_of_pftreestate   = cursor_of_pftreestate
-let is_top_pftreestate      = is_top_pftreestate
-let evc_of_pftreestate      = evc_of_pftreestate
-let top_goal_of_pftreestate = top_goal_of_pftreestate
-let nth_goal_of_pftreestate = nth_goal_of_pftreestate
-let traverse                = traverse
-let solve_nth_pftreestate   = solve_nth_pftreestate
-let solve_pftreestate       = solve_pftreestate
-let weak_undo_pftreestate   = weak_undo_pftreestate
-let mk_pftreestate          = mk_pftreestate
-let extract_pftreestate     = extract_pftreestate
-let extract_open_pftreestate = extract_open_pftreestate
-let first_unproven          = first_unproven
-let last_unproven           = last_unproven
-let nth_unproven            = nth_unproven
-let node_prev_unproven      = node_prev_unproven
-let node_next_unproven      = node_next_unproven
-let next_unproven           = next_unproven
-let prev_unproven           = prev_unproven
-let top_of_tree             = top_of_tree
-let frontier                = frontier
-let change_constraints_pftreestate = change_constraints_pftreestate
-
-
 (********************************************)
 (* Definition of the most primitive tactics *)
 (********************************************)
@@ -237,16 +202,20 @@ let rename_hyp l       = with_check (rename_hyp_no_check l)
 
 open Pp
 open Tacexpr
-open Rawterm
+open Glob_term
 
-let rec pr_list f = function
-  | []   -> mt ()
-  | a::l1 -> (f a) ++ pr_list f l1
+let db_pr_goal sigma g =
+  let env = Goal.V82.env sigma g in
+  let penv = print_named_context env in
+  let pc = print_constr_env env (Goal.V82.concl sigma g) in
+  str"  " ++ hv 0 (penv ++ fnl () ++
+                   str "============================" ++ fnl ()  ++
+                   str" "  ++ pc) ++ fnl ()
 
 let pr_gls gls =
-  hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls))
+  hov 0 (pr_evar_map (Some 2) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it 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))
+  hov 0 (pr_evar_map (Some 2) (sig_sig glls) ++ fnl () ++
+         prlist_with_sep pr_fnl (db_pr_goal (project glls)) (sig_it glls))
 
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 6938c320..884a0307 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -1,33 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacmach.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Sign
 open Environ
 open Evd
 open Reduction
-open Proof_trees
 open Proof_type
 open Refiner
 open Redexpr
 open Tacexpr
-open Rawterm
+open Glob_term
 open Pattern
-(*i*)
 
-(* Operations for handling terms under a local typing context. *)
+(** Operations for handling terms under a local typing context. *)
 
 type 'a sigma   = 'a Evd.sigma;;
-type validation = Proof_type.validation;;
 type tactic     = Proof_type.tactic;;
 
 val sig_it  : 'a sigma   -> 'a
@@ -38,7 +32,7 @@ val re_sig : 'a -> evar_map -> 'a sigma
 val unpackage : 'a sigma -> evar_map ref * 'a
 val repackage : evar_map ref -> 'a -> 'a sigma
 val apply_sig_tac :
-  evar_map ref -> (goal sigma -> (goal list) sigma * validation) -> goal -> (goal list) * validation
+  evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) 
 
 val pf_concl              : goal sigma -> types
 val pf_env                : goal sigma -> env
@@ -90,40 +84,8 @@ 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
-
-
-(*s Functions for handling the state of the proof editor. *)
-
-type pftreestate = Refiner.pftreestate
-
-val proof_of_pftreestate    : pftreestate -> proof_tree
-val cursor_of_pftreestate   : pftreestate -> int list
-val is_top_pftreestate      : pftreestate -> bool
-val evc_of_pftreestate      : pftreestate -> evar_map
-val top_goal_of_pftreestate : pftreestate -> goal sigma
-val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma
-val traverse                : int -> pftreestate -> pftreestate
-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.meta_type_map
-val extract_pftreestate     : pftreestate -> constr
-val first_unproven          : pftreestate -> pftreestate
-val last_unproven           : pftreestate -> pftreestate
-val nth_unproven            : int -> pftreestate -> pftreestate
-val node_prev_unproven      : int -> pftreestate -> pftreestate
-val node_next_unproven      : int -> pftreestate -> pftreestate
-val next_unproven           : pftreestate -> pftreestate
-val prev_unproven           : pftreestate -> pftreestate
-val top_of_tree             : pftreestate -> pftreestate
-val change_constraints_pftreestate :
-  evar_map -> pftreestate -> pftreestate
-
-(*s The most primitive tactics. *)
+
+(** {6 The most primitive tactics. } *)
 
 val refiner                   : rule -> tactic
 val introduction_no_check     : identifier -> tactic
@@ -142,7 +104,7 @@ val mutual_fix      :
   identifier -> int -> (identifier * int * constr) list -> int -> tactic
 val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
 
-(*s The most primitive tactics with consistency and type checking *)
+(** {6 The most primitive tactics with consistency and type checking } *)
 
 val introduction     : identifier -> tactic
 val internal_cut     : bool -> identifier -> types -> tactic
@@ -155,11 +117,11 @@ val thin_body        : identifier list -> tactic
 val move_hyp         : bool -> identifier -> identifier move_location -> tactic
 val rename_hyp       : (identifier*identifier) list -> tactic
 
-(*s Tactics handling a list of goals. *)
+(** {6 Tactics handling a list of goals. } *)
 
 type validation_list = proof_tree list -> proof_tree list
 
-type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+type tactic_list = Refiner.tactic_list
 
 val first_goal         : 'a list sigma -> 'a sigma
 val goal_goal_list     : 'a sigma -> 'a list sigma
@@ -169,6 +131,6 @@ val tactic_list_tactic : tactic_list -> tactic
 val tclFIRSTLIST       : tactic_list list -> tactic_list
 val tclIDTAC_list      : tactic_list
 
-(*s Pretty-printing functions (debug only). *)
+(** {6 Pretty-printing functions (debug only). } *)
 val pr_gls    : goal sigma -> Pp.std_ppcmds
 val pr_glls   : goal list sigma -> Pp.std_ppcmds
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index 7922eeb0..1c2fb278 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_debug.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Names
 open Constrextern
 open Pp
@@ -36,8 +34,18 @@ let explain_logic_error = ref (fun e -> mt())
 let explain_logic_error_no_anomaly = ref (fun e -> mt())
 
 (* Prints the goal *)
+
+let db_pr_goal g =
+  let env = Refiner.pf_env g in
+  let penv = print_named_context env in
+  let pc = print_constr_env env (Goal.V82.concl (Refiner.project g) (Refiner.sig_it g)) in
+  str"  " ++ hv 0 (penv ++ fnl () ++
+                   str "============================" ++ fnl ()  ++
+                   str" "  ++ pc) ++ fnl ()
+
 let db_pr_goal g =
-  msgnl (str "Goal:" ++ fnl () ++ Proof_trees.db_pr_goal (Refiner.sig_it g))
+  msgnl (str "Goal:" ++ fnl () ++ db_pr_goal g)
+
 
 (* Prints the commands *)
 let help () =
@@ -146,11 +154,6 @@ let db_mc_pattern_success debug =
     msgnl (str "The goal has been successfully matched!" ++ fnl() ++
            str "Let us execute the right-hand side part..." ++ fnl())
 
-let pp_match_pattern env = function
-  | Term c -> Term (extern_constr_pattern (names_of_rel_context env) c)
-  | Subterm (b,o,c) ->
-    Subterm (b,o,(extern_constr_pattern (names_of_rel_context env) c))
-
 (* Prints a failure message for an hypothesis pattern *)
 let db_hyp_pattern_failure debug env (na,hyp) =
   if debug <> DebugOff & !skip = 0 then
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index e2606a06..d96f4c74 100644
--- a/proofs/tactic_debug.mli
+++ b/proofs/tactic_debug.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_debug.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Environ
 open Pattern
 open Evd
@@ -16,7 +14,7 @@ open Names
 open Tacexpr
 open Term
 
-(* This module intends to be a beginning of debugger for tactic expressions.
+(** This module intends to be a beginning of debugger for tactic expressions.
    Currently, it is quite simple and we can hope to have, in the future, a more
    complete panel of commands dedicated to a proof assistant framework *)
 
@@ -24,53 +22,53 @@ val set_tactic_printer : (glob_tactic_expr ->Pp.std_ppcmds) -> unit
 val set_match_pattern_printer :
   (env -> constr_pattern match_pattern -> Pp.std_ppcmds) -> unit
 val set_match_rule_printer :
-  ((Genarg.rawconstr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
+  ((Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
     unit
 
-(* Debug information *)
+(** Debug information *)
 type debug_info =
   | DebugOn of int
   | DebugOff
 
-(* Prints the state and waits *)
+(** Prints the state and waits *)
 val debug_prompt :
   int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a
 
-(* Prints a constr *)
+(** Prints a constr *)
 val db_constr : debug_info -> env -> constr -> unit
 
-(* Prints the pattern rule *)
+(** Prints the pattern rule *)
 val db_pattern_rule :
-  debug_info -> int -> (Genarg.rawconstr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit
+  debug_info -> int -> (Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit
 
-(* Prints a matched hypothesis *)
+(** Prints a matched hypothesis *)
 val db_matched_hyp :
   debug_info -> env -> identifier * constr option * constr -> name -> unit
 
-(* Prints the matched conclusion *)
+(** Prints the matched conclusion *)
 val db_matched_concl : debug_info -> env -> constr -> unit
 
-(* Prints a success message when the goal has been matched *)
+(** Prints a success message when the goal has been matched *)
 val db_mc_pattern_success : debug_info -> unit
 
-(* Prints a failure message for an hypothesis pattern *)
+(** Prints a failure message for an hypothesis pattern *)
 val db_hyp_pattern_failure :
   debug_info -> env -> name * constr_pattern match_pattern -> unit
 
-(* Prints a matching failure message for a rule *)
+(** Prints a matching failure message for a rule *)
 val db_matching_failure : debug_info -> unit
 
-(* Prints an evaluation failure message for a rule *)
+(** Prints an evaluation failure message for a rule *)
 val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit
 
-(* An exception handler *)
+(** An exception handler *)
 val explain_logic_error: (exn -> Pp.std_ppcmds) ref
 
-(* For use in the Ltac debugger: some exception that are usually
+(** For use in the Ltac debugger: some exception that are usually
    consider anomalies are acceptable because they are caught later in
    the process that is being debugged.  One should not require
    from users that they report these anomalies. *)
 val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref
 
-(* Prints a logic failure message for a rule *)
+(** Prints a logic failure message for a rule *)
 val db_logic_failure : debug_info -> exn -> unit
diff --git a/proofs/tmp-src b/proofs/tmp-src
deleted file mode 100644
index 1da11fe0..00000000
--- a/proofs/tmp-src
+++ /dev/null
@@ -1,56 +0,0 @@
-
-(********* INSTANTIATE ****************************************************)
-
-(* existential_type gives the type of an existential *)
-let existential_type env k = 
-  let (sp,args) = destConst k in
-  let evd = Evd.map (evar_map env) sp in
-  instantiate_constr 
-    (ids_of_sign evd.evar_hyps) evd.evar_concl.body (Array.to_list args)
-
-(* existential_value gives the value of a defined existential *)
-let existential_value env k =
-  let (sp,args) = destConst k in
-  if defined_const env k then
-    let evd = Evd.map (evar_map env) sp in
-    match evd.evar_body with
-      | EVAR_DEFINED c ->
- 	  instantiate_constr (ids_of_sign evd.evar_hyps) c (Array.to_list args)
-      | _ -> anomalylabstrm "termenv__existential_value"
-            [< 'sTR"The existential variable code just registered a" ;
-               'sPC ; 'sTR"grave internal error." >]
-  else 
-    failwith "undefined existential"
-
-
-(******* REDUCTION ********************************************************)
-
-
-(************ REDUCTION.MLI **********************************************)
-
-(*********** TYPEOPS *****************************************************)
-
-
-(* Constants or existentials. *)
-
-let type_of_constant_or_existential env c =
-  if is_existential c then
-    type_of_existential env c
-  else
-    type_of_constant env c
-
-
-(******** TYPING **********************************************************)
-
-    | IsMeta n ->
-       	let metaty =
-          try lookup_meta n env
-          with Not_found -> error "A variable remains non instanciated" 
-	in
-        (match kind_of_term metaty with
-           | IsCast (typ,kind) -> 
-	       ({ uj_val = cstr; uj_type = typ; uj_kind = kind }, cst0)
-           | _ ->
-	       let (jty,cst) = execute mf env metaty in
-	       let k = whd_betadeltaiotaeta env jty.uj_type in
-	       ({ uj_val = cstr; uj_type = metaty; uj_kind = k }, cst))
diff --git a/scripts/coqc.ml b/scripts/coqc.ml
index d5544b94..dfcb9c18 100644
--- a/scripts/coqc.ml
+++ b/scripts/coqc.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqc.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Afin de rendre Coq plus portable, ce programme Caml remplace le script
    coqc.
 
@@ -133,7 +131,7 @@ let parse_args () =
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
     | ("-outputstate"|"-inputstate"|"-is"
       |"-load-vernac-source"|"-l"|"-load-vernac-object"
-      |"-load-ml-source"|"-require"|"-load-ml-object"|"-user"
+      |"-load-ml-source"|"-require"|"-load-ml-object"
       |"-init-file"|"-dump-glob"|"-compat"|"-coqlib" as o) :: rem ->
 	begin
 	  match rem with
@@ -153,12 +151,11 @@ let parse_args () =
     | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem
 
     | ("-notactics"|"-debug"|"-nolib"
-      |"-debugVM"|"-alltransp"|"-VMno"
       |"-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" as o) :: rem ->
+      |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs"
+      |"-impredicative-set"|"-vm" as o) :: rem ->
 	parse (cfiles,o::args) rem
 
     | ("-where") :: _ ->
@@ -169,7 +166,7 @@ let parse_args () =
     | ("-config" | "--config") :: _ -> Usage.print_config (); exit 0
 
     | ("-v"|"--version") :: _ ->
-        Usage.version ()
+        Usage.version 0
     | f :: rem ->
 	if Sys.file_exists f then
 	  parse (f::cfiles,args) rem
@@ -195,7 +192,7 @@ let main () =
     end;
     let coqtopname =
       if !image <> "" then !image
-      else Filename.concat (Envars.coqbin ()) (!binary ^ Coq_config.exec_extension)
+      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
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
index c7596d83..7dcfbab1 100644
--- a/scripts/coqmktop.ml
+++ b/scripts/coqmktop.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqmktop.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* coqmktop is a script to link Coq, analogous to ocamlmktop.
    The command line contains options specific to coqmktop, options for the
    Ocaml linker and files to link (in addition to the default Coq files). *)
@@ -19,7 +17,8 @@ open Unix
 (* 1. Core objects *)
 let ocamlobjs = ["str.cma";"unix.cma";"nums.cma"]
 let dynobjs = ["dynlink.cma"]
-let camlp4objs = ["gramlib.cma"]
+let camlp4objs =
+  if Coq_config.camlp4 = "camlp5" then ["gramlib.cma"] else ["camlp4lib.cma"]
 let libobjs = ocamlobjs @ camlp4objs
 
 let spaces = Str.regexp "[ \t\n]+"
@@ -28,14 +27,17 @@ 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
 
 (* 3. Toplevel objects *)
 let camlp4topobjs =
   if Coq_config.camlp4 = "camlp5" then
     ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"]
   else
-    ["camlp4_top.cma"; "pa_o.cmo"; "pa_op.cmo"; "pa_extend.cmo"]
+    [ "Camlp4Top.cmo";
+      "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo";
+      "Camlp4Parsers/Camlp4OCamlParser.cmo";
+      "Camlp4Parsers/Camlp4GrammarParser.cmo";
+      "q_util.cmo"; "q_coqast.cmo" ]
 let topobjs = camlp4topobjs
 
 let gramobjs = []
@@ -47,13 +49,11 @@ let notopobjs = gramobjs
 let opt        = ref false
 let full       = ref false
 let top        = ref false
-let searchisos = ref false
-let coqide     = ref false
 let echo       = ref false
+let no_start   = ref false
 
 let src_dirs () =
-  [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] @
-  if !coqide then [[ "ide" ]] else []
+  [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ]
 
 let includes () =
   let coqlib = Envars.coqlib () in
@@ -62,8 +62,7 @@ let includes () =
       (fun d l -> "-I" :: ("\"" ^ List.fold_left Filename.concat coqlib d ^ "\"") :: l)
       (src_dirs ())
       (["-I"; "\"" ^ camlp4lib ^ "\""] @
-	 ["-I"; "\"" ^ coqlib ^ "\""] @
-	 (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
+	  ["-I"; "\"" ^ coqlib ^ "\""])
 
 (* Transform bytecode object file names in native object file names *)
 let native_suffix f =
@@ -89,18 +88,10 @@ 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"::"Lablgtk"::"GtkThread"::ide else []
-  in
-  let ide_libs =
-    if !coqide then
-      ["threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ; "ide/ide.cma" ]
-    else []
-  in
-  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs @ ide_objs in
+  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs in
   let modules = List.map module_of_file (objs @ userfiles)
   in
-  let libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs @ ide_libs in
+  let libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs in
   let libstolink =
     (if !opt then List.map native_suffix libs else libs) @ userfiles
   in
@@ -132,20 +123,19 @@ let all_subdirs dir =
 
 (* usage *)
 let usage () =
-  prerr_endline "Usage: coqmktop <options> <ocaml options> files
-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
-  -echo          Print calls to external commands
-  -ide           Build a toplevel for the Coq IDE
-  -full          Link high level tactics
-  -opt           Compile in native code
-  -searchisos    Build a toplevel for SearchIsos
-  -top           Build Coq on a OCaml toplevel (incompatible with -opt)
-  -R dir         Specify recursively directories for Ocaml\n";
+  prerr_endline "Usage: coqmktop <options> <ocaml options> files\
+\nFlags are:\
+\n  -coqlib dir    Specify where the Coq object files are\
+\n  -camlbin dir   Specify where the OCaml binaries are\
+\n  -camlp4bin dir Specify where the Camlp4/5 binaries are\
+\n  -o exec-file   Specify the name of the resulting toplevel\
+\n  -boot          Run in boot mode\
+\n  -echo          Print calls to external commands\
+\n  -full          Link high level tactics\
+\n  -opt           Compile in native code\
+\n  -top           Build Coq on a OCaml toplevel (incompatible with -opt)\
+\n  -R dir         Add recursively dir to OCaml search path\
+\n";
   exit 1
 
 (* parsing of the command line *)
@@ -165,8 +155,6 @@ let parse_args () =
     | "-opt" :: rem -> opt := true ; parse (op,fl) rem
     | "-full" :: rem -> full := true ; parse (op,fl) rem
     | "-top" :: rem -> top := true ; parse (op,fl) rem
-    | "-ide" :: rem ->
-        coqide := true; parse (op,fl) rem
     | "-v8" :: rem ->
 	Printf.eprintf "warning: option -v8 deprecated";
 	parse (op,fl) rem
@@ -184,12 +172,14 @@ let parse_args () =
     | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem ->
         parse (o::op,fl) rem
     | ("-h"|"--help") :: _ -> usage ()
+    | ("-no-start") :: rem -> no_start:=true; parse (op, fl) rem
     | f :: rem ->
 	if Filename.check_suffix f ".ml"
 	  or Filename.check_suffix f ".cmx"
 	  or Filename.check_suffix f ".cmo"
 	  or Filename.check_suffix f ".cmxa"
-	  or Filename.check_suffix f ".cma" then
+	  or Filename.check_suffix f ".cma"
+	  or Filename.check_suffix f ".c" then
 	    parse (op,f::fl) rem
 	else begin
 	  prerr_endline ("Don't know what to do with " ^ f);
@@ -220,23 +210,24 @@ let declare_loading_string () =
   if not !top then
     "Mltop.remove ();;"
   else
-    "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=
-         (fun f -> if not (Topdirs.load_file ppf f) then Util.error (\"Could not load plugin \"^f));\
-        Mltop.use_file=Topdirs.dir_use ppf;
-        Mltop.add_dir=Topdirs.dir_directory;
-        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n"
+    "begin try\
+\n       (* Enable rectypes in the toplevel if it has the directive #rectypes *)\
+\n       begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\
+\n         | Toploop.Directive_none f -> f ()\
+\n         | _ -> ()\
+\n       end\
+\n     with\
+\n       | Not_found -> ()\
+\n     end;;\
+\n\
+\n     let ppf = Format.std_formatter;;\
+\n     Mltop.set_top\
+\n       {Mltop.load_obj=\
+\n         (fun f -> if not (Topdirs.load_file ppf f) then Util.error (\"Could not load plugin \"^f));\
+\n        Mltop.use_file=Topdirs.dir_use ppf;\
+\n        Mltop.add_dir=Topdirs.dir_directory;\
+\n        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\
+\n"
 
 (* create a temporary main file to link *)
 let create_tmp_main_file modules =
@@ -249,13 +240,9 @@ let create_tmp_main_file 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
-      output_string oc "Cmd_searchisos_line.start();;\n"
-    else if !coqide then
-      output_string oc "Coqide.start();;\n"
-    else
-      output_string oc "Coqtop.start();;\n";
+    (* Start the toplevel loop *)
+    if not !no_start then
+    output_string oc "Coqtop.start();;\n";
     close_out oc;
     main_name
   with e ->
diff --git a/states/MakeInitial.v b/states/MakeInitial.v
index 1787c840..e5551d20 100644
--- a/states/MakeInitial.v
+++ b/states/MakeInitial.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 6a9ced3e..93ca89f4 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: auto.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -27,7 +25,7 @@ open Matching
 open Tacmach
 open Proof_type
 open Pfedit
-open Rawterm
+open Glob_term
 open Evar_refiner
 open Tacred
 open Tactics
@@ -48,23 +46,43 @@ open Mod_subst
 (*            The Type of Constructions Autotactic Hints                    *)
 (****************************************************************************)
 
-type auto_tactic =
-  | Res_pf     of constr * clausenv (* Hint Apply *)
-  | ERes_pf    of constr * clausenv (* Hint EApply *)
+type 'a auto_tactic =
+  | Res_pf     of constr * 'a (* Hint Apply *)
+  | ERes_pf    of constr * 'a (* Hint EApply *)
   | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
+  | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *)
   | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
   | Extern     of glob_tactic_expr       (* Hint Extern *)
 
-type pri_auto_tactic = {
-  pri  : int;            (* A number between 0 and 4, 4 = lower priority *)
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+type 'a gen_auto_tactic = {
+  pri  : int;            (* A number lower is higher priority *)
   pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
-  code : auto_tactic     (* the tactic to apply when the concl matches pat *)
+  name  : hints_path_atom; (* A potential name to refer to the hint *) 
+  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
 }
 
-type hint_entry = global_reference option * pri_auto_tactic
+type pri_auto_tactic = clausenv gen_auto_tactic
 
-let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2
+type hint_entry = global_reference option * types gen_auto_tactic
+
+let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) =
+  let d = pri1 - pri2 in
+    if d == 0 then id2 - id1
+    else d
+
+let pri_order t1 t2 = pri_order_int t1 t2 <= 0
 
 let insert v l =
   let rec insrec = function
@@ -74,32 +92,45 @@ let insert v l =
   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.
+  La table impérative "searchtable", de type "hint_db_table",
+   associe une database (hint_db) à chaque nom.
 
   Une hint_db est une table d'association fonctionelle constr -> search_entry
-  Le constr correspond à la constante de tête de la conclusion.
+  Le constr correspond à la constante de tête de la conclusion.
 
   Une search_entry est un triplet comprenant :
-     - la liste des tactiques qui n'ont pas de pattern associé
+     - la liste des tactiques qui n'ont pas de pattern associé
      - la liste des tactiques qui ont un pattern
-     - un discrimination net borné (Btermdn.t) constitué de tous les
+     - un discrimination net borné (Btermdn.t) constitué de tous les
        patterns de la seconde liste de tactiques *)
 
-type stored_data = pri_auto_tactic
+type stored_data = int * pri_auto_tactic
+    (* First component is the index of insertion in the table, to keep most recent first semantics. *)
+
+let auto_tactic_ord code1 code2 =
+  match code1, code2 with
+  | Res_pf (c1, _), Res_pf (c2, _)
+  | ERes_pf (c1, _), ERes_pf (c2, _)
+  | Give_exact c1, Give_exact c2
+  | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> constr_ord c1 c2
+  | Unfold_nth (EvalVarRef i1), Unfold_nth (EvalVarRef i2) -> Pervasives.compare i1 i2
+  | Unfold_nth (EvalConstRef c1), Unfold_nth (EvalConstRef c2) ->
+      kn_ord (canonical_con c1) (canonical_con c2)
+  | Extern t1, Extern t2 -> Pervasives.compare t1 t2
+  | _ -> Pervasives.compare code1 code2
 
 module Bounded_net = Btermdn.Make(struct
 				    type t = stored_data
-				    let compare = Pervasives.compare
+				    let compare = pri_order_int
 				  end)
 
 type search_entry = stored_data list * stored_data list * Bounded_net.t
 
 let empty_se = ([],[],Bounded_net.create ())
 
-let eq_pri_auto_tactic x y =
+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,_) -> 
@@ -118,15 +149,18 @@ let eq_pri_auto_tactic x y =
 let add_tac pat t st (l,l',dn) =
   match pat with
   | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn)
-  | Some pat -> if not (List.exists (eq_pri_auto_tactic t) l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn)
+  | 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 -> Bounded_net.add (Some st) dn (Option.get t.pat, t))
+let rebuild_dn st ((l,l',dn) : search_entry) =
+  (l, l', List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t)))
     (Bounded_net.create ()) l')
 
+
 let lookup_tacs (hdc,c) st (l,l',dn) =
   let l'  = List.map snd (Bounded_net.lookup st dn c) in
-  let sl' = Sort.list pri_order l' in
+  let sl' = List.stable_sort pri_order_int l' in
     Sort.merge pri_order l sl'
 
 module Constr_map = Map.Make(RefOrdered)
@@ -136,11 +170,138 @@ let is_transparent_gr (ids, csts) = function
   | ConstRef cst -> Cpred.mem cst csts
   | IndRef _ | ConstructRef _ -> false
 
+let dummy_goal = Goal.V82.dummy_goal
+
+let translate_hint (go,p) =
+  let mk_clenv (c,t) =
+    let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env }
+  in
+  let code = match p.code with
+    | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t))
+    | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t))
+    | Res_pf_THEN_trivial_fail (c,t) ->
+      Res_pf_THEN_trivial_fail (c, mk_clenv (c,t))
+    | Give_exact c -> Give_exact c
+    | Unfold_nth e -> Unfold_nth e
+    | Extern t -> Extern t
+  in
+  (go,{ p with code = code })
+
+let path_matches hp hints =
+  let rec aux hp hints k =
+    match hp, hints with
+    | PathAtom _, [] -> false
+    | PathAtom PathAny, (_ :: hints') -> k hints'
+    | PathAtom p, (h :: hints') -> 
+      if p = h then k hints' else false
+    | PathStar hp', hints -> 
+      k hints || aux hp' hints (fun hints' -> aux hp hints' k)
+    | PathSeq (hp, hp'), hints -> 
+      aux hp hints (fun hints' -> aux hp' hints' k)
+    | PathOr (hp, hp'), hints ->
+      aux hp hints k || aux hp' hints k
+    | PathEmpty, _ -> false
+    | PathEpsilon, hints -> k hints
+  in aux hp hints (fun hints' -> true)
+
+let rec matches_epsilon = function
+  | PathAtom _ -> false
+  | PathStar _ -> true
+  | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathOr (p, p') -> matches_epsilon p || matches_epsilon p'
+  | PathEmpty -> false
+  | PathEpsilon -> true
+
+let rec is_empty = function
+  | PathAtom _ -> false
+  | PathStar _ -> false
+  | PathSeq (p, p') -> is_empty p || is_empty p'
+  | PathOr (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathEmpty -> true
+  | PathEpsilon -> false
+
+let rec path_derivate hp hint =
+  let rec derivate_atoms hints hints' =
+    match hints, hints' with
+    | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs'
+    | [], [] -> PathEpsilon
+    | [], hints -> PathEmpty
+    | grs, [] -> PathAtom (PathHints grs)
+    | _, _ -> PathEmpty 
+  in
+    match hp with
+    | PathAtom PathAny -> PathEpsilon
+    | PathAtom (PathHints grs) -> 
+      (match grs, hint with
+       | h :: hints, PathAny -> PathEmpty
+       | hints, PathHints hints' -> derivate_atoms hints hints'
+       | _, _ -> assert false)
+    | PathStar p -> if path_matches p [hint] then hp else PathEpsilon
+    | PathSeq (hp, hp') ->
+      let hpder = path_derivate hp hint in
+	if matches_epsilon hp then 
+	  PathOr (PathSeq (hpder, hp'), path_derivate hp' hint)
+	else if is_empty hpder then PathEmpty 
+	else PathSeq (hpder, hp')
+    | PathOr (hp, hp') ->
+      PathOr (path_derivate hp hint, path_derivate hp' hint)
+    | PathEmpty -> PathEmpty
+    | PathEpsilon -> PathEmpty
+
+let rec normalize_path h =
+  match h with
+  | PathStar PathEpsilon -> PathEpsilon
+  | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty
+  | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p
+  | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p
+  | PathOr (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if p = p' && q = q' then h
+      else normalize_path (PathOr (p', q'))
+  | PathSeq (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if p = p' && q = q' then h
+      else normalize_path (PathSeq (p', q'))
+  | _ -> h
+
+let path_derivate hp hint = normalize_path (path_derivate hp hint)
+
+let rec pp_hints_path = function
+  | PathAtom (PathAny) -> str"."
+  | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs
+  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
+  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
+  | PathOr (p, p') -> 
+    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
+  | PathEmpty -> str"Ø"
+  | PathEpsilon -> str"ε"
+
+let rec subst_hints_path subst hp =
+  match hp with
+  | PathAtom PathAny -> hp
+  | PathAtom (PathHints grs) -> 
+    let gr' gr = fst (subst_global subst gr) in
+    let grs' = list_smartmap gr' grs in
+      if grs' == grs then hp else PathAtom (PathHints grs')
+  | PathStar p -> let p' = subst_hints_path subst p in
+      if p' == p then hp else PathStar p'
+  | PathSeq (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathSeq (p', q')
+  | PathOr (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathOr (p', q')
+  | _ -> hp
+
 module Hint_db = struct
 
   type t = {
     hintdb_state : Names.transparent_state;
+    hintdb_cut : hints_path;
     hintdb_unfolds : Idset.t * Cset.t;
+    mutable hintdb_max_id : int;
     use_dn : bool;
     hintdb_map : search_entry Constr_map.t;
     (* A list of unindexed entries starting with an unfoldable constant
@@ -148,8 +309,13 @@ module Hint_db = struct
     hintdb_nopat : (global_reference option * stored_data) list
   }
 
+  let next_hint_id t = 
+    let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h
+
   let empty st use_dn = { hintdb_state = st;
+			  hintdb_cut = PathEmpty;
 			  hintdb_unfolds = (Idset.empty, Cset.empty);
+			  hintdb_max_id = 0;
 			  use_dn = use_dn;
 			  hintdb_map = Constr_map.empty;
 			  hintdb_nopat = [] }
@@ -157,47 +323,54 @@ module Hint_db = struct
   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 (List.map snd db.hintdb_nopat) []
-
+    List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
+    
   let map_all k db =
     let (l,l',_) = find k db in
-      Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l'
+      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
 
   let map_auto (k,c) db =
     let st = if db.use_dn then Some db.hintdb_state else None in
     let l' = lookup_tacs (k,c) st (find k db) in
-      Sort.merge pri_order (List.map snd db.hintdb_nopat) l'
+      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
 
   let is_exact = function
     | Give_exact _ -> true
     | _ -> false
 
-  let addkv gr v db =
+  let is_unfold = function
+    | Unfold_nth _ -> true
+    | _ -> false
+
+  let addkv gr id v db =
+    let idv = id, v in
     let k = match gr with
-      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr
+      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr &&
+	  is_unfold v.code then None else Some gr
       | None -> None
     in
     let dnst = if db.use_dn then Some db.hintdb_state else None in
     let pat = if not db.use_dn && is_exact v.code then None else v.pat in
       match k with
       | None ->
-	  if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then
-	    { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat }
+	  if not (List.exists (fun (_, (_, v')) -> v = v') db.hintdb_nopat) then
+	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
 	  else db
       | Some gr ->
 	  let oval = find gr db in
-	    { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map }
+	    { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map }
 
   let rebuild_db st' db =
     let db' =
       { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map;
 	hintdb_state = st'; hintdb_nopat = [] }
     in
-      List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat
+      List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
 
-  let add_one (k,v) db =
+  let add_one kv db =
+    let (k,v) = translate_hint kv in
     let st',db,rebuild =
       match v.code with
       | Unfold_nth egr ->
@@ -211,13 +384,27 @@ module Hint_db = struct
       | _ -> 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
+    in addkv k (next_hint_id db) v db
 
   let add_list l db = List.fold_right add_one l db
 
+  let remove_sdl p sdl = list_smartfilter p sdl 
+  let remove_he st p (sl1, sl2, dn as he) =
+    let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in
+      if sl1' == sl1 && sl2' == sl2 then he
+      else rebuild_dn st (sl1', sl2', dn)
+
+  let remove_list grs db =
+    let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem gr grs) | _ -> true in
+    let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in
+    let hintnopat = list_smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
+      { db with hintdb_map = hintmap; hintdb_nopat = hintnopat }
+
+  let remove_one gr db = remove_list [gr] db
+
   let iter f db =
-    f None (List.map snd db.hintdb_nopat);
-    Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map
+    f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat);
+    Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map
 
   let transparent_state db = db.hintdb_state
 
@@ -225,6 +412,11 @@ module Hint_db = struct
     if db.use_dn then rebuild_db st db
     else { db with hintdb_state = st }
 
+  let add_cut path db =
+    { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) }
+
+  let cut db = db.hintdb_cut
+
   let unfolds db = db.hintdb_unfolds
 
   let use_dn db = db.use_dn
@@ -255,6 +447,9 @@ let current_db_names () =
 (**************************************************************************)
 
 let auto_init : (unit -> unit) ref = ref (fun () -> ())
+let add_auto_init f = 
+  let init = !auto_init in
+    auto_init := (fun () -> init (); f ())
 
 let init     () = searchtable := Hintdbmap.empty; !auto_init ()
 let freeze   () = !searchtable
@@ -280,47 +475,51 @@ let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable."
 
-let dummy_goal =
-  {it = make_evar empty_named_context_val mkProp;
-   sigma = empty}
+let name_of_constr c = try Some (global_of_constr c) with Not_found -> None
 
-let make_exact_entry sigma pri (c,cty) =
+let make_exact_entry sigma pri ?(name=PathAny) (c,cty) =
   let cty = strip_outer_cast cty in
     match kind_of_term cty with
     | Prod _ -> failwith "make_exact_entry"
     | _ ->
 	let pat = snd (Pattern.pattern_of_constr sigma cty) in
-	let head = 
-	  try head_of_constr_reference (fst (head_constr cty)) 
-	  with _ -> failwith "make_exact_entry" 
+	let hd =
+	  try head_pattern_bound pat
+	  with BoundPattern -> failwith "make_exact_entry"
 	in
-          (Some head,
-	  { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c })
+          (Some hd,
+	  { pri = (match pri with None -> 0 | Some p -> p);
+	    pat = Some pat;
+	    name = name;
+	    code = Give_exact c })
 
-let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
+let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) =
   let cty = if hnf then hnf_constr env sigma cty else cty in
     match kind_of_term cty with
     | Prod _ ->
         let ce = mk_clenv_from dummy_goal (c,cty) in
 	let c' = clenv_type (* ~reduce:false *) ce in
 	let pat = snd (Pattern.pattern_of_constr sigma c') in
-        let hd = (try head_pattern_bound pat
-          with BoundPattern -> failwith "make_apply_entry") in
+        let hd =
+	  try head_pattern_bound pat
+          with BoundPattern -> failwith "make_apply_entry" in
         let nmiss = List.length (clenv_missing ce) in
 	if nmiss = 0 then
 	  (Some hd,
           { pri = (match pri with None -> nb_hyp cty | Some p -> p);
             pat = Some pat;
-            code = Res_pf(c,{ce with env=empty_env}) })
+	    name = name;
+            code = Res_pf(c,cty) })
 	else begin
 	  if not eapply then failwith "make_apply_entry";
           if verbose then
 	    warn (str "the hint: eapply " ++ pr_lconstr c ++
 	    str " will only be used by eauto");
           (Some hd,
-            { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
-              pat = Some pat;
-              code = ERes_pf(c,{ce with env=empty_env}) })
+           { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
+             pat = Some pat;
+	     name = name;
+             code = ERes_pf(c,cty) })
         end
     | _ -> failwith "make_apply_entry"
 
@@ -328,12 +527,12 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
    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 make_resolves env sigma flags pri ?name c =
+  let cty = Retyping.get_type_of env sigma c in
   let ents =
     map_succeed
       (fun f -> f (c,cty))
-      [make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
+      [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name]
   in
   if ents = [] then
     errorlabstrm "Hint"
@@ -345,7 +544,8 @@ let make_resolves env sigma flags pri c =
 (* used to add an hypothesis to the local hint database *)
 let make_resolve_hyp env sigma (hname,_,htyp) =
   try
-    [make_apply_entry env sigma (true, true, false) None
+    [make_apply_entry env sigma (true, true, false) None 
+       ~name:(PathHints [VarRef hname])
        (mkVar hname, htyp)]
   with
     | Failure _ -> []
@@ -353,26 +553,30 @@ let make_resolve_hyp env sigma (hname,_,htyp) =
 
 (* REM : in most cases hintname = id *)
 let make_unfold eref =
-  (Some (global_of_evaluable_reference eref),
+  let g = global_of_evaluable_reference eref in
+  (Some g,
    { pri = 4;
      pat = None;
+     name = PathHints [g];
      code = Unfold_nth eref })
 
 let make_extern pri pat tacast =
   let hdconstr = Option.map try_head_pattern pat in
   (hdconstr,
-   { pri=pri;
+   { pri = pri;
      pat = pat;
-     code= Extern tacast })
+     name = PathAny;
+     code = Extern tacast })
 
-let make_trivial env sigma c =
+let make_trivial env sigma ?(name=PathAny) c =
   let t = hnf_constr env sigma (type_of env sigma c) in
   let hd = head_of_constr_reference (fst (head_constr t)) in
   let ce = mk_clenv_from dummy_goal (c,t) in
   (Some hd, { pri=1;
-         pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
-         code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) })
-
+              pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
+	      name = name;
+              code=Res_pf_THEN_trivial_fail(c,t) })
+  
 open Vernacexpr
 
 (**************************************************************************)
@@ -402,23 +606,39 @@ let add_transparency dbname grs b =
       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 remove_hint dbname grs =
+  let db = get_db dbname in
+  let db' = Hint_db.remove_list grs db in
+    searchtable_add (dbname, db')
+
+type hint_action =
+  | CreateDB of bool * transparent_state
+  | AddTransparency of evaluable_global_reference list * bool
+  | AddHints of hint_entry list
+  | RemoveHints of global_reference list
+  | AddCut of hints_path
+
+let add_cut dbname path =
+  let db = get_db dbname in
+  let db' = Hint_db.add_cut path db in
+    searchtable_add (dbname, db')
+
+type hint_obj = bool * string * hint_action  (* locality, name, action *)
 
 let cache_autohint (_,(local,name,hints)) =
   match hints with
   | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
   | AddTransparency (grs, b) -> add_transparency name grs b
-  | AddTactic hints -> add_hint name hints
+  | AddHints hints -> add_hint name hints
+  | RemoveHints grs -> remove_hint name grs
+  | AddCut path -> add_cut name path
 
 let forward_subst_tactic =
   ref (fun _ -> failwith "subst_tactic is not installed for auto")
 
 let set_extern_subst_tactic f = forward_subst_tactic := f
 
-let subst_autohint (subst,(local,name,hintlist as obj)) = 
-  let trans_clenv clenv = Clenv.subst_clenv subst clenv in
+let subst_autohint (subst,(local,name,hintlist as obj)) =
   let subst_key gr =
     let (lab'', elab') = subst_global subst gr in
     let gr' =
@@ -428,90 +648,72 @@ let subst_autohint (subst,(local,name,hintlist as obj)) =
   in
   let subst_hint (k,data as hint) =
     let k' = Option.smartmap subst_key k in
-    let data' = match data.code with
-      | Res_pf (c, clenv) ->
-	  let c' = subst_mps subst c in
-	  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
-	  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')}
+    let pat' = Option.smartmap (subst_pattern subst) data.pat in
+    let code' = match data.code with
+      | Res_pf (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else Res_pf (c', t')
+      | ERes_pf (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else ERes_pf (c',t')
       | Give_exact c ->
-	  let c' = subst_mps subst c in
-	  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
-	  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')}
+          let c' = subst_mps subst c in
+          if c==c' then data.code else Give_exact c'
+      | Res_pf_THEN_trivial_fail (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t')
       | Unfold_nth ref ->
           let ref' = subst_evaluable_reference subst ref in
-	  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')}
+          if ref==ref' then data.code else Unfold_nth ref'
       | Extern tac ->
 	  let tac' = !forward_subst_tactic subst tac in
-	  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')}
+	  if tac==tac' then data.code else Extern tac'
     in
-      if k' == k && data' == data then hint else
-	(k',data')
+    let data' =
+      if data.pat==pat' && data.code==code' then data
+      else { data with pat = pat'; code = code' }
+    in
+    if k' == k && data' == data then hint else (k',data')
   in
     match hintlist with
     | CreateDB _ -> obj
     | AddTransparency (grs, b) ->
 	let grs' = list_smartmap (subst_evaluable_reference subst) grs in
 	  if grs==grs' then obj else (local, name, AddTransparency (grs', b))
-    | AddTactic hintlist ->
+    | AddHints hintlist ->
 	let hintlist' = list_smartmap subst_hint hintlist in
 	  if hintlist' == hintlist then obj else
-	    (local,name,AddTactic hintlist')
+	    (local,name,AddHints hintlist')
+    | RemoveHints grs ->
+	let grs' = list_smartmap (fun x -> fst (subst_global subst x)) grs in
+	  if grs==grs' then obj else (local, name, RemoveHints grs')
+    | AddCut path ->
+      let path' = subst_hints_path subst path in
+	if path' == path then obj else (local, name, AddCut path')
 
 let classify_autohint ((local,name,hintlist) as obj) =
-  if local or hintlist = (AddTactic []) then Dispose else Substitute obj
+  if local or hintlist = (AddHints []) then Dispose else Substitute obj
 
-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,_) =
+let inAutoHint : hint_obj -> obj =
   declare_object {(default_object "AUTOHINT") with
                     cache_function = cache_autohint;
 		    load_function = (fun _ -> cache_autohint);
 		    subst_function = subst_autohint;
-		    classify_function = classify_autohint }
-
+		    classify_function = classify_autohint; }
 
 let create_hint_db l n st b =
   Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
 
+let remove_hints local dbnames grs =
+  let dbnames = if dbnames = [] then ["core"] else dbnames in
+    List.iter
+      (fun dbname ->
+	 Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs)))
+      dbnames
+
 (**************************************************************************)
 (*                     The "Hint" vernacular command                      *)
 (**************************************************************************)
@@ -520,16 +722,21 @@ let add_resolves env sigma clist local dbnames =
     (fun dbname ->
        Lib.add_anonymous_leaf
 	 (inAutoHint
-	    (local,dbname, AddTactic
-     	      (List.flatten (List.map (fun (x, hnf, y) ->
-		make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist)))))
+	    (local,dbname, AddHints
+     	      (List.flatten (List.map (fun (x, hnf, path, y) ->
+		make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path y) clist)))))
     dbnames
 
-
 let add_unfolds l local dbnames =
   List.iter
     (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddTactic (List.map make_unfold l))))
+       (inAutoHint (local,dbname, AddHints (List.map make_unfold l))))
+    dbnames
+
+let add_cuts l local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddCut l)))
     dbnames
 
 let add_transparency l b local dbnames =
@@ -550,10 +757,10 @@ let add_extern pri pat tacast local dbname =
 	      (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])))
+	      (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast])))
     | None ->
 	Lib.add_anonymous_leaf
-	  (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast]))
+	  (inAutoHint(local,dbname, AddHints [make_extern pri None tacast]))
 
 let add_externs pri pat tacast local dbnames =
   List.iter (add_extern pri pat tacast local) dbnames
@@ -562,7 +769,8 @@ let add_trivials env sigma l local dbnames =
   List.iter
     (fun dbname ->
        Lib.add_anonymous_leaf (
-	 inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l))))
+	 inAutoHint(local,dbname, 
+		    AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l))))
     dbnames
 
 let forward_intern_tac =
@@ -571,8 +779,9 @@ let forward_intern_tac =
 let set_extern_intern_tac f = forward_intern_tac := f
 
 type hints_entry =
-  | HintsResolveEntry of (int option * bool * constr) list
-  | HintsImmediateEntry of constr list
+  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
+  | HintsImmediateEntry of (hints_path_atom * constr) list
+  | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
   | HintsExternEntry of
@@ -580,24 +789,69 @@ type hints_entry =
   | HintsDestructEntry of identifier * int * (bool,unit) location *
       (patvar list * constr_pattern) * glob_tactic_expr
 
+let h = id_of_string "H"
+
+exception Found of constr * types
+
+let prepare_hint env (sigma,c) =
+  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
+  (* We re-abstract over uninstantiated evars.
+     It is actually a bit stupid to generalize over evars since the first
+     thing make_resolves will do is to re-instantiate the products *)
+  let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in
+  let vars = ref (collect_vars c) in
+  let subst = ref [] in
+  let rec find_next_evar c = match kind_of_term c with
+    | Evar (evk,args as ev) ->
+      (* We skip the test whether args is the identity or not *)
+      let t = Evarutil.nf_evar sigma (existential_type sigma ev) in
+      let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in
+      if free_rels t <> Intset.empty then
+	error "Hints with holes dependent on a bound variable not supported.";
+      if occur_existential t then
+	(* Not clever enough to construct dependency graph of evars *)
+	error "Not clever enough to deal with evars dependent in other evars.";
+      raise (Found (c,t))
+    | _ -> iter_constr find_next_evar c in
+  let rec iter c =
+    try find_next_evar c; c
+    with Found (evar,t) ->
+      let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in
+      vars := Idset.add id !vars;
+      subst := (evar,mkVar id)::!subst;
+      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
+  iter c
+
+let path_of_constr_expr c =
+  match c with
+  | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny)
+  | _ -> PathAny
+      
 let interp_hints h =
-  let f = Constrintern.interp_constr Evd.empty (Global.env()) in
+  let f c =
+    let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in
+    let c = prepare_hint (Global.env()) (evd,c) in
+    Evarutil.check_evars (Global.env()) Evd.empty evd c;
+    c in
   let fr r =
     let gr = global_with_alias r in
     let r' = evaluable_of_global_reference (Global.env()) gr in
     Dumpglob.add_glob (loc_of_reference r) gr;
     r' in
+  let fres (o, b, c) = (o, b, path_of_constr_expr c, f c) in
+  let fi c = path_of_constr_expr c, f c in
   let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in
   match h with
-  | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints)
-  | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints)
+  | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints)
+  | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints)
   | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
   | HintsTransparency (lhints, b) ->
       HintsTransparencyEntry (List.map fr lhints, b)
   | HintsConstructors lqid ->
       let constr_hints_of_ind qid =
         let ind = global_inductive_with_alias qid in
-        list_tabulate (fun i -> None, true, mkConstruct (ind,i+1))
+        list_tabulate (fun i -> let c = (ind,i+1) in
+			 None, true, PathHints [ConstructRef c], mkConstruct c)
 	  (nconstructors ind) in
 	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
   | HintsExtern (pri, patcom, tacexp) ->
@@ -609,11 +863,14 @@ let interp_hints h =
       HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code)
 
 let add_hints local dbnames0 h =
+  if List.mem "nocore" dbnames0 then
+    error "The hint database \"nocore\" is meant to stay empty.";
   let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
   let env = Global.env() and sigma = Evd.empty in
   match h with
   | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
   | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
+  | HintsCutEntry lhints -> add_cuts lhints local dbnames
   | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
   | HintsTransparencyEntry (lhints, b) ->
       add_transparency lhints b local dbnames
@@ -639,8 +896,8 @@ let pr_autotactic =
   | Extern tac ->
       (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
 
-let pr_hint v =
-  (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
+let pr_hint (id, v) =
+  (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())
 
 let pr_hint_list hintlist =
   (str "  " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ())
@@ -655,7 +912,7 @@ 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))
+      (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db)))
       dbs
   in
   if valid_dbs = [] then
@@ -682,6 +939,7 @@ let pr_hint_term cl =
 	    else Hint_db.map_auto (hd, applist (hdc,args))
 	with Bound -> Hint_db.map_none
       in
+      let fn db = List.map (fun x -> 0, x) (fn db) in
 	map_succeed (fun (name, db) -> (name, db, fn db)) dbs
     in
       if valid_dbs = [] then
@@ -700,8 +958,12 @@ 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
-  print_hint_term (pf_concl gl)
+  let glss = Proof.V82.subgoals pts in
+  match glss.Evd.it with
+  | [] -> Util.error "No focused goal."
+  | g::_ ->
+    let gl = { Evd.it = g; sigma = glss.Evd.sigma } in
+    print_hint_term (pf_concl gl)
 
 (* displays the whole hint database db *)
 let print_hint_db db =
@@ -711,17 +973,18 @@ let print_hint_db db =
 	    else str"Non-discriminated database")));
   msgnl (hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids));
   msgnl (hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts));
+  msgnl (hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)));
   Hint_db.iter
     (fun head hintlist ->
       match head with
       | Some head ->
 	  msg (hov 0
 		  (str "For " ++ pr_global head ++ str " -> " ++
-		      pr_hint_list hintlist))
+		      pr_hint_list (List.map (fun x -> (0,x)) hintlist)))
       | None ->
 	  msg (hov 0
 		  (str "For any goal -> " ++
-		      pr_hint_list hintlist)))
+		      pr_hint_list (List.map (fun x -> (0, x)) hintlist))))
     db
 
 let print_hint_db_by_name dbname =
@@ -746,7 +1009,7 @@ let print_searchtable () =
 (*          tactics with a trace mechanism for automatic search           *)
 (**************************************************************************)
 
-let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l
+let priority l = List.filter (fun (_, hint) -> hint.pri = 0) l
 
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
@@ -755,10 +1018,18 @@ open Unification
 
 let auto_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = false;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
   modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = true;
-  use_evars_pattern_unification = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* Compat *)
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
 }
 
 (* Try unification with the precompiled clause, then use registered Apply *)
@@ -769,12 +1040,12 @@ let h_clenv_refine ev c clenv =
 
 let unify_resolve_nodelta (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in
+  let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in
   h_clenv_refine false c clenv'' gl
 
 let unify_resolve flags (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver false ~flags clenv' gl in
+  let clenv'' = clenv_unique_resolver ~flags clenv' gl in
   h_clenv_refine false c clenv'' gl
 
 let unify_resolve_gen = function
@@ -783,40 +1054,44 @@ let unify_resolve_gen = function
 
 (* Util *)
 
-let expand_constructor_hints lems =
-  list_map_append (fun lem ->
+let expand_constructor_hints env lems =
+  list_map_append (fun (sigma,lem) ->
     match kind_of_term lem with
     | Ind ind ->
 	list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind)
     | _ ->
-	[lem]) lems
+	[prepare_hint env (sigma,lem)]) lems
 
 (* builds a hint database from a constr signature *)
 (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
 
 let add_hint_lemmas eapply lems hint_db gl =
-  let lems = expand_constructor_hints lems in
+  let lems = expand_constructor_hints (pf_env gl) lems in
   let hintlist' =
     list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
   Hint_db.add_list hintlist' hint_db
 
-let make_local_hint_db eapply lems gl =
+let make_local_hint_db ?ts eapply lems gl =
   let sign = pf_hyps gl in
+  let ts = match ts with
+    | None -> Hint_db.transparent_state (searchtable_map "core") 
+    | Some ts -> ts
+  in
   let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in
   add_hint_lemmas eapply lems
-    (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl
+    (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl
 
 (* Serait-ce possible de compiler d'abord la tactique puis de faire la
-   substitution sans passer par bdize dont l'objectif est de préparer un
+   substitution sans passer par bdize dont l'objectif est de préparer un
    terme pour l'affichage ? (HH) *)
 
-(* Si on enlève le dernier argument (gl) conclPattern est calculé une
+(* Si on enlève le dernier argument (gl) conclPattern est calculé une
 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.
+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 *)
+(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
 
 let forward_interp_tactic =
   ref (fun _ -> failwith "interp_tactic is not installed for auto")
@@ -837,8 +1112,8 @@ let conclPattern concl pat tac gl =
 (**************************************************************************)
 
 (* 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 *)
+(* 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 flags_of_state st =
   {auto_unif_flags with
@@ -864,7 +1139,7 @@ let rec trivial_fail_db mod_delta db_list local_db gl =
   in
   tclFIRST
     (assumption::intro_tac::
-     (List.map tclCOMPLETE
+     (List.map (fun tac -> tclCOMPLETE tac)
        (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
 
 and my_find_search_nodelta db_list local_db hdc concl =
@@ -876,7 +1151,7 @@ and my_find_search mod_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 flags = {auto_unif_flags with use_metas_eagerly_in_conv_on_closed_terms = true} in
   let f = hintmap_of hdc concl in
     if occur_existential concl then
       list_map_append
@@ -906,20 +1181,23 @@ and my_find_search_delta db_list local_db hdc concl =
 	  in List.map (fun x -> (Some flags,x)) l)
       	(local_db::db_list)
 
-and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) =
-  match t with
-  | 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) ->
+and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) =
+  let tactic = 
+    match t with
+    | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl)
+    | ERes_pf _ -> (fun gl -> error "eres_pf")
+    | Give_exact c  -> exact_check c
+    | Res_pf_THEN_trivial_fail (c,cl) ->
       tclTHEN
-        (unify_resolve_gen flags (term,cl))
+        (unify_resolve_gen flags (c,cl))
         (trivial_fail_db (flags <> None) db_list local_db)
-  | 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
+    | 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
+  in tactic
 
 and trivial_resolve mod_delta db_list local_db cl =
   try
@@ -933,21 +1211,25 @@ and trivial_resolve mod_delta db_list local_db cl =
 	    (my_find_search mod_delta db_list local_db head cl))
   with Not_found -> []
 
-let trivial lems dbnames gl =
-  let db_list =
-    List.map
-      (fun x ->
-	 try
-	   searchtable_map x
-	 with Not_found ->
-	   error_no_such_hint_database x)
-      ("core"::dbnames)
+(** The use of the "core" database can be de-activated by passing
+    "nocore" amongst the databases. *)
+
+let make_db_list dbnames =
+  let use_core = not (List.mem "nocore" dbnames) in
+  let dbnames = list_remove "nocore" dbnames in
+  let dbnames = if use_core then "core"::dbnames else dbnames in
+  let lookup db =
+    try searchtable_map db with Not_found -> error_no_such_hint_database db
   in
+  List.map lookup dbnames
+
+let trivial lems dbnames gl =
+  let db_list = make_db_list dbnames in
   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
+  let dbnames = list_remove "v62" dbnames in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
   tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
 
@@ -955,10 +1237,8 @@ let gen_trivial lems = function
   | None -> full_trivial lems
   | Some l -> trivial lems l
 
-let inj_open c = (Evd.empty,c)
-
 let h_trivial lems l =
-  Refiner.abstract_tactic (TacTrivial (lems,l))
+  Refiner.abstract_tactic (TacTrivial (List.map snd lems,l))
     (gen_trivial lems l)
 
 (**************************************************************************)
@@ -1051,15 +1331,7 @@ let search = search_gen 0
 let default_search_depth = ref 5
 
 let delta_auto mod_delta n lems dbnames gl =
-  let db_list =
-    List.map
-      (fun x ->
-	 try
-	   searchtable_map x
-	 with Not_found ->
-	   error_no_such_hint_database x)
-      ("core"::dbnames)
-  in
+  let db_list = make_db_list dbnames in
   tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
 let auto = delta_auto false
@@ -1070,7 +1342,7 @@ let default_auto = auto !default_search_depth [] []
 
 let delta_full_auto mod_delta n lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_subtract dbnames ["v62"] in
+  let dbnames = list_remove "v62" dbnames in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
   tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
@@ -1088,7 +1360,7 @@ 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,lems,l))
+  Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l))
     (gen_auto n lems l)
 
 (**************************************************************************)
@@ -1117,7 +1389,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,lems))
+  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems))
     (dauto (n,p) lems)
 
 (***************************************)
diff --git a/tactics/auto.mli b/tactics/auto.mli
index eef6a0ee..521c5ed2 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -22,31 +19,52 @@ open Evd
 open Libnames
 open Vernacexpr
 open Mod_subst
-(*i*)
 
-type auto_tactic =
-  | Res_pf     of constr * clausenv    (* Hint Apply *)
-  | ERes_pf    of constr * clausenv    (* Hint EApply *)
+(** Auto and related automation tactics *)
+
+type 'a auto_tactic =
+  | Res_pf     of constr * 'a    (** Hint Apply *)
+  | ERes_pf    of constr * 'a    (** Hint EApply *)
   | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference          (* Hint Unfold *)
-  | Extern     of Tacexpr.glob_tactic_expr   (* Hint Extern *)
+  | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference          (** Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr   (** Hint Extern *)
 
-open Rawterm
+open Glob_term
 
-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 hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type 'a gen_auto_tactic = {
+  pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
+  pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (** A potential name to refer to the hint *) 
+  code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
 }
 
-type stored_data = pri_auto_tactic
+type pri_auto_tactic = clausenv gen_auto_tactic
+
+type stored_data = int * clausenv gen_auto_tactic
 
 type search_entry
 
-(* The head may not be bound. *)
+(** The head may not be bound. *)
 
-type hint_entry = global_reference option * pri_auto_tactic
+type hint_entry = global_reference option * types gen_auto_tactic
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+val normalize_path : hints_path -> hints_path
+val path_matches : hints_path -> hints_path_atom list -> bool
+val path_derivate : hints_path -> hints_path_atom -> hints_path
+val pp_hints_path : hints_path -> Pp.std_ppcmds
 
 module Hint_db :
   sig
@@ -58,12 +76,17 @@ module Hint_db :
     val map_auto : global_reference * constr -> t -> pri_auto_tactic list
     val add_one : hint_entry -> t -> t
     val add_list : (hint_entry) list -> t -> t
-    val iter : (global_reference option -> stored_data list -> unit) -> t -> unit
+    val remove_one : global_reference -> t -> t
+    val remove_list : global_reference list -> t -> t
+    val iter : (global_reference option -> pri_auto_tactic list -> unit) -> t -> unit
 
     val use_dn : t -> bool
     val transparent_state : t -> transparent_state
     val set_transparent_state : t -> transparent_state -> t
 
+    val add_cut : hints_path -> t -> t
+    val cut : t -> hints_path
+
     val unfolds : t -> Idset.t * Cset.t
   end
 
@@ -72,8 +95,9 @@ 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
+  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
+  | HintsImmediateEntry of (hints_path_atom * constr) list
+  | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
   | HintsExternEntry of
@@ -85,19 +109,23 @@ 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
    and patterns. *)
 
 val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
 
+val remove_hints : bool -> hint_db_name list -> global_reference list -> unit
+
 val current_db_names : unit -> hint_db_name list
 
 val interp_hints : hints_expr -> hints_entry
 
 val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
 
+val prepare_hint : env -> open_constr -> constr
+
 val print_searchtable : unit -> unit
 
 val print_applicable_hint : unit -> unit
@@ -108,13 +136,13 @@ val print_hint_db_by_name : hint_db_name -> unit
 
 val print_hint_db : Hint_db.t -> unit
 
-(* [make_exact_entry pri (c, ctyp)].
+(** [make_exact_entry pri (c, ctyp)].
    [c] is the term given as an exact proof to solve the goal;
    [ctyp] is the type of [c]. *)
 
-val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry
+val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry
 
-(* [make_apply_entry (eapply,verbose) pri (c,cty)].
+(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
    [eapply] is true if this hint will be used only with EApply;
    [hnf] should be true if we should expand the head of cty before searching for
    products;
@@ -122,21 +150,21 @@ val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry
    [cty] is the type of [c]. *)
 
 val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> constr * constr
-      -> hint_entry
+  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
+  constr * constr -> hint_entry
 
-(* A constr which is Hint'ed will be:
-   (1) used as an Exact, if it does not start with a product
-   (2) used as an Apply, if its HNF starts with a product, and
-       has no missing arguments.
-   (3) used as an EApply, if its HNF starts with a product, and
-       has missing arguments. *)
+(** A constr which is Hint'ed will be:
+   - (1) used as an Exact, if it does not start with a product
+   - (2) used as an Apply, if its HNF starts with a product, and
+         has no missing arguments.
+   - (3) used as an EApply, if its HNF starts with a product, and
+         has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> constr ->
-      hint_entry list
+  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
+  constr -> hint_entry list
 
-(* [make_resolve_hyp hname htyp].
+(** [make_resolve_hyp hname htyp].
    used to add an hypothesis to the local hint database;
    Never raises a user exception;
    If the hyp cannot be used as a Hint, the empty list is returned. *)
@@ -144,7 +172,7 @@ val make_resolves :
 val make_resolve_hyp :
   env -> evar_map -> named_declaration -> hint_entry list
 
-(* [make_extern pri pattern tactic_expr] *)
+(** [make_extern pri pattern tactic_expr] *)
 
 val make_extern :
   int -> constr_pattern option -> Tacexpr.glob_tactic_expr
@@ -161,11 +189,11 @@ val set_extern_subst_tactic :
   (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
   -> unit
 
-(* Create a Hint database from the pairs (name, constr).
+(** Create a Hint database from the pairs (name, constr).
    Useful to take the current goal hypotheses as hints;
    Boolean tells if lemmas with evars are allowed *)
 
-val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db
+val make_local_hint_db : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db
 
 val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list
 
@@ -173,63 +201,69 @@ val default_search_depth : int ref
 
 val auto_unif_flags : Unification.unify_flags
 
-(* Try unification with the precompiled clause, then use registered Apply *)
+(** Try unification with the precompiled clause, then use registered Apply *)
 val unify_resolve_nodelta : (constr * clausenv) -> tactic
 
 val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
 
-(* [ConclPattern concl pat tacast]:
+(** [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of
    [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
    right values to build a tactic *)
 
 val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic
 
-(* The Auto tactic *)
+(** The Auto tactic *)
 
-val auto : int -> constr list -> hint_db_name list -> tactic
+(** The use of the "core" database can be de-activated by passing
+    "nocore" amongst the databases. *)
 
-(* Auto with more delta. *)
+val make_db_list : hint_db_name list -> hint_db list
 
-val new_auto : int -> constr list -> hint_db_name list -> tactic
+val auto : int -> open_constr list -> hint_db_name list -> tactic
 
-(* auto with default search depth and with the hint database "core" *)
+(** Auto with more delta. *)
+
+val new_auto : int -> open_constr list -> hint_db_name list -> tactic
+
+(** auto with default search depth and with the hint database "core" *)
 val default_auto : tactic
 
-(* auto with all hint databases except the "v62" compatibility database *)
-val full_auto : int -> constr list -> tactic
+(** auto with all hint databases except the "v62" compatibility database *)
+val full_auto : int -> open_constr list -> tactic
 
-(* auto with all hint databases except the "v62" compatibility database
+(** auto with all hint databases except the "v62" compatibility database
    and doing delta *)
-val new_full_auto : int -> constr list -> tactic
+val new_full_auto : int -> open_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
 
-(* The generic form of auto (second arg [None] means all bases) *)
-val gen_auto : int option -> constr list -> hint_db_name list option -> tactic
+(** The generic form of auto (second arg [None] means all bases) *)
+val gen_auto : int option -> open_constr list -> hint_db_name list option -> tactic
 
-(* The hidden version of auto *)
-val h_auto   : int option -> constr list -> hint_db_name list option -> tactic
+(** The hidden version of auto *)
+val h_auto   : int option -> open_constr list -> hint_db_name list option -> tactic
 
-(* Trivial *)
-val trivial : constr list -> hint_db_name list -> tactic
-val gen_trivial : constr list -> hint_db_name list option -> tactic
-val full_trivial : constr list -> tactic
-val h_trivial : constr list -> hint_db_name list option -> tactic
+(** Trivial *)
+val trivial : open_constr list -> hint_db_name list -> tactic
+val gen_trivial : open_constr list -> hint_db_name list option -> tactic
+val full_trivial : open_constr list -> tactic
+val h_trivial : open_constr list -> hint_db_name list option -> tactic
 
-val pr_autotactic : auto_tactic -> Pp.std_ppcmds
+val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
 
-(*s The following is not yet up to date -- Papageno. *)
+(** {6 The following is not yet up to date -- Papageno. } *)
 
-(* DAuto *)
-val dauto : int option * int option -> constr list -> tactic
+(** DAuto *)
+val dauto : int option * int option -> open_constr list -> tactic
 val default_search_decomp : int ref
 val default_dauto : tactic
 
-val h_dauto : int option * int option -> constr list -> tactic
-(* SuperAuto *)
+val h_dauto : int option * int option -> open_constr list -> tactic
+
+(** SuperAuto *)
 
 type autoArguments =
   | UsingTDB
@@ -241,4 +275,4 @@ val superauto : int -> (identifier * constr) list -> autoArguments list -> tacti
 
 val h_superauto : int option -> reference list -> bool -> bool -> tactic
 
-val auto_init : (unit -> unit) ref
+val add_auto_init : (unit -> unit) -> unit
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 2a41a8e5..a974c76a 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: autorewrite.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Equality
 open Hipattern
 open Names
@@ -19,7 +17,7 @@ open Tactics
 open Term
 open Termops
 open Util
-open Rawterm
+open Glob_term
 open Vernacinterp
 open Tacexpr
 open Mod_subst
@@ -36,7 +34,7 @@ let subst_hint subst hint =
   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
+    if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else
       { hint with
 	rew_lemma = cst'; rew_type = typ';
 	rew_pat = pat';	rew_tac = t' }
@@ -119,7 +117,7 @@ let autorewrite ?(conds=Naive) tac_main lbas =
        tclTHEN tac
         (one_base (fun dir c tac ->
 	  let tac = tac, conds in
-	    general_rewrite dir all_occurrences false ~tac c)
+	    general_rewrite dir all_occurrences true false ~tac c)
 	  tac_main bas))
       tclIDTAC lbas))
 
@@ -132,16 +130,16 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
   let to_be_cleared = ref false in
    fun dir cstr tac gl ->
     let last_hyp_id =
-     match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with
+     match Tacmach.pf_hyps gl with
         (last_hyp_id,_,_)::_ -> last_hyp_id
       | _ -> (* even the hypothesis id is missing *)
              error ("No such hypothesis: " ^ (string_of_id !id) ^".")
     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
+    let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in
+    let gls = gl'.Evd.it in
     match gls with
        g::_ ->
-        (match Environ.named_context_of_val g.Evd.evar_hyps with
+        (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with
             (lastid,_,_)::_ ->
               if last_hyp_id <> lastid then
                begin
@@ -225,7 +223,7 @@ let classify_hintrewrite x = Libobject.Substitute x
 
 
 (* Declaration of the Hint Rewrite library object *)
-let (inHintRewrite,_)=
+let inHintRewrite : string * HintDN.t -> Libobject.obj =
   Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
     Libobject.cache_function = cache_hintrewrite;
     Libobject.load_function = (fun _ -> cache_hintrewrite);
@@ -248,7 +246,7 @@ type hypinfo = {
 
 let evd_convertible env evd x y =
   try
-    ignore(Unification.w_unify true env Reduction.CONV x y evd); true 
+    ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true 
   (* try ignore(Evarconv.the_conv_x env x y evd); true *)
   with _ -> false
 
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index ec285500..3205b041 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -1,34 +1,30 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: autorewrite.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Tacexpr
 open Tacmach
 open Equality
-(*i*)
 
-(* Rewriting rules before tactic interpretation *)
+(** Rewriting rules before tactic interpretation *)
 type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr
 
-(* To add rewriting rules to a base *)
+(** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
 
-(* The AutoRewrite 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 *)
+(** Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 119d8398..c13136b9 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: btermdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Names
 open Termdn
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index 22d3c3a2..55826df5 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: btermdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Names
-(*i*)
 
-(* Discrimination nets with bounded depth. *)
+(** Discrimination nets with bounded depth. *)
 module Make :
   functor (Z : Map.OrderedType) ->
 sig
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index 465d1d80..42df244d 100644
--- a/tactics/class_tactics.ml4
+++ b/tactics/class_tactics.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: class_tactics.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -19,7 +17,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -28,7 +25,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 open Typeclasses
 open Typeclasses_errors
@@ -38,77 +35,57 @@ open Pfedit
 open Command
 open Libnames
 open Evd
+open Compat
 
-let default_eauto_depth = 100
 let typeclasses_db = "typeclass_instances"
+let typeclasses_debug = ref false
+let typeclasses_depth = ref None
 
-let _ = Auto.auto_init := (fun () ->
-  Auto.create_hint_db false typeclasses_db full_transparent_state true)
+let _ = 
+  Auto.add_auto_init 
+    (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true)
 
 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' }
+(** We transform the evars that are concerned by this resolution
+    (according to predicate p) into goals.
+    Invariant: function p only manipulates undefined evars *)
 
 let evars_to_goals p evm =
   let goals, evm' =
-    Evd.fold
+    Evd.fold_undefined
       (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)
+	let evi', goal = p evm ev evi in
+	let gls' = if goal then (ev,Goal.V82.build ev) :: gls else gls in
+	(gls', Evd.add evm' ev evi'))
+      evm ([], Evd.defined_evars evm)
   in
-    if goals = [] then None
-    else
-      let goals = List.rev goals in
-      let evm' = evars_reset_evd ~with_conv_pbs:false evm' evm in
-	Some (goals, evm')
+  if goals = [] then None else Some (List.rev goals, evm')
 
 (** Typeclasses instance search tactic / eauto *)
 
-let intersects s t =
-  Intset.exists (fun el -> Intset.mem el t) s
-
 open Auto
 
 let e_give_exact flags c gl = 
   let t1 = (pf_type_of gl c) in
     tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
 
-let assumption flags id = e_give_exact flags (mkVar id)
-
 open Unification
 
 let auto_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
   modulo_delta = var_full_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = false;
-  use_evars_pattern_unification = true;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = true;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
 }
 
 let rec eq_constr_mod_evars x y =
@@ -126,18 +103,18 @@ let progress_evars t gl =
   in tclTHEN t check gl
 
 TACTIC EXTEND progress_evars
-  [ "progress_evars" tactic(t) ] -> [ progress_evars (snd t) ]
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ]
 END
 
 let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
-    tclPROGRESS (Clenvtac.clenv_refine true ~with_classes:false clenv') gls
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    Clenvtac.clenv_refine true ~with_classes:false clenv' gls
 
 let unify_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
-    tclPROGRESS (Clenvtac.clenv_refine false ~with_classes:false clenv') gls
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    Clenvtac.clenv_refine false ~with_classes:false clenv' gls
 
 let clenv_of_prods nprods (c, clenv) gls =
   if nprods = 0 then Some clenv
@@ -157,7 +134,9 @@ let with_prods nprods (c, clenv) f gls =
 
 let flags_of_state st =
   {auto_unif_flags with
-    modulo_conv_on_closed_terms = Some st; modulo_delta = st}
+    modulo_conv_on_closed_terms = Some st; modulo_delta = st; 
+     modulo_delta_types = st;
+     modulo_eta = false}
 
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl =
@@ -168,11 +147,11 @@ let rec e_trivial_fail_db db_list local_db goal =
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
           (e_trivial_fail_db db_list
 	      (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map (fun (x,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal)))
+    (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 complete concl =
   let hdc = head_of_constr_reference hdc in
   let prods, concl = decompose_prod_assum concl in
   let nprods = List.length prods in
@@ -188,7 +167,7 @@ and e_my_find_search db_list local_db hdc concl =
       (local_db::db_list)
   in
   let tac_of_hint =
-    fun (flags, {pri=b; pat = p; code=t}) ->
+    fun (flags, {pri = b; pat = p; code = t; name = name}) ->
       let tac =
 	match t with
 	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags)
@@ -196,66 +175,55 @@ and e_my_find_search db_list local_db hdc concl =
 	  | Give_exact (c) -> e_give_exact flags c
 	  | Res_pf_THEN_trivial_fail (term,cl) ->
               tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
-		(e_trivial_fail_db db_list local_db)
+	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
 	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c])
-	  | Extern tacast -> conclPattern concl p tacast
+	  | Extern tacast -> 
+(* 	    tclTHEN *)
+(* 	      (fun gl -> Refiner.tclEVARS (mark_unresolvables (project gl)) gl) *)
+	      (conclPattern concl p tacast)
       in
+      let tac = if complete then tclCOMPLETE tac else tac in
 	match t with
-	| Extern _ -> (tac,b,true,lazy (pr_autotactic t))
-	| _ -> (tac,b,false,lazy (pr_autotactic t))
+	| Extern _ -> (tac,b,true, name, lazy (pr_autotactic t))
+	| _ -> 
+(* 	  let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *)
+	    (tac,b,false, name, lazy (pr_autotactic t))
   in List.map tac_of_hint hintl
 
 and e_trivial_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) gl
+    (fst (head_constr_bound gl)) true gl
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) gl
+      (fst (head_constr_bound gl)) false gl
   with Bound | Not_found -> []
 
 let rec catchable = function
   | Refiner.FailError _ -> true
-  | Stdpp.Exc_located (_, e) -> catchable e
+  | Loc.Exc_located (_, e) -> catchable e
   | e -> Logic.catchable_exception e
 
-let is_dep gl gls =
-  let evs = Evarutil.evars_of_term gl.evar_concl in
-    if evs = Intset.empty then false
-    else
-      List.fold_left
-	(fun b gl ->
-	  if b then b
-	  else
-	    let evs' = Evarutil.evars_of_term gl.evar_concl in
-	      intersects evs evs')
-	false gls
-
-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
+  Evd.fold_undefined (fun ev evi acc -> succ 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
+let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
 
 let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l)
 
 type autoinfo = { hints : Auto.hint_db; is_evar: existential_key option;
-		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t}
+		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t;
+		  auto_path : global_reference option list;
+		  auto_cut : hints_path }
 type autogoal = goal * autoinfo
 type 'ans fk = unit -> 'ans
 type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
 type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
 
-type auto_result = autogoal list sigma * validation
+type auto_result = autogoal list sigma
 
 type atac = auto_result tac
 
@@ -272,26 +240,67 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
 	       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 -> try f (c,cty) with UserError _ -> failwith "") 
-	[make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
+  let is_class = iscl env cty in
+  let keep = not only_classes || is_class in
+    if keep then 
+      let c = mkVar id in
+      let name = PathHints [VarRef id] in
+      let hints =
+	if is_class then
+	  let hints = build_subclasses ~check:false env sigma (VarRef id) None in
+	    (list_map_append
+	       (fun (pri, c) -> make_resolves env sigma 
+		  (true,false,Flags.is_verbose()) pri c) 
+	       hints)
+	else []
+      in
+        (hints @ map_succeed 
+	 (fun f -> try f (c,cty) with UserError _ -> failwith "") 
+	 [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri])
     else []
 
 let pf_filtered_hyps gls = 
-  evar_filtered_context (sig_it gls)
+  Goal.V82.hyps gls.Evd.sigma (sig_it gls)
+
+let make_hints g st only_classes sign =
+  let paths, hintlist = 
+    List.fold_left 
+    (fun (paths, hints) hyp ->
+     if is_section_variable (pi1 hyp) then (paths, hints)
+     else
+       let path, hint = 		    
+	 PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp
+       in
+	 (PathOr (paths, path), hint @ hints))
+    (PathEmpty, []) sign
+  in Hint_db.add_list hintlist (Hint_db.empty st true)
+
+let autogoal_hints_cache : (Environ.named_context_val * hint_db) option ref = ref None
+let freeze () = !autogoal_hints_cache
+let unfreeze v = autogoal_hints_cache := v
+let init () = autogoal_hints_cache := None
+
+let _ = init ()
 
-let 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 _ =
+  Summary.declare_summary "autogoal-hints-cache"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init }
+    
+let make_autogoal_hints = 
+  fun only_classes ?(st=full_transparent_state) g ->
+    let sign = pf_filtered_hyps g in
+      match freeze () with
+      | Some (sign', hints) when Environ.eq_named_context_val sign sign' -> hints
+      | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
+	  unfreeze (Some (sign, hints)); hints
+	  
 let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
   { skft = fun sk fk {it = gl,hints; sigma=s} ->
     let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in
       match res with
-      | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk
+      | Some gls -> sk (f gls hints) fk
       | None -> fk () }
 
 let intro_tac : atac =
@@ -299,28 +308,22 @@ let intro_tac : atac =
     (fun {it = gls; sigma = s} info ->
       let gls' =
 	List.map (fun g' ->
-	  let env = evar_env g' in
+	  let env = Goal.V82.env s g' in
+	  let context = Environ.named_context_of_val (Goal.V82.hyps s g') in
 	  let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) 
-	    (true,false,false) info.only_classes None (List.hd (evar_context g')) in
+	    (true,false,false) info.only_classes None (List.hd context) in
 	  let ldb = Hint_db.add_list hint info.hints in
 	    (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls
       in {it = gls'; sigma = s})
 
 let normevars_tac : atac = 
-  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 }
+  { skft = fun sk fk {it = (gl, info); sigma = s} ->
+    let gl', sigma' = Goal.V82.nf_evar s gl in
+    let info' = { info with auto_last_tac = lazy (str"normevars") } in
+      sk {it = [gl', info']; sigma = sigma'} fk }
 
 (* Ordering of states is lexicographic on the number of remaining goals. *)
-let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) =
+let compare (pri, _, _, res) (pri', _, _, res') =
   let nbgoals s =
     List.length (sig_it s) + nb_empty_evars (sig_sig s)
   in
@@ -331,131 +334,104 @@ let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) =
 let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
   { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
 
-let 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 solve_unif_tac : atac =
-  { skft = fun sk fk {it = gl; sigma = s} -> 
-    try let s' = Evarconv.consider_remaining_unif_problems (Global.env ()) s in
-	  normevars_tac.skft sk fk ({it=gl; sigma=s'})
-    with _ -> fk () }
-
 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 concl = Goal.V82.concl s gl in
+      let tacgl = {it = gl; sigma = s} in
       let poss = e_possible_resolve hints info.hints concl in
-      let 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)
+      let rec aux i foundone = function
+	| (tac, _, b, name, pp) :: tl ->
+	  let derivs = path_derivate info.auto_cut name in
+	  let res = 
+            try
+		if path_matches derivs [] then None else Some (tac tacgl)
+	    with e when catchable e -> None 
 	  in
-	  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
-
-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) 
+	    (match res with
+	       | None -> aux i foundone tl
+	       | Some {it = gls; sigma = s'} ->
+	    	   if !typeclasses_debug then
+		     msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
+			    ++ str" on" ++ spc () ++ pr_ev s gl);
+		   let fk =
+		     (fun () -> if !typeclasses_debug then msgnl (str"backtracked after " ++ Lazy.force pp);
+			aux (succ i) true tl)
+		   in
+		   let sgls =
+		     evars_to_goals
+		       (fun evm ev evi ->
+			  if Typeclasses.is_resolvable evi &&
+			    (not info.only_classes || Typeclasses.is_class_evar evm evi)
+			  then Typeclasses.mark_unresolvable evi, true
+			  else evi, false) s'
+		   in
+		   let newgls, s' =
+		     let gls' = List.map (fun g -> (None, g)) gls in
+		       match sgls with
+		       | None -> gls', s'
+		       | Some (evgls, s') ->
+			 (* Reorder with dependent subgoals. *)
+			 (gls' @ List.map (fun (ev, x) -> Some ev, x) evgls, s')
+		   in
+		   let gls' = list_map_i
+		     (fun j (evar, g) ->
+			let info =
+			  { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
+			      is_evar = evar;
+			      hints =
+			      if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) (Goal.V82.hyps s' gl))
+			      then make_autogoal_hints info.only_classes
+				~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'}
+			      else info.hints;
+			      auto_cut = derivs }
+			in g, info) 1 newgls in
+		   let glsv = {it = gls'; sigma = s'} in
+		     sk glsv fk)
+	| [] ->
+	  if not foundone && !typeclasses_debug then
+	    msgnl (pr_depth info.auto_depth ++ str": no match for " ++
+		     Printer.pr_constr_env (Goal.V82.env s gl) concl ++
+		     spc () ++ int (List.length poss) ++ str" possibilities");
+	  fk ()
+    in aux 1 false poss }
+
+let isProp env sigma concl = 
+  let ty = Retyping.get_type_of env sigma concl in
+    kind_of_term ty = Sort (Prop Null)
+
+let needs_backtrack only_classes env evd oev concl =
+  if oev = None || isProp env evd concl then
+    not (Intset.is_empty (Evarutil.evars_of_term concl))
+  else true
 
 let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
-  let rec aux s (acc : (autogoal list * validation) list) fk = function
+  let rec aux s (acc : autogoal list 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}
+	(match info.is_evar with 
+	 | Some ev when Evd.is_defined s ev -> aux s acc fk gls
+	 | _ -> 
+	     second.skft
+	       (fun {it=gls';sigma=s'} fk' ->
+		  let needs_backtrack = 
+		    if gls' = [] then
+ 		      needs_backtrack info.only_classes
+		        (Goal.V82.env s gl) s' info.is_evar (Goal.V82.concl s gl)
+		    else true
+		  in
+		  let fk'' = 
+		    if not needs_backtrack then
+		      (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl ++ 
+							 str " after " ++ Lazy.force info.auto_last_tac); fk) 
+		    else fk' 
+		  in aux s' (gls'::acc) fk'' gls)
+	       fk {it = (gl,info); sigma = s})
     | [] -> Some (List.rev acc, s, fk)
-  in fun ({it = gls; sigma = s},v) fk ->
+  in fun {it = gls; sigma = s} 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' ()))
+	  let goals' = List.concat res in
+	    sk {it = goals'; sigma = s'} (fun () -> aux' (fk' ()))
     in aux' (aux s [] (fun () -> None) gls)
 
 let then_tac (first : atac) (second : atac) : atac =
@@ -468,52 +444,68 @@ 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)
+    gl
     (fun _ -> None)
 
+let fail_tac : atac = 
+  { skft = fun sk fk _ -> fk () }
+
 let rec fix (t : 'a tac) : 'a tac =
   then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
 
-let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) ev g =
+let rec fix_limit limit (t : 'a tac) : 'a tac =
+  if limit = 0 then fail_tac 
+  else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
+    
+let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) cut ev g =
   let hints = make_autogoal_hints only_classes ~st g in
     (g.it, { hints = hints ; is_evar = ev; 
-	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (mt()) })
+	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none");
+	     auto_path = []; auto_cut = cut })
       
-let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' =
+
+let cut_of_hints h =
+  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
+
+let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) hints gs evm' =
+  let cut = cut_of_hints hints in
   { it = list_map_i (fun i g -> 
-    let (gl, auto) = make_autogoal ~only_classes ~st (Some (fst g)) {it = snd g; sigma = evm'} in
+    let (gl, auto) = make_autogoal ~only_classes ~st cut (Some (fst g)) {it = snd g; sigma = evm'} in
       (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' }
 
 let get_result r = 
   match r with
   | None -> None
-  | Some ((gls, 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 =
+  | Some (gls, fk) -> Some (gls.sigma,fk)
+	
+let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints tac =
   match evars_to_goals p evm with
   | None -> None (* This happens only because there's no evar having p *)
   | Some (goals, evm') ->
-      let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in
+      let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in
 	match get_result res with
 	| None -> raise Not_found
-	| Some (evm', fk) -> Some (evars_reset_evd evm' evm, fk)
+	| Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true 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
+  then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
+
+let eauto_tac ?limit hints = 
+  match limit with
+  | None -> fix (eauto_tac hints)
+  | Some limit -> fix_limit limit (eauto_tac hints)
+      
+let eauto ?(only_classes=true) ?st ?limit hints g =
+  let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g } in
+    match run_tac (eauto_tac ?limit hints) gl with
     | None -> raise Not_found
-    | Some ({it = goals; sigma = s}, valid) ->
-	{it = List.map fst goals; sigma = s}, valid s
+    | Some {it = goals; sigma = s} ->
+	{it = List.map fst goals; sigma = s}
 
-let real_eauto st hints p evd =
+let real_eauto st ?limit hints p evd =
   let rec aux evd fails =
     let res, fails =
-      try run_on_evars ~st p evd (eauto_tac hints), fails
+      try run_on_evars ~st p evd hints (eauto_tac ?limit hints), fails
       with Not_found ->
 	List.fold_right (fun fk (res, fails) ->
 	  match res with
@@ -526,162 +518,209 @@ let real_eauto st hints p evd =
       | Some (evd', fk) -> aux evd' (fk :: fails)
   in aux evd []
 
-let resolve_all_evars_once debug (mode, depth) p evd =
+let resolve_all_evars_once debug limit p evd =
   let db = searchtable_map typeclasses_db in
-    real_eauto (Hint_db.transparent_state db) [db] p evd
+    real_eauto ?limit (Hint_db.transparent_state db) [db] p evd
+
+(** We compute dependencies via a union-find algorithm.
+    Beware of the imperative effects on the partition structure,
+    it should not be shared, but only used locally. *)
+
+module Intpart = Unionfind.Make(Intset)(Intmap)
 
-exception FoundTerm of constr
+let deps_of_constraints cstrs evm p =
+  List.iter (fun (_, _, x, y) ->
+    let evx = Evarutil.undefined_evars_of_term evm x in
+    let evy = Evarutil.undefined_evars_of_term evm y in
+    Intpart.union_set (Intset.union evx evy) p)
+    cstrs
+
+let evar_dependencies evm p =
+  Evd.fold_undefined
+    (fun ev evi _ ->
+      let evars = Intset.add ev (Evarutil.undefined_evars_of_evar_info evm evi)
+      in Intpart.union_set evars p)
+    evm ()
 
 let resolve_one_typeclass env ?(sigma=Evd.empty) gl =
-  let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in
+  let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env gl in
+  let (gl,t,sigma) = 
+    Goal.V82.mk_goal sigma nc gl Store.empty in
+  let gls = { it = gl ; sigma = sigma } in
   let hints = searchtable_map typeclasses_db in
-  let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in
-  let term = v [] in
+  let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls 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
+  let t' = let (ev, inst) = destEvar t in
+    mkEvar (ev, Array.of_list subst)
+  in
+  let term = Evarutil.nf_evar evd t' in
     evd, term
 
 let _ =
   Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z)
 
-let has_undefined p oevd evd =
-  Evd.fold (fun ev evi has -> has ||
-    (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
-	merge_deps (Intset.union deps hd) tl
-      else hd :: merge_deps deps tl
-
-let evars_of_evi evi =
-  Intset.union (evars_of_term evi.evar_concl)
-    (Intset.union
-	(match evi.evar_body with
-	| Evar_empty -> Intset.empty
-	| Evar_defined b -> evars_of_term b)
-	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
-
-let deps_of_constraints cstrs deps =
-  List.fold_right (fun (_, _, x, y) deps -> 
-    let evs = Intset.union (evars_of_term x) (evars_of_term y) in
-      merge_deps evs deps)
-    cstrs deps
-      
-let evar_dependencies evm =
-  Evd.fold 
-    (fun ev evi acc ->
-      merge_deps (Intset.union (Intset.singleton ev) 
-		     (evars_of_evi evi)) acc)
-    evm []
+(** [split_evars] returns groups of undefined evars according to dependencies *)
 
 let split_evars evm =
-  let _, cstrs = extract_all_conv_pbs evm in
-  let evmdeps = evar_dependencies evm in
-  let deps = deps_of_constraints cstrs evmdeps in
-    List.sort Intset.compare deps
+  let p = Intpart.create () in
+  evar_dependencies evm p;
+  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+  Intpart.partition p
+
+(** [evars_in_comp] filters an [evar_map], keeping only evars
+    that belongs to a certain component *)
 
-let select_evars evs evm =
-  Evd.fold (fun ev evi acc ->
-    if Intset.mem ev evs then Evd.add acc ev evi else acc)
-    evm Evd.empty
+let evars_in_comp comp evm =
+  try
+    evars_reset_evd 
+      (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev))
+	 comp Evd.empty) evm
+  with Not_found -> assert false
 
-let is_inference_forced p ev evd =
+let is_inference_forced p evd ev =
   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 evi = Evd.find_undefined evd ev in
+    if Typeclasses.is_resolvable evi && snd (p ev evi)
+    then
+      let (loc, k) = evar_source ev evd in
+      match k with
+	| ImplicitArg (_, _, b) -> b
+	| QuestionMark _ -> false
+	| _ -> true
+    else true
+  with Not_found -> assert false
+
+let is_mandatory p comp evd =
+  Intset.exists (is_inference_forced p evd) comp
+
+(** In case of unsatisfiable constraints, build a nice error message *)
+
+let error_unresolvable env comp do_split evd =
+  let evd = Evarutil.nf_evar_map_undefined evd in
+  let evm = if do_split then evars_in_comp comp evd else evd in
+  let _, ev = Evd.fold_undefined
+    (fun ev evi (b,acc) ->
+      (* focus on one instance if only one was searched for *)
+      if class_of_constr evi.evar_concl <> None then
+	if not b (* || do_split *) then
+	  true, Some ev
+	else b, None
+      else b, acc) evm (false, None)
+  in
+  Typeclasses_errors.unsatisfiable_constraints
+    (Evarutil.nf_env_evar evm env) evm ev
+
+(** Check if an evar is concerned by the current resolution attempt,
+    (and in particular is in the current component), and also update
+    its evar_info.
+    Invariant : this should only be applied to undefined evars,
+    and return undefined evar_info *)
+
+let select_and_update_evars p oevd in_comp evd ev evi =
+  assert (evi.evar_body = Evar_empty);
+  try
+    let oevi = Evd.find_undefined oevd ev in
+    if Typeclasses.is_resolvable oevi then
+      Typeclasses.mark_unresolvable evi,
+      (in_comp ev && p evd ev evi)
+    else evi, false
+  with Not_found ->
+    Typeclasses.mark_unresolvable evi, p evd ev evi
+
+(** Do we still have unresolved evars that should be resolved ? *)
+
+let has_undefined p oevd evd =
+  Evd.fold_undefined (fun ev evi has -> has ||
+    snd (p oevd ev evi))
+    evd false
+
+(** If [do_split] is [true], we try to separate the problem in
+    several components and then solve them separately *)
+
+exception Unresolved
 
 let resolve_all_evars debug m env p oevd do_split fail =
   let split = if do_split then split_evars oevd else [Intset.empty] in
-  let 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'
+  let in_comp comp ev = if do_split then Intset.mem ev comp else true
   in
   let rec docomp evd = function
     | [] -> evd
     | comp :: comps ->
-	let res = try aux (p comp) evd with Not_found -> None in
-	  match res with
-	  | None -> 
-	      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
-		      else b, None
-		    else b, acc) evm (false, None)
-		in
-		  Typeclasses_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evm env) evm ev
-	      else (* Best effort: do nothing *) oevd
-	  | Some evd' -> docomp evd' comps
+      let p = select_and_update_evars p oevd (in_comp comp) in
+      try
+	 let evd' = resolve_all_evars_once debug m p evd in
+	 if has_undefined p oevd evd' then raise Unresolved;
+	 docomp evd' comps
+      with Unresolved | Not_found ->
+	if fail && (not do_split || is_mandatory (p evd) comp evd)
+	then (* Unable to satisfy the constraints. *)
+	  error_unresolvable env comp do_split evd
+	else (* Best effort: do nothing on this component *) 
+	  docomp evd comps
   in docomp oevd split
 
-let resolve_typeclass_evars d p env evd onlyargs split fail =
-  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 initial_select_evars onlyargs =
+  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)
+
+let resolve_typeclass_evars debug m env evd onlyargs split fail =
+  let evd = 
+    try Evarconv.consider_remaining_unif_problems
+      ~ts:(Typeclasses.classes_transparent_state ()) env evd
+    with _ -> evd
+  in
+    resolve_all_evars debug m env (initial_select_evars onlyargs) 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 solve_inst debug depth env evd onlyargs split fail =
+  resolve_typeclass_evars debug depth env evd onlyargs split fail
 
 let _ =
   Typeclasses.solve_instanciations_problem :=
-    solve_inst false true default_eauto_depth
+    solve_inst false !typeclasses_depth
+
+
+(** Options: depth, debug and transparency settings. *)
+
+open Goptions
+
+let set_typeclasses_debug d = (:=) typeclasses_debug d;
+  Typeclasses.solve_instanciations_problem := solve_inst d !typeclasses_depth
+    
+let get_typeclasses_debug () = !typeclasses_debug
+
+let set_typeclasses_debug =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "debug output for typeclasses proof search";
+      optkey   = ["Typeclasses";"Debug"];
+      optread  = get_typeclasses_debug;
+      optwrite = set_typeclasses_debug; }
+
+
+let set_typeclasses_depth d = (:=) typeclasses_depth d;
+  Typeclasses.solve_instanciations_problem := solve_inst !typeclasses_debug !typeclasses_depth
+    
+let get_typeclasses_depth () = !typeclasses_depth
+
+let set_typeclasses_depth =
+  declare_int_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "depth for typeclasses proof search";
+      optkey   = ["Typeclasses";"Depth"];
+      optread  = get_typeclasses_depth;
+      optwrite = set_typeclasses_depth; }
 
 let set_transparency cl b =
   List.iter (fun r -> 
     let gr = Smartlocate.global_with_alias r in
     let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
-      Classes.set_typeclass_transparency ev b) cl
+      Classes.set_typeclass_transparency ev false b) cl
 
 VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
 | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
@@ -704,18 +743,6 @@ ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
 | [ ] -> [ false ]
 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"
-    | None -> Pp.mt()
-
-ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode
-| [ "dfs" ] -> [ Some true ]
-| [ "bfs" ] -> [ Some false ]
-| [] -> [ None ]
-END
-
 let pr_depth _prc _prlc _prt = function
     Some i -> Util.pr_int i
   | None -> Pp.mt()
@@ -724,13 +751,12 @@ ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth
 | [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ]
 END
 
+(* true = All transparent, false = Opaque if possible *)
+
 VERNAC COMMAND EXTEND Typeclasses_Settings
- | [ "Typeclasses" "eauto" ":=" debug(d) 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 :=
-	 solve_inst d mode depth
+ | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
+     set_typeclasses_debug d;
+     set_typeclasses_depth depth
    ]
 END
 
@@ -738,8 +764,8 @@ 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
+      eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl
+   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl
  
 TACTIC EXTEND typeclasses_eauto
 | [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ]
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index f459a3dd..a3d43623 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: contradiction.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Term
 open Proof_type
@@ -17,7 +15,7 @@ open Tacticals
 open Tactics
 open Coqlib
 open Reductionops
-open Rawterm
+open Glob_term
 
 (* Absurd *)
 
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index bd2138d5..b77b2721 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: contradiction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Proof_type
-open Rawterm
+open Glob_term
 open Genarg
-(*i*)
 
 val absurd                      : constr -> tactic
 val contradiction               : constr with_bindings option -> tactic
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index 041e58df..fd924707 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dhyp.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Chet's comments about this tactic :
 
  Programmable destruction of hypotheses and conclusions.
@@ -118,7 +116,7 @@ open Term
 open Environ
 open Reduction
 open Proof_type
-open Rawterm
+open Glob_term
 open Tacmach
 open Refiner
 open Tactics
@@ -222,7 +220,7 @@ let subst_dd (subst,(local,na,dd)) =
     d_pri = dd.d_pri;
     d_code = !forward_subst_tactic subst dd.d_code })
 
-let (inDD,_) =
+let inDD : bool * identifier * destructor_data -> obj =
   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);
@@ -292,7 +290,7 @@ let applyDestructor cls discard dd gls =
       match cl, dd.d_code with
         | Some id, (Some x, tac) ->
 	    let arg =
-              ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
+              ConstrMayEval(ConstrTerm (GRef(dummy_loc,VarRef id),None)) in
             TacLetIn (false, [(dummy_loc, x), arg], tac)
         | None, (None, tac) -> tac
         | _, (Some _,_) -> error "Destructor expects an hypothesis."
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
index 4cde3b49..1bdeed6a 100644
--- a/tactics/dhyp.mli
+++ b/tactics/dhyp.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dhyp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Tacmach
 open Tacexpr
-(*i*)
 
-(* Programmable destruction of hypotheses and conclusions. *)
+(** Programmable destruction of hypotheses and conclusions. *)
 
 val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
 
@@ -28,5 +24,5 @@ val h_auto_tdb : int option -> tactic
 
 val add_destructor_hint :
   Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
-    Rawterm.patvar list * Pattern.constr_pattern -> int ->
+    Glob_term.patvar list * Pattern.constr_pattern -> int ->
       glob_tactic_expr -> unit
diff --git a/tactics/dn.mli b/tactics/dn.mli
index 3cb52a56..662ac19a 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -17,7 +17,7 @@ sig
 
   val create : unit -> t
     
-  (* [add t f (tree,inf)] adds a structured object [tree] together with
+  (** [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
@@ -31,7 +31,8 @@ sig
       
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
     
-(* [lookup t f tree] looks for trees (and their associated
+
+(** [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
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index e0cdbcfa..9966fb77 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eauto.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -19,7 +17,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -28,7 +25,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 
 let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
@@ -71,6 +68,7 @@ let rec prolog l n gl =
   (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
 
 let prolog_tac l n gl =
+  let l = List.map (prepare_hint (pf_env gl)) l in
   let n =
     match n with
       |  ArgArg n -> n
@@ -81,7 +79,7 @@ let prolog_tac l n gl =
     errorlabstrm "Prolog.prolog" (str "Prolog failed.")
 
 TACTIC EXTEND prolog
-| [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
 END
 
 open Auto
@@ -95,7 +93,7 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
 
 let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false ~flags clenv' gls in
+  let _ = clenv_unique_resolver ~flags clenv' gls in
   h_simplest_eapply c gls
 
 let rec e_trivial_fail_db db_list local_db goal =
@@ -170,7 +168,7 @@ let find_first_goal gls =
 
 type search_state = {
   depth : int; (*r depth of search before failing *)
-  tacres : goal list sigma * validation;
+  tacres : goal list sigma;
   last_tactic : std_ppcmds Lazy.t;
   dblist : Auto.hint_db list;
   localdb :  Auto.hint_db list }
@@ -179,15 +177,15 @@ module SearchProblem = struct
 
   type state = search_state
 
-  let success s = (sig_it (fst s.tacres)) = []
+  let success s = (sig_it s.tacres) = []
 
   let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
 
   let pr_goals gls =
-    let evars = Evarutil.nf_evars (Refiner.project gls) in
+    let evars = Evarutil.nf_evar_map (Refiner.project gls) in
       prlist (pr_ev evars) (sig_it gls)
 
-  let filter_tactics (glls,v) l =
+  let filter_tactics glls 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"); *)
@@ -195,11 +193,10 @@ module SearchProblem = struct
       | [] -> []
       | (tac,pptac) :: tacl ->
 	  try
-	    let (lgls,ptl) = apply_tac_list tac glls in
-	    let v' p = v (ptl p) in
+	    let lgls = apply_tac_list tac glls in
 (* 	    let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
 (* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
-	      ((lgls,v'),pptac) :: aux tacl
+	      (lgls,pptac) :: aux tacl
 	  with e -> Refiner.catch_failerror e; aux tacl
     in aux l
 
@@ -207,14 +204,14 @@ module SearchProblem = struct
      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
+    let nbgoals s = List.length (sig_it 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 lg = s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
       let g = find_first_goal lg in
@@ -232,7 +229,7 @@ module SearchProblem = struct
       in
       let intro_tac =
 	List.map
-	  (fun ((lgls,_) as res,pp) ->
+	  (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')
@@ -248,7 +245,7 @@ module SearchProblem = struct
 	  filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
 	in
 	List.map
-	  (fun ((lgls,_) as res, pp) ->
+	  (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;
@@ -294,7 +291,7 @@ let e_breadth_search debug n db_list local_db gl =
   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
+  let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
   if in_depth then
     e_depth_search debug p db_list local_db gl
   else
@@ -306,18 +303,12 @@ 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 db_list =
-    List.map
-      (fun x ->
-	 try searchtable_map x
-	 with Not_found -> error ("No such Hint database: "^x^"."))
-      ("core"::dbnames)
-  in
+  let db_list = make_db_list dbnames in
   tclTRY (e_search_auto debug np lems db_list)
 
 let full_eauto debug n lems gl =
   let dbnames = current_db_names () in
-  let dbnames =  list_subtract dbnames ["v62"] in
+  let dbnames =  list_remove "v62" dbnames in
   let db_list = List.map searchtable_map dbnames in
   tclTRY (e_search_auto debug n lems db_list) gl
 
@@ -349,19 +340,20 @@ ARGUMENT EXTEND hintbases
 | [ ] -> [ Some [] ]
 END
 
-let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
+let pr_constr_coma_sequence prc _ _ =
+  prlist_with_sep pr_comma (fun (_,c) -> prc c)
 
 ARGUMENT EXTEND constr_coma_sequence
-  TYPED AS constr_list
+  TYPED AS open_constr_list
   PRINTED BY pr_constr_coma_sequence
-| [ constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
-| [ constr(c) ] -> [ [c] ]
+| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
+| [ open_constr(c) ] -> [ [c] ]
 END
 
-let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c)
 
 ARGUMENT EXTEND auto_using
-  TYPED AS constr_list
+  TYPED AS open_constr_list
   PRINTED BY pr_auto_using
 | [ "using" constr_coma_sequence(l) ] -> [ l ]
 | [ ] -> [ [] ]
@@ -414,19 +406,6 @@ let autounfold db cls gl =
     | OnConcl occs -> tac occs None)
     cls gl
 
-let autosimpl db cl =
-  let unfold_of_elts constr (b, elts) =
-    if not b then
-      List.map (fun c -> all_occurrences, constr c) elts
-    else []
-  in
-  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
-
 open Extraargs
 
 TACTIC EXTEND autounfold
@@ -520,3 +499,55 @@ END
 TACTIC EXTEND convert_concl_no_check
 | ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ]
 END
+
+
+let pr_hints_path_atom prc _ _ a =
+  match a with
+  | PathAny -> str"."
+  | PathHints grs ->
+    prlist_with_sep pr_spc Printer.pr_global grs
+
+ARGUMENT EXTEND hints_path_atom
+  TYPED AS hints_path_atom
+  PRINTED BY pr_hints_path_atom
+| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ]
+| [ "*" ] -> [ PathAny ]
+END
+
+let pr_hints_path prc prx pry c =
+  let rec aux = function
+  | PathAtom a -> pr_hints_path_atom prc prx pry a
+  | PathStar p -> str"(" ++ aux p ++ str")*"
+  | PathSeq (p, p') -> aux p ++ spc () ++ aux p'
+  | PathOr (p, p') -> str "(" ++ aux p ++ str"|" ++ aux p' ++ str")"
+  | PathEmpty -> str"ø"
+  | PathEpsilon -> str"ε"
+  in aux c
+
+ARGUMENT EXTEND hints_path
+  TYPED AS hints_path
+  PRINTED BY pr_hints_path
+| [ "(" hints_path(p) ")"  ] -> [ p ]
+| [ "!" hints_path(p)  ] -> [ PathStar p ]
+| [ "emp" ] -> [ PathEmpty ]
+| [ "eps" ] -> [ PathEpsilon ]
+| [ hints_path_atom(a) ] -> [ PathAtom a ]
+| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ]
+| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ]
+END
+
+let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
+
+ARGUMENT EXTEND opthints
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ ":" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ None ]
+END
+
+VERNAC COMMAND EXTEND HintCut
+| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
+  let entry = HintsCutEntry p in
+    Auto.add_hints (Vernacexpr.use_section_locality ()) 
+      (match dbnames with None -> ["core"] | Some l -> l) entry ]
+END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index b40261b6..68ec42f4 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
 open Term
 open Proof_type
 open Tacexpr
@@ -15,13 +14,12 @@ open Topconstr
 open Evd
 open Environ
 open Explore
-(*i*)
 
-val hintbases : hint_db_name list option Pcoq.Gram.Entry.e
+val hintbases : hint_db_name list option Pcoq.Gram.entry
 val wit_hintbases : hint_db_name list option typed_abstract_argument_type
 val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
 
-val rawwit_auto_using : constr_expr list raw_abstract_argument_type
+val rawwit_auto_using : Genarg.open_constr_expr list raw_abstract_argument_type
 
 val e_assumption : tactic
 
@@ -29,13 +27,12 @@ val registered_e_assumption : 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 -> open_constr list ->
   hint_db_name list option -> tactic
 
-
 val eauto_with_bases :
   bool ->
   bool * int ->
-  Term.constr list -> Auto.hint_db list -> Proof_type.tactic
+  open_constr list -> Auto.hint_db list -> Proof_type.tactic
 
 val autounfold : hint_db_name list -> Tacticals.clause -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index f3517ea6..1ff8800f 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elim.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -111,12 +109,6 @@ let head_in gls indl t =
     in List.mem ity indl
   with Not_found -> false
 
-let inductive_of = function
-  | IndRef ity -> ity
-  | r ->
-      errorlabstrm "Decompose"
-        (Printer.pr_global r ++ str " is not an inductive type.")
-
 let decompose_these c l gls =
   let indl = (*List.map inductive_of*) l in
   general_decompose (fun (_,t) -> head_in gls indl t) c gls
@@ -136,8 +128,6 @@ let decompose_or c gls =
     (fun (_,t) -> is_disjunction t)
     c gls
 
-let inj_open c = (Evd.empty,c)
-
 let h_decompose l c =
   Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
 
diff --git a/tactics/elim.mli b/tactics/elim.mli
index c6aecad7..48a7ca68 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: elim.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Proof_type
 open Tacmach
 open Genarg
 open Tacticals
-(*i*)
 
-(* Eliminations tactics. *)
+(** Eliminations tactics. *)
 
 val introElimAssumsThen :
   (branch_assumptions -> tactic) -> branch_args -> tactic
@@ -34,5 +30,5 @@ val h_decompose       : inductive list -> constr -> tactic
 val h_decompose_or    : constr -> tactic
 val h_decompose_and   : constr -> tactic
 
-val double_ind : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis -> tactic
-val h_double_induction : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis->tactic
+val double_ind : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis -> tactic
+val h_double_induction : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis->tactic
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index c60938ed..fbf36c1c 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elimschemes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* 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
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index ab01a5fa..06d44550 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.mli
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elimschemes.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Ind_tables
 
-(* Induction/recursion schemes *)
+(** Induction/recursion schemes *)
 
 val rect_scheme_kind_from_prop : individual scheme_kind
 val ind_scheme_kind_from_prop : individual scheme_kind
@@ -21,7 +19,7 @@ val ind_dep_scheme_kind_from_type : individual scheme_kind
 val rec_dep_scheme_kind_from_type : individual scheme_kind
 
 
-(* Case analysis schemes *)
+(** Case analysis schemes *)
 
 val case_scheme_kind_from_type : individual scheme_kind
 val case_scheme_kind_from_prop : individual scheme_kind
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index a16e99bb..6d40b2da 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,8 +14,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eqdecide.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Namegen
@@ -29,7 +27,6 @@ open Auto
 open Pattern
 open Matching
 open Hipattern
-open Proof_trees
 open Proof_type
 open Tacmach
 open Coqlib
@@ -163,8 +160,7 @@ let decideGralEquality g =
 
 let decideEqualityGoal = tclTHEN intros decideGralEquality
 
-let decideEquality c1 c2 g =
-  let rectype = (pf_type_of g c1) in
+let decideEquality rectype g =
   let decide  = mkGenDecideEqGoal rectype g in
   (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g
 
@@ -178,13 +174,12 @@ let compare c1 c2 g =
             [(tclTHEN  intro
              (tclTHEN (onLastHyp simplest_case)
                        clear_last));
-             decideEquality c1 c2]) g
+             decideEquality (pf_type_of g c1)]) g
 
 
 (* User syntax *)
 
 TACTIC EXTEND decide_equality
-  [ "decide" "equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
 | [ "decide" "equality" ] -> [ decideEqualityGoal ]
 END
 
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 88931415..779fe265 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: eqschemes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* File created by Hugo Herbelin, Nov 2009 *)
 
 (* This file builds schemes related to equality inductive types,
@@ -70,8 +68,8 @@ let build_dependent_inductive ind (mib,mip) =
        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 s c = it_mkLambda_or_LetIn c s
+let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
 let my_it_mkLambda_or_LetIn_name s c =
   it_mkLambda_or_LetIn_name (Global.env()) c s
 
@@ -110,7 +108,7 @@ let get_sym_eq_data env ind =
   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
+  if not (list_equal eq_constr params2 constrargs) then
     error "Constructors arguments must repeat the parameters.";
   (* nrealargs_ctxt and nrealargs are the same here *)
   (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
@@ -176,7 +174,7 @@ let build_sym_scheme env ind =
        [|cstr (nrealargs+1)|]))))
 
 let sym_scheme_kind =
-  declare_individual_scheme_object "_sym"
+  declare_individual_scheme_object "_sym_internal"
   (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind)
 
 (**********************************************************************)
@@ -635,27 +633,14 @@ let rew_l2r_forward_dep_scheme_kind =
 (**********************************************************************)
 (* 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:                       *)
+(* potential candidates. Since l2r_rew needs a symmetrical equality,  *)
+(* we adopt r2l_forward_rew (this one introduces a blocked beta-      *)
+(* expansion but since the guard condition supports commutative cuts  *)
+(* this is not a problem; we need though a fix to adjust it to the    *)
+(* standard form of schemes in Coq)                                   *)
 (**********************************************************************)
 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))
 
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index 08b3b05c..870ca6b6 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.mli
@@ -1,21 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eqschemes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* This file builds schemes relative to equality inductive types *)
+(** 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 *)
+(** 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
@@ -23,7 +21,6 @@ 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
@@ -32,7 +29,7 @@ val build_r2l_forward_rew_scheme :
 val build_l2r_forward_rew_scheme :
   bool -> env -> inductive -> sorts_family -> constr
 
-(* Builds a symmetry scheme for a symmetrical equality type *)
+(** Builds a symmetry scheme for a symmetrical equality type *)
 
 val build_sym_scheme : env -> inductive -> constr
 val sym_scheme_kind : individual scheme_kind
@@ -40,7 +37,7 @@ 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 *)
+(** 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 a25f88e3..10fd0fef 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: equality.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -35,7 +33,7 @@ open Tacexpr
 open Tacticals
 open Tactics
 open Tacred
-open Rawterm
+open Glob_term
 open Coqlib
 open Vernacexpr
 open Declarations
@@ -58,6 +56,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic introduction of hypotheses by discriminate";
       optkey   = ["Discriminate";"Introduction"];
       optread  = (fun () -> !discriminate_introduction);
@@ -66,6 +65,7 @@ let _ =
 (* Rewriting tactics *)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
+type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
 type orientation = bool
 
@@ -84,18 +84,42 @@ type conditions =
 
 let rewrite_unif_flags = {
   Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly = true;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
   Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = empty_transparent_state;
+  Unification.check_applied_meta_types = true;
   Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = ExistentialSet.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = false
+    (* allow_K does not matter in practice because calls w_typed_unify *)
 }
 
+let freeze_initial_evars sigma flags clause =
+  (* We take evars of the type: this may include old evars! For excluding *)
+  (* all old evars, including the ones occurring in the rewriting lemma, *)
+  (* we would have to take the clenv_value *)
+  let newevars = Evd.collect_evars (clenv_type clause) in
+  let evars =
+    fold_undefined (fun evk _ evars ->
+      if ExistentialSet.mem evk newevars then evars
+      else ExistentialSet.add evk evars)
+      sigma ExistentialSet.empty in
+  { flags with Unification.frozen_evars = evars }
+
+let make_flags frzevars sigma flags clause =
+  if frzevars then freeze_initial_evars sigma flags clause else flags
+
 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 instantiate_lemma_all frzevars env sigma gl c ty l l2r concl =
   let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in
   let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
   let rec split_last_two = function
@@ -105,13 +129,12 @@ let instantiate_lemma_all env sigma gl c ty l l2r concl =
       | _ -> 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
+    clenv_pose_dependent_evars true {eqclause with evd = evd'}
   in
+  let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in
   let occs =
-    Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env
-      ((if l2r then c1 else c2),concl) eqclause.evd
+    Unification.w_unify_to_subterm_all ~flags env eqclause.evd
+      ((if l2r then c1 else c2),concl)
   in List.map try_occ occs
 
 let instantiate_lemma env sigma gl c ty l l2r concl =
@@ -121,28 +144,61 @@ let instantiate_lemma env sigma gl c ty l l2r concl =
   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_conv_closed_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = Some full_transparent_state;
+    (* We have this flag for historical reasons, it has e.g. the consequence *)
+    (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *)
+
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+    (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *)
+    (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *)
+
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
+  Unification.resolve_evars = false;
+  Unification.use_pattern_unification = true;
+    (* To rewrite "?n x y" in "y+x=0" when ?n is *)
+    (* a preexisting evar of the goal*)
+
+  Unification.use_meta_bound_pattern_unification = true;
+
+  Unification.frozen_evars = ExistentialSet.empty;
+    (* This is set dynamically *)
+
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = false
+}
+
+let rewrite_elim with_evars frzevars c e gl =
+  let flags =
+    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause_gen (elimination_clause_scheme with_evars ~flags) c e gl
 
-let rewrite_elim_in with_evars id c e =
-  general_elim_clause_gen (elimination_in_clause_scheme with_evars id) c e
+let rewrite_elim_in with_evars frzevars id c e gl =
+  let flags =
+    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause_gen
+    (elimination_in_clause_scheme with_evars ~flags id) c e gl
 
 (* Ad hoc asymmetric general_elim_clause *)
-let general_elim_clause with_evars cls rew elim =
+let general_elim_clause with_evars frzevars cls rew elim =
   try
     (match cls with
       | None ->
 	  (* was tclWEAK_PROGRESS which only fails for tactics generating one
              subgoal and did not fail for useless conditional rewritings generating
              an extra condition *)
-	  tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false)
-      | Some id -> rewrite_elim_in with_evars id rew elim)
-  with Pretype_errors.PretypeError (env,
-				   (Pretype_errors.NoOccurrenceFound (c', _))) ->
+	  tclNOTSAMEGOAL (rewrite_elim with_evars frzevars rew elim)
+      | Some id -> rewrite_elim_in with_evars frzevars id rew elim)
+  with Pretype_errors.PretypeError (env,evd,
+				    Pretype_errors.NoOccurrenceFound (c', _)) ->
     raise (Pretype_errors.PretypeError
-	      (env, (Pretype_errors.NoOccurrenceFound (c', cls))))
+	      (env,evd,Pretype_errors.NoOccurrenceFound (c', cls)))
 
-let general_elim_clause with_evars tac cls sigma c t l l2r elim gl =
+let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
   let all, firstonly, tac =
     match tac with
     | None -> false, false, None
@@ -151,12 +207,15 @@ let general_elim_clause with_evars tac cls sigma c t l l2r elim gl =
     | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac)
   in
   let cs =
-    (if not all then instantiate_lemma else instantiate_lemma_all)
+    (if not all then instantiate_lemma else instantiate_lemma_all frzevars)
       (pf_env gl) sigma gl c t l l2r
       (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id)
   in
   let try_clause c =
-    side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars cls c elim)) tac
+    side_tac
+      (tclTHEN
+         (Refiner.tclEVARS c.evd)
+         (general_elim_clause with_evars frzevars cls c elim)) tac
   in
     if firstonly then
       tclFIRST (List.map try_clause cs) gl
@@ -180,8 +239,8 @@ let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation
 
 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) &&
+  if (eq_constr hdcncl (constr_of_reference (Coqlib.glob_eq)) ||
+      eq_constr 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
@@ -195,7 +254,7 @@ let find_elim hdcncl lft2rgt dep cls args gl =
 	  let c1 = destConst pr1 in 
 	  let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in 
 	  let l' = label_of_id (add_suffix (id_of_label l) "_r")  in 
-	  let c1' = Global.constant_of_delta (make_con mp dp l') in
+	  let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in
 	  begin 
 	    try 
 	      let _ = Global.lookup_constant c1' in
@@ -211,20 +270,16 @@ let find_elim hdcncl lft2rgt dep cls args gl =
 	assert false
   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 *)
+    (* Non dependent case *)
+    | false, Some true, true -> rew_l2r_scheme_kind
+    | false, Some true, false -> rew_r2l_scheme_kind
+    | false, _, false -> rew_l2r_scheme_kind
+    | false, _, true -> rew_r2l_scheme_kind
+    (* Dependent case *)
     | 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
+    | true, _, true -> rew_r2l_dep_scheme_kind
+    | true, _, false -> rew_r2l_forward_dep_scheme_kind
   in
   match kind_of_term hdcncl with
   | Ind ind -> mkConst (find_scheme scheme_name ind)
@@ -234,12 +289,12 @@ 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 leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars 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
+  general_elim_clause with_evars frzevars tac cls sigma c t l
     (match lft2rgt with None -> false | Some b -> b)
     {elimindex = None; elimbody = (elim,NoBindings)} gl
 
@@ -259,7 +314,7 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac)
 
 (* Main function for dispatching which kind of rewriting it is about *)
 
-let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
+let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
     ((c,l) : constr with_bindings) with_evars gl =
   if occs <> all_occurrences then (
     rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl)
@@ -272,7 +327,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
       | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *)
 	  let lft2rgt = adjust_rewriting_direction args lft2rgt in
           leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels)
-	    l with_evars dep_proof_ok gl hdcncl
+	    l with_evars frzevars dep_proof_ok gl hdcncl
       | None ->
 	  try
 	    rewrite_side_tac (!general_rewrite_clause cls
@@ -284,27 +339,31 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
 	      | 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
+		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl
 	      | None -> raise e
 		  (* error "The provided term does not end with an equality or a declared rewrite relation." *)
 
 let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
 
-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_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) =
+  general_rewrite_ebindings_clause None l2r occs
+    frzevars 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 l2r occs frzevars dep_proof_ok ?tac c =
+  general_rewrite_bindings l2r occs
+    frzevars 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_ebindings_in l2r occs frzevars dep_proof_ok ?tac id =
+  general_rewrite_ebindings_clause (Some id) l2r occs frzevars 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_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) =
+  general_rewrite_ebindings_clause (Some id) l2r occs
+    frzevars dep_proof_ok ?tac (c,bl)
 
-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_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c =
+  general_rewrite_ebindings_clause (Some id) l2r occs
+    frzevars dep_proof_ok ?tac (c,NoBindings)
 
 let general_multi_rewrite l2r with_evars ?tac c cl =
   let occs_of = on_snd (List.fold_left
@@ -320,12 +379,12 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	  | [] -> tclIDTAC
 	  | ((occs,id),_) :: l ->
 	    tclTHENFIRST
-	      (general_rewrite_ebindings_in l2r (occs_of occs) true ?tac id c with_evars)
+	      (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars)
 	      (do_hyps l)
 	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps l else
 	  tclTHENFIRST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   (do_hyps l)
     | None ->
 	(* Otherwise, if we are told to rewrite in all hypothesis via the
@@ -334,7 +393,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	  | [] -> (fun gl -> error "Nothing to rewrite.")
 	  | id :: l ->
 	    tclIFTHENTRYELSEMUST
-	     (general_rewrite_ebindings_in l2r all_occurrences true ?tac id c with_evars)
+	     (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars)
 	     (do_hyps_atleastonce l)
 	in
 	let do_hyps gl =
@@ -346,7 +405,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps else
 	  tclIFTHENTRYELSEMUST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   do_hyps
 
 type delayed_open_constr_with_bindings =
@@ -371,8 +430,8 @@ let general_multi_multi_rewrite with_evars l cl tac =
     | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l)
   in loop l
 
-let rewriteLR = general_rewrite true all_occurrences true
-let rewriteRL = general_rewrite false all_occurrences true
+let rewriteLR = general_rewrite true all_occurrences true true
+let rewriteRL = general_rewrite false all_occurrences true true
 
 (* Replacing tactics *)
 
@@ -512,7 +571,7 @@ let discriminable env sigma t1 t2 =
 
 let injectable env sigma t1 t2 =
     match find_positions env sigma t1 t2 with
-    | Inl _ | Inr [] -> false
+    | Inl _ | Inr [] | Inr [([],_,_)] -> false
     | Inr _ -> true
 
 
@@ -631,7 +690,7 @@ let construct_discriminator sigma env dirn c sort =
           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
@@ -682,14 +741,13 @@ let gen_absurdity id gl =
 *)
 
 let ind_scheme_of_eq lbeq =
-  let ind = destInd lbeq.eq in
-  let (mib,mip) = Global.lookup_inductive ind in
+  let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in
   let kind = inductive_sort_family mip in
   (* use ind rather than case by compatibility *)
   let kind =
     if kind = InProp then Elimschemes.ind_scheme_kind_from_prop
     else Elimschemes.ind_scheme_kind_from_type in
-  mkConst (find_scheme kind ind)
+  mkConst (find_scheme kind (destInd lbeq.eq))
 
 
 let discrimination_pf e (t,t1,t2) discriminator lbeq =
@@ -894,8 +952,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
       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 !evdref
- 	  (destEvar ev)
+        Evd.existential_opt_value !evdref
+          (destEvar ev)
       with
 	| Some w ->
             let w_type = type_of env sigma w in
@@ -1057,6 +1115,8 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
     | Inr [] ->
 	errorlabstrm "Equality.inj"
 	   (str"Nothing to do, it is an equality between convertible terms.")
+    | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 ->
+        errorlabstrm "Equality.inj" (str"Nothing to inject.")
     | Inr posns ->
 (* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
 	let t1 = try_delta_expand env sigma t1 in
@@ -1186,26 +1246,37 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
 
 let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
+    let iterated_decomp =
     try
       let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
       let car_code = applist (p1,[a;p;inner_code])
       and cdr_code = applist (p2,[a;p;inner_code]) in
       let cdrtyp = beta_applist (p,[car]) in
-      ((car,a),car_code)::(decomprec cdr_code cdr cdrtyp)
+      List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp)
     with PatternMatchingFailure ->
-      [((ex,exty),inner_code)]
+      []
+    in
+    [((ex,exty),inner_code)]::iterated_decomp
   in
-  List.split (decomprec (mkRel 1) c t)
+  decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let typ = get_type_of env sigma dep_pair1 in
+  (* We find all possible decompositions *)
+  let decomps1 = decomp_tuple_term env dep_pair1 typ in
+  let decomps2 = decomp_tuple_term env dep_pair2 typ in
+  (* We adjust to the shortest decomposition *)
+  let n = min (List.length decomps1) (List.length decomps2) in
+  let decomp1 = List.nth decomps1 (n-1) in
+  let decomp2 = List.nth decomps2 (n-1) in
   (* We rewrite dep_pair1 ... *)
-  let e1_list,proj_list = decomp_tuple_term env dep_pair1 typ in
+  let e1_list,proj_list = List.split decomp1 in
+  (* ... and use dep_pair2 to compute the expected goal *)
+  let e2_list,_ = List.split decomp2 in
+  (* We build the expected goal *)
   let abst_B =
     List.fold_right
       (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 *)
@@ -1330,34 +1401,21 @@ exception FoundHyp of (identifier * constr * bool)
 let is_eq_x gl x (id,_,c) =
   try
     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))
+    if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
   with PatternMatchingFailure ->
     ()
 
-let 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 *)
-  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
-  (* x is a variable: *)
-  let varx = mkVar x in
-  (* Find a non-recursive definition for x *)
-  let (hyp,rhs,dir) =
-    try
-      let test hyp _ = is_eq_x gl varx hyp in
-      Sign.fold_named_context test ~init:() hyps;
-      errorlabstrm "Subst"
-        (str "Cannot find any non-recursive equality over " ++ pr_id x ++
-	 str".")
-    with FoundHyp res -> res
-  in
+(* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and
+   erase hyp and x; proceed by generalizing all dep hyps *)
+
+let subst_one dep_proof_ok x (hyp,rhs,dir) gl =
   (* The set of hypotheses using x *)
   let depdecls =
     let test (id,_,c as dcl) =
       if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
       else failwith "caught" in
-    List.rev (map_succeed test hyps) in
+    List.rev (map_succeed test (pf_hyps gl)) in
   let dephyps = List.map (fun (id,_,_) -> id) depdecls in
   (* Decides if x appears in conclusion *)
   let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
@@ -1373,23 +1431,47 @@ let subst_one dep_proof_ok x gl =
       (id,None,_) -> intro_using id
     | (id,Some hval,htyp) ->
         letin_tac None (Name id)
-	  (replace_term varx rhs hval)
-	  (Some (replace_term varx rhs htyp)) nowhere
+	  (replace_term (mkVar x) rhs hval)
+	  (Some (replace_term (mkVar x) rhs htyp)) nowhere
   in
   let need_rewrite = dephyps <> [] || depconcl in
   tclTHENLIST
     ((if need_rewrite then
       [generalize abshyps;
-       general_rewrite dir all_occurrences dep_proof_ok (mkVar hyp);
+       general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp);
        thin dephyps;
        tclMAP introtac depdecls]
-    else
-      [thin dephyps;
-       tclMAP introtac depdecls]) @
+      else
+       [tclIDTAC]) @
      [tclTRY (clear [x;hyp])]) gl
 
+(* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite
+   it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *)
+
+let subst_one_var dep_proof_ok x gl =
+  let hyps = pf_hyps gl in
+  let (_,xval,_) = pf_get_hyp gl x in
+  (* If x has a body, simply replace x with body and clear x *)
+  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
+  (* x is a variable: *)
+  let varx = mkVar x in
+  (* Find a non-recursive definition for x *)
+  let (hyp,rhs,dir) =
+    try
+      let test hyp _ = is_eq_x gl varx hyp in
+      Sign.fold_named_context test ~init:() hyps;
+      errorlabstrm "Subst"
+        (str "Cannot find any non-recursive equality over " ++ pr_id x ++
+	 str".")
+    with FoundHyp res -> res in
+  subst_one dep_proof_ok x (hyp,rhs,dir) gl
+
 let subst_gen dep_proof_ok ids =
-  tclTHEN tclNORMEVAR (tclMAP (subst_one dep_proof_ok) ids)
+  tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids)
+
+(* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x",
+   rewrite it everywhere, and erase hyp and x; proceed by generalizing
+   all dep hyps *)
 
 let subst = subst_gen true
 
@@ -1466,3 +1548,5 @@ let replace_multi_term dir_opt c  =
 
 let _ = Tactics.register_general_multi_rewrite
   (fun b evars t cls -> general_multi_rewrite b evars t cls)
+
+let _ = Tactics.register_subst_one (fun b -> subst_one b)
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 0c2d8942..79059469 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: equality.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Util
 open Names
@@ -23,12 +21,13 @@ open Tacticals
 open Tactics
 open Tacexpr
 open Termops
-open Rawterm
+open Glob_term
 open Genarg
 open Ind_tables
 (*i*)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
+type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
 type orientation = bool
 
@@ -38,10 +37,10 @@ type conditions =
   | AllMatches (* Rewrite all matches whose side-conditions are solved *)
 
 val general_rewrite_bindings :
-  orientation -> occurrences -> dep_proof_flag ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
   ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite :
-  orientation -> occurrences -> dep_proof_flag ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
   ?tac:(tactic * conditions) -> constr -> tactic
 
 (* Equivalent to [general_rewrite l2r] *)
@@ -56,15 +55,16 @@ val register_general_rewrite_clause :
 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
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
+  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
 
 val general_rewrite_bindings_in :
-  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
+  ?tac:(tactic * conditions) ->
   identifier -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite_in          :
-  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
-  identifier -> constr -> evars_flag -> tactic
+  orientation -> occurrences -> freeze_evars_flag -> 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
@@ -73,7 +73,7 @@ type delayed_open_constr_with_bindings =
     env -> evar_map -> evar_map * constr with_bindings
 
 val general_multi_multi_rewrite :
-  evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list -> 
+  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
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index 9f7c0a54..992fdc91 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_tactics.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Util
 open Evar_refiner
@@ -25,9 +23,9 @@ let instantiate n (ist,rawc) ido gl =
   let sigma = gl.sigma in
   let evl =
     match ido with
-	ConclLocation () -> evar_list sigma gl.it.evar_concl
+	ConclLocation () -> evar_list sigma (pf_concl gl)
       | HypLocation (id,hloc) ->
-	  let decl = Environ.lookup_named_val id gl.it.evar_hyps in
+	  let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in
 	    match hloc with
 		InHyp ->
 		  (match decl with
@@ -57,4 +55,3 @@ let let_evar name typ gls =
   let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) ~src typ in
   Refiner.tclTHEN (Refiner.tclEVARS sigma')
     (Tactics.letin_tac None name evar None nowhere) gls
-
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index f54f6a4c..882cf3ce 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -1,23 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_tactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacmach
 open Names
 open Tacexpr
 open Termops
 
-val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr ->
+val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
   (identifier * hyp_location_flag, unit) location -> tactic
 
-(*i
-val instantiate_tac : tactic_arg list -> tactic
-i*)
-
 val let_evar : name -> Term.types -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 310423d2..6a13ac2a 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extraargs.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Genarg
@@ -27,35 +25,37 @@ let pr_orient _prc _prlc _prt = function
   | true -> Pp.mt ()
   | false -> Pp.str " <-"
 
-
 ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ "->" ] -> [ true ]
 | [ "<-" ] -> [ false ]
 | [ ] -> [ true ]
 END
 
-let pr_int_list _prc _prlc _prt l =
+let pr_orient = pr_orient () () ()
+
+let pr_int_list_full _prc _prlc _prt l =
   let rec aux = function
     | i :: l -> Pp.int i ++ Pp.spc () ++ aux l
     | [] -> Pp.mt()
   in aux l
 
 ARGUMENT EXTEND int_nelist
-  TYPED AS int list
-  PRINTED BY pr_int_list
+  PRINTED BY pr_int_list_full
   RAW_TYPED AS int list
-  RAW_PRINTED BY pr_int_list
+  RAW_PRINTED BY pr_int_list_full
   GLOB_TYPED AS int list
-  GLOB_PRINTED BY pr_int_list
+  GLOB_PRINTED BY pr_int_list_full
 | [ integer(x) int_nelist(l) ] -> [x::l]
 | [ integer(x) ] -> [ [x] ]
 END
 
-open Rawterm
+let pr_int_list = pr_int_list_full () () ()
+
+open Glob_term
 
 let pr_occurrences _prc _prlc _prt l =
   match l with
-    | ArgArg x -> pr_int_list _prc _prlc _prt x
+    | ArgArg x -> pr_int_list x
     | ArgVar (loc, id) -> Nameops.pr_id id
 
 let coerce_to_int = function
@@ -81,8 +81,7 @@ type occurrences_or_var = int list or_var
 type occurrences = int list
 
 ARGUMENT EXTEND occurrences
-  TYPED AS occurrences
-  PRINTED BY pr_int_list
+  PRINTED BY pr_int_list_full
 
   INTERPRETED BY interp_occs
   GLOBALIZED BY glob_occs
@@ -98,32 +97,34 @@ ARGUMENT EXTEND occurrences
 | [ var(id) ] -> [ ArgVar id ]
 END
 
+let pr_occurrences = pr_occurrences () () ()
+
 let pr_gen prc _prlc _prtac c = prc c
 
-let pr_rawc _prc _prlc _prtac (_,raw) = Printer.pr_rawconstr raw
+let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
 
-let interp_raw ist gl (t,_) = (ist,t)
+let interp_glob ist gl (t,_) = (ist,t)
 
-let glob_raw = Tacinterp.intern_constr
+let glob_glob = Tacinterp.intern_constr
 
-let subst_raw = Tacinterp.subst_rawconstr_and_expr
+let subst_glob = Tacinterp.subst_glob_constr_and_expr
 
-ARGUMENT EXTEND raw
-    TYPED AS rawconstr
-    PRINTED BY pr_rawc
+ARGUMENT EXTEND glob
+    PRINTED BY pr_globc
 
-     INTERPRETED BY interp_raw
-     GLOBALIZED BY glob_raw
-     SUBSTITUTED BY subst_raw
+     INTERPRETED BY interp_glob
+     GLOBALIZED BY glob_glob
+     SUBSTITUTED BY subst_glob
 
      RAW_TYPED AS constr_expr
      RAW_PRINTED BY pr_gen
 
-     GLOB_TYPED AS rawconstr_and_expr
+     GLOB_TYPED AS glob_constr_and_expr
      GLOB_PRINTED BY pr_gen
   [ lconstr(c) ] -> [ c ]
 END
 
+
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
 type loc_place = identifier Util.located gen_place
@@ -139,6 +140,7 @@ let pr_gen_place pr_id = function
 
 let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
 let pr_place _ _ _ = pr_gen_place Nameops.pr_id
+let pr_hloc = pr_loc_place () () ()
 
 let intern_place ist = function
     ConclLocation () -> ConclLocation ()
@@ -151,7 +153,6 @@ let interp_place ist gl = function
 let subst_place subst pl = pl
 
 ARGUMENT EXTEND hloc
-    TYPED AS place
     PRINTED BY pr_place
     INTERPRETED BY interp_place
     GLOBALIZED BY intern_place
@@ -193,6 +194,7 @@ ARGUMENT EXTEND by_arg_tac
 | [ ] -> [ None ]
 END
 
+let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c
 
 let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds =
   match lo,concl with
@@ -220,7 +222,6 @@ let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
 
 
 ARGUMENT EXTEND comma_var_lne
-  TYPED AS var list
   PRINTED BY pr_var_list_typed
   RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
@@ -231,7 +232,6 @@ ARGUMENT EXTEND comma_var_lne
 END
 
 ARGUMENT EXTEND comma_var_l
-  TYPED AS var list
   PRINTED BY pr_var_list_typed
   RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
@@ -253,7 +253,6 @@ 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_PRINTED BY pr_in_arg_hyp
@@ -267,6 +266,7 @@ ARGUMENT EXTEND in_arg_hyp
 | [ ] -> [ (Some [],true) ]
 END
 
+let pr_in_arg_hyp = pr_in_arg_hyp_typed () () ()
 
 let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
   {Tacexpr.onhyps=
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index a3f27fde..2abca40e 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -1,32 +1,32 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraargs.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacexpr
 open Term
 open Names
 open Proof_type
 open Topconstr
 open Termops
-open Rawterm
+open Glob_term
 
 val rawwit_orient : bool raw_abstract_argument_type
 val wit_orient : bool typed_abstract_argument_type
-val orient : bool Pcoq.Gram.Entry.e
+val orient : bool Pcoq.Gram.entry
+val pr_orient : bool -> Pp.std_ppcmds
 
-val occurrences : (int list or_var) Pcoq.Gram.Entry.e
+val occurrences : (int list or_var) Pcoq.Gram.entry
 val rawwit_occurrences : (int list or_var) raw_abstract_argument_type
 val wit_occurrences : (int list) typed_abstract_argument_type
+val pr_occurrences : int list Glob_term.or_var -> Pp.std_ppcmds
 
-val rawwit_raw : constr_expr raw_abstract_argument_type
-val wit_raw : (Tacinterp.interp_sign * rawconstr) typed_abstract_argument_type
-val raw : constr_expr Pcoq.Gram.Entry.e
+val rawwit_glob : constr_expr raw_abstract_argument_type
+val wit_glob : (Tacinterp.interp_sign * glob_constr) typed_abstract_argument_type
+val glob : constr_expr Pcoq.Gram.entry
 
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
@@ -35,24 +35,26 @@ type place = identifier gen_place
 
 val rawwit_hloc : loc_place raw_abstract_argument_type
 val wit_hloc : place typed_abstract_argument_type
-val hloc : loc_place Pcoq.Gram.Entry.e
-
+val hloc : loc_place Pcoq.Gram.entry
+val pr_hloc : loc_place -> Pp.std_ppcmds
 
-val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.Entry.e
+val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.entry
 val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
 val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
 val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
 val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
+val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds
 
-
-val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e
+val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
 val rawwit_by_arg_tac :  raw_tactic_expr option raw_abstract_argument_type
 val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type
+val pr_by_arg_tac : 
+  (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) ->
+  raw_tactic_expr option -> Pp.std_ppcmds
 
 
+(** Spiwack: Primitive for retroknowledge registration *)
 
-(* Spiwack: Primitive for retroknowledge registration *)
-
-val retroknowledge_field : Retroknowledge.field Pcoq.Gram.Entry.e
+val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry
 val rawwit_retroknowledge_field :  Retroknowledge.field raw_abstract_argument_type
 val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index c4a2ef44..da35edbe 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extratactics.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Genarg
@@ -17,12 +15,12 @@ open Extraargs
 open Mod_subst
 open Names
 open Tacexpr
-open Rawterm
+open Glob_term
 open Tactics
 open Util
-open Termops
 open Evd
 open Equality
+open Compat
 
 (**********************************************************************)
 (* replace, discriminate, injection, simplify_eq                      *)
@@ -189,13 +187,24 @@ END
 
 open Autorewrite
 
+let pr_orient _prc _prlc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+let pr_orient_string _prc _prlc _prt (orient, s) =
+  pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s
+
+ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string
+| [ orient(r) preident(i) ] -> [ r, i ]
+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
-      auto_multi_rewrite_with (snd t) l cl
+      auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl
 
     ]
 END
@@ -205,7 +214,7 @@ TACTIC EXTEND autorewrite_star
     [ 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 ]
+	auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ]
 END
 
 (**********************************************************************)
@@ -214,7 +223,7 @@ END
 let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) =
   let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in
   Refiner. tclWITHHOLES false
-    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true (c,NoBindings)) sigma true
+    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings)) sigma true
 
 let occurrences_of = function
   | n::_ as nl when n < 0 -> (false,List.map abs nl)
@@ -229,11 +238,11 @@ TACTIC EXTEND rewrite_star
 | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] ->
     [ rewrite_star (Some id) o (occurrences_of occ) c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] ->
-    [ rewrite_star (Some id) o all_occurrences c tac ]
+    [ rewrite_star (Some id) o Termops.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 ]
+    [ rewrite_star None o Termops.all_occurrences c tac ]
     END
 
 (**********************************************************************)
@@ -277,7 +286,7 @@ let project_hint pri l2r c =
   let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in
   let c = it_mkLambda_or_LetIn
     (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
-  (pri,true,c)
+  (pri,true,Auto.PathAny,c)
 
 let add_hints_iff l2r lc n bl =
   Auto.add_hints true bl
@@ -326,18 +335,18 @@ VERNAC COMMAND EXTEND DeriveInversionClear
   -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
 
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ]
+  -> [ add_inversion_lemma_exn na c (Glob_term.GProp Term.Null) false inv_clear_tac ]
 END
 
 open Term
-open Rawterm
+open Glob_term
 
 VERNAC COMMAND EXTEND DeriveInversion
 | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
   -> [ add_inversion_lemma_exn na c s false inv_tac ]
 
 | [ "Derive" "Inversion" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (RProp Null) false inv_tac ]
+  -> [ add_inversion_lemma_exn na c (GProp Null) false inv_tac ]
 
 | [ "Derive" "Inversion" ident(na) hyp(id) ]
   -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_tac ]
@@ -385,7 +394,7 @@ open Tacexpr
 open Tacticals
 
 TACTIC EXTEND instantiate
-  [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] ->
+  [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] ->
     [instantiate i c hl  ]
 | [ "instantiate" ] -> [ tclNORMEVAR ]
 END
@@ -397,7 +406,7 @@ END
 open Tactics
 open Tactics
 open Libnames
-open Rawterm
+open Glob_term
 open Summary
 open Libobject
 open Lib
@@ -433,7 +442,7 @@ let cache_transitivity_lemma (_,(left,lem)) =
 
 let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
 
-let (inTransitivity,_) =
+let inTransitivity : bool * constr -> obj =
   declare_object {(default_object "TRANSITIVITY-STEPS") with
     cache_function = cache_transitivity_lemma;
     open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
@@ -467,12 +476,12 @@ let add_transitivity_lemma left lem =
 (* Vernacular syntax *)
 
 TACTIC EXTEND stepl
-| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ]
+| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ]
 | ["stepl" constr(c) ] -> [ step true c tclIDTAC ]
 END
 
 TACTIC EXTEND stepr
-| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ]
+| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ]
 | ["stepr" constr(c) ] -> [ step false c tclIDTAC ]
 END
 
@@ -488,7 +497,7 @@ END
 
 VERNAC COMMAND EXTEND ImplicitTactic
 | [ "Declare" "Implicit" "Tactic" tactic(tac) ] ->
-    [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ]
+    [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ]
 END
 
 
@@ -539,27 +548,27 @@ END
 (**********************************************************************)
 
 let subst_var_with_hole occ tid t = 
-  let occref = if occ > 0 then ref occ else error_invalid_occurrence [occ] in
+  let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in
   let locref = ref 0 in
   let rec substrec = function
-    | RVar (_,id) as x -> 
+    | GVar (_,id) as x -> 
         if id = tid 
         then (decr occref; if !occref = 0 then x
-                           else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
+                           else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
         else x
-    | c -> map_rawconstr_left_to_right substrec c in
+    | c -> map_glob_constr_left_to_right substrec c in
   let t' = substrec t
   in
-  if !occref > 0 then error_invalid_occurrence [occ] else t'
+  if !occref > 0 then Termops.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)) -> 
+    | GHole (_,Evd.QuestionMark(Evd.Define true)) -> 
         decr occref; if !occref = 0 then tc
-                     else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
-    | c -> map_rawconstr_left_to_right substrec c
+                     else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
+    | c -> map_glob_constr_left_to_right substrec c
   in
   substrec t
 
@@ -571,16 +580,16 @@ let out_arg = function
 
 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 env = Termops.clear_named_body id (pf_env gl) in
+  let env_ids = Termops.ids_of_context env in
+  let env_names = Termops.names_of_rel_context env in
   let c_raw = Detyping.detype true env_ids env_names c in 
   let t_raw = Detyping.detype true env_ids env_names t in 
   let rec resolve_hole t_hole =
     try 
       Pretyping.Default.understand sigma env t_hole
     with 
-    | Stdpp.Exc_located (loc,Pretype_errors.PretypeError (_, Pretype_errors.UnsolvableImplicit _)) -> 
+    | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) ->
         resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole)
   in
   let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
@@ -625,8 +634,91 @@ END
 
 (**********************************************************************)
 
+(**********************************************************************)
+(* A tactic that reduces one match t with ... by doing destruct t.    *)
+(* if t is not a variable, the tactic does                            *)
+(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is    *)
+(* preserved).                                                        *)
+(* Contributed by Julien Forest and Pierre Courtieu (july 2010)       *)
+(**********************************************************************)
+
+exception Found of tactic
+
+let rewrite_except h g =
+  tclMAP (fun id -> if id = h then tclIDTAC else 
+      tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true true id (mkVar h) false))
+    (Tacmach.pf_ids_of_hyps g) g
+
+
+let refl_equal = 
+  let coq_base_constant s =
+    Coqlib.gen_constant_in_modules "RecursiveDefinition"
+      (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in
+  function () -> (coq_base_constant "eq_refl")
+
+
+(* This is simply an implementation of the case_eq tactic.  this code
+  should be replaced by a call to the tactic but I don't know how to
+  call it before it is defined. *)
+let  mkCaseEq a  : tactic =
+     (fun g ->
+       let type_of_a = Tacmach.pf_type_of g a in
+       tclTHENLIST
+         [Hiddentac.h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
+          (fun g2 ->
+	    change_in_concl None
+	     (Tacred.pattern_occs [((false,[1]), a)] (Tacmach.pf_env g2) Evd.empty (Tacmach.pf_concl g2))
+		  g2);
+	  simplest_case a] g);;
+
+
+let case_eq_intros_rewrite x g =
+  let n = nb_prod (Tacmach.pf_concl g) in
+  Pp.msgnl (Printer.pr_lconstr x); 
+  tclTHENLIST [
+      mkCaseEq x;
+      (fun g -> 
+	let n' = nb_prod (Tacmach.pf_concl g) in
+	let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in
+	tclTHENLIST [ (tclDO (n'-n-1) intro);
+		      Tacmach.introduction h;
+		      rewrite_except h] g
+      )
+    ] g
+
+let rec find_a_destructable_match t =
+  match kind_of_term t with
+    | Case (_,_,x,_) when closed0 x ->
+	if isVar x then
+	  (* TODO check there is no rel n. *)
+	  raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>)))
+	else
+	  let _ = Pp.msgnl (Printer.pr_lconstr x)  in
+	  raise (Found (case_eq_intros_rewrite x))
+    | _ -> iter_constr find_a_destructable_match t
+	
+
+let destauto t =
+  try find_a_destructable_match t;
+    error "No destructable match found"
+  with Found tac -> tac
+
+let destauto_in id g = 
+  let ctype = Tacmach.pf_type_of g (mkVar id) in
+  Pp.msgnl (Printer.pr_lconstr (mkVar id)); 
+  Pp.msgnl (Printer.pr_lconstr (ctype)); 
+  destauto ctype g
+
+TACTIC EXTEND destauto
+| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ]
+| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
+END
+
+
+(* ********************************************************************* *)
+
 TACTIC EXTEND constr_eq
-| [ "constr_eq" constr(x) constr(y) ] -> [ 
+| [ "constr_eq" constr(x) constr(y) ] -> [
     if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ]
 END
 
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index ecad939c..66f46722 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extratactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Proof_type
 
 val h_discrHyp : Names.identifier -> tactic
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 018bf815..fafc681a 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hiddentac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Proof_type
 open Tacmach
 
-open Rawterm
+open Glob_term
 open Refiner
 open Genarg
 open Tacexpr
@@ -66,6 +64,10 @@ let h_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,c,cl,b)) (letin_tac with_eq na c None cl)
+let h_let_pat_tac b na c cl =
+  let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
+  abstract_tactic (TacLetTac (na,snd c,cl,b))
+    (letin_pat_tac with_eq na c None cl)
 
 (* Derived basic tactics *)
 let h_simple_induction_destruct isrec h =
@@ -74,10 +76,17 @@ let h_simple_induction_destruct isrec h =
 let h_simple_induction = h_simple_induction_destruct true
 let h_simple_destruct = h_simple_induction_destruct false
 
+let out_indarg = function
+  | ElimOnConstr (_,c) -> ElimOnConstr c
+  | ElimOnIdent id -> ElimOnIdent id
+  | ElimOnAnonHyp n -> ElimOnAnonHyp n
+
 let h_induction_destruct isrec ev lcl =
-  abstract_tactic (TacInductionDestruct (isrec,ev,lcl))
+  let lcl' = on_fst (List.map (fun (a,b,c) ->(List.map out_indarg a,b,c))) lcl in
+  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_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,d)) (specialize n d)
@@ -102,9 +111,9 @@ 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)
+  abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l)
 let h_one_constructor n =
-  abstract_tactic (TacConstructor(false,AI n,NoBindings)) (one_constructor n NoBindings)
+  abstract_tactic (TacConstructor(false,ArgArg n,NoBindings)) (one_constructor n NoBindings)
 let h_simplest_left   = h_left false NoBindings
 let h_simplest_right  = h_right false NoBindings
 
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index 31484cc0..96e7e3f0 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hiddentac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Util
 open Term
@@ -16,16 +13,15 @@ open Proof_type
 open Tacmach
 open Genarg
 open Tacexpr
-open Rawterm
+open Glob_term
 open Evd
 open Clenv
 open Termops
-(*i*)
 
-(* Tactics for the interpreter. They left a trace in the proof tree
+(** Tactics for the interpreter. They left a trace in the proof tree
    when they are called. *)
 
-(* Basic tactics *)
+(** Basic tactics *)
 
 val h_intro_move      : identifier option -> identifier move_location -> tactic
 val h_intro           : identifier -> tactic
@@ -61,39 +57,44 @@ 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
+val h_let_pat_tac     : letin_flag -> name -> evar_map * constr ->
+                        Tacticals.clause -> tactic
 
-(* Derived basic tactics *)
+(** Derived basic tactics *)
 
 val h_simple_induction   : quantified_hypothesis -> tactic
 val h_simple_destruct    : quantified_hypothesis -> tactic
 val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic
 val h_new_induction   : evars_flag ->
-  constr with_bindings induction_arg list -> constr with_bindings option ->
+  (evar_map * 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_bindings induction_arg list -> constr with_bindings option ->
+  (evar_map * 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_bindings induction_arg list * constr with_bindings option *
+  ((evar_map * 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_bindings -> tactic
 val h_lapply          : constr -> tactic
 
-(* Automation tactic : see Auto *)
+(** Automation tactic : see Auto *)
 
 
-(* Context management *)
+(** Context management *)
 val h_clear           : bool -> identifier list -> tactic
 val h_clear_body      : identifier list -> tactic
 val h_move            : bool -> identifier -> identifier move_location -> tactic
 val h_rename          : (identifier*identifier) list -> tactic
 val h_revert          : identifier list -> tactic
 
-(* Constructors *)
+(** Constructors *)
 val h_constructor     : evars_flag -> int -> constr bindings -> tactic
 val h_left            : evars_flag -> constr bindings -> tactic
 val h_right           : evars_flag -> constr bindings -> tactic
@@ -104,12 +105,12 @@ val h_simplest_left   : tactic
 val h_simplest_right  : tactic
 
 
-(* Conversion *)
+(** Conversion *)
 val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
 val h_change          :
   Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic
 
-(* Equivalence relations *)
+(** Equivalence relations *)
 val h_reflexivity     : tactic
 val h_symmetry        : Tacticals.clause -> tactic
 val h_transitivity    : constr option -> tactic
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index 08bcf65a..9057c60d 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
 
-(* $Id: hipattern.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -21,7 +19,6 @@ open Reductionops
 open Inductiveops
 open Evd
 open Environ
-open Proof_trees
 open Clenv
 open Pattern
 open Matching
@@ -98,7 +95,7 @@ let match_with_one_constructor style allow_rec t =
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
 	  if
 	    List.for_all
-	      (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx
+	      (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx
 	  then
 	    Some (hdapp,args)
 	  else None
@@ -145,7 +142,7 @@ let is_tuple t =
 let test_strict_disjunction n lc =
   array_for_all_i (fun i c ->
     match (prod_assum (snd (decompose_prod_n_assum n c))) with
-    | [_,None,c] -> c = mkRel (n - i)
+    | [_,None,c] -> isRel c && destRel c = (n - i)
     | _ -> false) 0 lc
 
 let match_with_disjunction ?(strict=false) t =
@@ -426,6 +423,7 @@ let dest_nf_eq gls eqn =
 (* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *)
 let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ]
 let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref
+let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref
 
 let match_sigma ex ex_pat =
   match matches (Lazy.force ex_pat) ex with
@@ -437,7 +435,8 @@ let match_sigma ex ex_pat =
 
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
   first_match (match_sigma ex)
-    [coq_existT_pattern, build_sigma_type]
+    [coq_existT_pattern, build_sigma_type;
+     coq_exist_pattern, build_sigma]
 
 (* Pattern "(sig ?1 ?2)" *)
 let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 15d7bfc6..aa386364 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -1,25 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hipattern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Sign
 open Evd
 open Pattern
-open Proof_trees
 open Coqlib
-(*i*)
 
-(*s Given a term with second-order variables in it,
+(** High-order patterns *)
+
+(** Given a term with second-order variables in it,
    represented by Meta's, and possibly applied using SoApp
    terms, this function will perform second-order, binding-preserving,
    matching, in the case where the pattern is a pattern in the sense
@@ -38,7 +35,7 @@ open Coqlib
    intersection of the free-rels of the term and the current stack be
    contained in the arguments of the application *)
 
-(*s I implemented the following functions which test whether a term [t]
+(** I implemented the following functions which test whether a term [t]
    is an inductive but non-recursive type, a general conjuction, a
    general disjunction, or a type with no constructors.
 
@@ -53,36 +50,36 @@ type testing_function = constr -> bool
 val match_with_non_recursive_type : (constr * constr list) matching_function
 val is_non_recursive_type         : testing_function
 
-(* Non recursive type with no indices and exactly one argument for each
+(** 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
 
-(* Non recursive tuple (one constructor and no indices) with no inner
+(** 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
 
-(* Non recursive tuple, possibly with inner dependencies *)
+(** Non recursive tuple, possibly with inner dependencies *)
 val match_with_record      : (constr * constr list) matching_function
 val is_record              : testing_function
 
-(* Like record but supports and tells if recursive (e.g. Acc) *)
+(** 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 *)
+(** No constructor, possibly with indices *)
 val match_with_empty_type  : constr matching_function
 val is_empty_type          : testing_function
 
-(* type with only one constructor and no arguments, possibly with indices *)
+(** 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
 
-(* type with only one constructor and no arguments, no indices *)
+(** type with only one constructor and no arguments, no indices *)
 val is_unit_type           : testing_function
 
-(* type with only one constructor, no arguments and at least one dependency *)
+(** 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
@@ -96,7 +93,7 @@ val is_forall_term            : testing_function
 val match_with_imp_term    : (constr * constr) matching_function
 val is_imp_term            : testing_function
 
-(* I added these functions to test whether a type contains dependent
+(** I added these functions to test whether a type contains dependent
   products or not, and if an inductive has constructors with dependent types
  (excluding parameters). this is useful to check whether a conjunction is a
  real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *)
@@ -110,7 +107,7 @@ 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 *)
+(** Recongnize inductive relation defined by reflexivity *)
 
 type equation_kind =
   | MonomorphicLeibnizEq of constr * constr
@@ -124,37 +121,37 @@ val match_with_equation:
 
 (***** Destructing patterns bound to some theory *)
 
-(* 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 *)
+(** 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 *)
+(** 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)
 
-(* A variant that returns more informative structure on the equality found *)
+(** 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] *)
+(** Match a term of the form [(existT A P t p)] 
+   Returns associated lemmas and [A,P,t,p] *)
 val find_sigma_data_decompose : constr ->
   coq_sigma_data * (constr * constr * constr * constr)
 
-(* Match a term of the form [{x:A|P}], returns [A] and [P] *)
+(** Match a term of the form [{x:A|P}], returns [A] and [P] *)
 val match_sigma : constr -> constr * constr
 
 val is_matching_sigma : constr -> bool
 
-(* Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
+(** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
    [t,u,T] and a boolean telling if equality is on the left side *)
 val match_eqdec : constr -> bool * constr * constr * constr * constr
 
-(* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
+(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
 open Proof_type
 open Tacmach
 val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr)
 
-(* Match a negation *)
+(** Match a negation *)
 val is_matching_not : constr -> bool
 val is_matching_imp_False : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 37142f30..2ae4e22e 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -34,7 +32,7 @@ open Equality
 open Typing
 open Pattern
 open Matching
-open Rawterm
+open Glob_term
 open Genarg
 open Tacexpr
 
@@ -333,7 +331,9 @@ let projectAndApply thin id eqname names depids gls =
   substHypIfVariable
     (* If no immediate variable in the equation, try to decompose it *)
     (* and apply a trailer which again try to substitute *)
-    (fun id -> dEqThen false (deq_trailer id) (Some (ElimOnIdent (dummy_loc,id))))
+    (fun id ->
+      dEqThen false (deq_trailer id)
+	(Some (ElimOnConstr (mkVar id,NoBindings))))
     id
     gls
 
diff --git a/tactics/inv.mli b/tactics/inv.mli
index 43e2a8de..ef828d88 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inv.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Tacmach
 open Genarg
 open Tacexpr
-open Rawterm
-(*i*)
+open Glob_term
 
 type inversion_status = Dep of constr option | NoDep
 
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 2544a4be..1697c146 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: leminv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -24,7 +22,6 @@ open Entries
 open Inductiveops
 open Environ
 open Tacmach
-open Proof_trees
 open Proof_type
 open Pfedit
 open Evar_refiner
@@ -37,8 +34,6 @@ open Vernacexpr
 open Safe_typing
 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 " ++
      pr_lconstr_env env constr ++
@@ -89,18 +84,6 @@ let no_inductive_inconstr env constr =
 
  *)
 
-let thin_ids env (hyps,vars) =
-  fst
-    (List.fold_left
-       (fun ((ids,globs) as sofar) (id,c,a) ->
-          if List.mem id globs then
-	    match c with
-	      | None -> (id::ids,(global_vars env a)@globs)
-	      | Some body ->
-                  (id::ids,(global_vars env body)@(global_vars env a)@globs)
-          else sofar)
-       ([],vars) hyps)
-
 (* returns the sub_signature of sign corresponding to those identifiers that
  * are not global. *)
 (*
@@ -192,10 +175,6 @@ 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
@@ -221,29 +200,32 @@ let inversion_scheme env sigma t sort dep_option inv_op =
     errorlabstrm "lemma_inversion"
     (str"Computed inversion goal was not closed in initial signature.");
   *)
-  let invSign = named_context_val invEnv in
-  let pfs = mk_pftreestate (mk_goal invSign invGoal None) in
-  let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in
-  let (pfterm,meta_types) = extract_open_pftreestate pfs in
+  let pf = Proof.start [invEnv,invGoal] in
+  Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf;
+  let pfterm = List.hd (Proof.partial_proof pf) in
   let global_named_context = Global.named_context () in
-  let ownSign =
+  let ownSign = ref begin
     fold_named_context
       (fun env (id,_,_ as d) sign ->
          if mem_named_context id global_named_context then sign
 	 else add_named_decl d sign)
       invEnv ~init:empty_named_context
+  end in
+  let avoid = ref [] in
+  let { sigma=sigma } = Proof.V82.subgoals pf in
+  let rec fill_holes c =
+    match kind_of_term c with
+    | Evar (e,args) ->
+	let h = next_ident_away (id_of_string "H") !avoid in
+	let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in
+	avoid := h::!avoid;
+	ownSign := add_named_decl (h,None,ty) !ownSign;
+	applist (mkVar h, inst)
+    | _ -> map_constr fill_holes c
   in
-  let (_,ownSign,mvb) =
-    List.fold_left
-      (fun (avoid,sign,mvb) (mv,mvty) ->
-         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
-  in
-  let invProof =
-    it_mkNamedLambda_or_LetIn
-      (local_strong (fun _ -> whd_meta_from_map mvb) Evd.empty pfterm) ownSign
+  let c = fill_holes pfterm in
+  (* warning: side-effect on ownSign *)
+  let invProof = it_mkNamedLambda_or_LetIn c !ownSign
   in
   invProof
 
@@ -253,32 +235,23 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
     declare_constant name
     (DefinitionEntry
        { const_entry_body = invProof;
+         const_entry_secctx = None;
          const_entry_type = None;
-         const_entry_opaque = false;
-	 const_entry_boxed = true && (Flags.boxed_definitions())},
+         const_entry_opaque = false },
      IsProof Lemma)
   in ()
 
-(* open Pfedit *)
-
 (* inv_op = Inv (derives de complete inv. lemma)
  * inv_op = InvNoThining (derives de semi inversion lemma) *)
 
 let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op =
   let pts = get_pftreestate() in
-  let gl = nth_goal_of_pftreestate n pts in
+  let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
+  let gl = { it = List.nth gls (n-1) ; sigma=sigma } in
   let t =
     try pf_get_hyp_typ gl id
     with Not_found -> Pretype_errors.error_var_not_found_loc loc id in
   let env = pf_env gl and sigma = project gl in
-(* Pourquoi ???
-  let fv = global_vars env t in
-  let thin_ids = thin_ids (hyps,fv) in
-  if not(list_subset thin_ids fv) then
-    errorlabstrm "lemma_inversion"
-      (str"Cannot compute lemma inversion when there are" ++ spc () ++
-	 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 =
@@ -296,11 +269,10 @@ let add_inversion_lemma_exn na com comsort bool tac =
 (* ================================= *)
 
 let lemInv id c gls =
-  ignore (pf_get_hyp gls id); (* ensure id exists *)
   try
     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
+    Clenvtac.res_pf clause ~flags:Unification.elim_flags gls
   with
     | NoSuchBinding ->
 	errorlabstrm ""
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index b4b5737b..233aeba3 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -1,7 +1,7 @@
 open Util
 open Names
 open Term
-open Rawterm
+open Glob_term
 open Proof_type
 open Topconstr
 
@@ -15,5 +15,5 @@ val inversion_lemma_from_goal :
   int -> identifier -> identifier located -> sorts -> bool ->
     (identifier -> tactic) -> unit
 val add_inversion_lemma_exn :
-  identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) ->
+  identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) ->
     unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index 19df4ff1..4e34fae8 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nbtermdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
index e655b6e3..652ff4f4 100644
--- a/tactics/nbtermdn.mli
+++ b/tactics/nbtermdn.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nbtermdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Libnames
-(*i*)
 
-(* Named, bounded-depth, term-discrimination nets. *)
+(** Named, bounded-depth, term-discrimination nets. *)
 module Make :
   functor (Y:Map.OrderedType) ->
 sig
diff --git a/tactics/refine.ml b/tactics/refine.ml
index c1b1fe9d..e7f3998a 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refine.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* JCF -- 6 janvier 1998  EXPERIMENTAL *)
 
 (*
@@ -114,8 +112,6 @@ let replace_by_meta env sigma = function
 	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)"
         *)
       in
-      if occur_meta ty then
-	error "Unable to manage a dependent metavariable of higher-order type.";
       mkCast (m,DEFAULTcast, ty),[n,ty],[Some th]
 
 exception NoMeta
@@ -197,8 +193,6 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       end
 
   | Case (ci,p,cc,v) ->
-      if occur_meta p then
-       error "Unable to manage a metavariable in the return clause of a match.";
       (* bof... *)
       let nbr = Array.length v in
       let v = Array.append [|p;cc|] v in
@@ -401,5 +395,3 @@ let refine (evd,c) gl =
      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
-
-let _ = Decl_proof_instr.set_refine refine (* dirty trick to solve circular dependency *)
diff --git a/tactics/refine.mli b/tactics/refine.mli
index 15491616..a96f47ba 100644
--- a/tactics/refine.mli
+++ b/tactics/refine.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refine.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacmach
 
 val refine : Evd.open_constr -> tactic
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
index fd3eeeb2..d297969d 100644
--- a/tactics/rewrite.ml4
+++ b/tactics/rewrite.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: rewrite.ml4 11981 2009-03-16 08:18:53Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,7 +18,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -29,7 +26,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 open Typeclasses
 open Typeclasses_errors
@@ -39,21 +36,16 @@ open Pfedit
 open Command
 open Libnames
 open Evd
+open Compat
 
 (** 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"]
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
 
 let proper_class =
   lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper"))))
@@ -61,7 +53,7 @@ let proper_class =
 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 proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 
@@ -73,28 +65,21 @@ 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 coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def")
 let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
 let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
-let 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")
@@ -102,18 +87,14 @@ let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse"
 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")
 
@@ -121,25 +102,13 @@ let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "rela
 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 Lazy.force arrow
 
-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)
@@ -167,14 +136,14 @@ 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 new_goal_evar (goal,cstr) env t =
+  let goal', t = Evarutil.new_evar goal env t in
+    (goal', cstr), t
+
 let build_signature evars env m (cstrs : (types * types option) option list)
     (finalcstr : (types * types option) option) =
   let new_evar evars env t =
@@ -220,11 +189,17 @@ let proper_proof env evars carrier relation x =
   let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |])
   in new_cstr_evar evars env goal
 
+let extends_undefined evars evars' =
+  let f ev evi found = found || not (Evd.mem evars ev)
+  in fold_undefined f evars' false
+  
+
 let find_class_proof proof_type proof_method env evars carrier relation =
   try
     let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
-    let evars, c = Typeclasses.resolve_one_typeclass env evars goal in
-      mkApp (Lazy.force proof_method, [| carrier; relation; c |])
+    let evars', c = Typeclasses.resolve_one_typeclass env evars goal in
+      if extends_undefined evars evars' then raise Not_found
+      else mkApp (Lazy.force proof_method, [| carrier; relation; c |])
   with e when Logic.catchable_exception e -> raise Not_found
 
 let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
@@ -247,10 +222,14 @@ type hypinfo = {
   l2r : bool;
   c1 : constr;
   c2 : constr;
-  c  : constr with_bindings option;
+  c  : (Tacinterp.interp_sign * Genarg.glob_constr_and_expr with_bindings) option;
   abs : (constr * types) option;
+  flags : Unification.unify_flags;
 }
 
+let goalevars evars = fst evars
+let cstrevars evars = snd evars
+
 let evd_convertible env evd x y =
   try ignore(Evarconv.the_conv_x env x y evd); true
   with _ -> false
@@ -270,10 +249,14 @@ let rec decompose_app_rel env evd t =
 	in (f'', args)
   | _ -> error "The term provided is not an applied relation."
 
-let decompose_applied_relation env sigma (c,l) left2right =
-  let ctype = Typing.type_of env sigma c in
+(*   let nc, c', cl = push_rel_context_to_named_context env c in *)
+(*   let env' = reset_with_named_context nc env in *)
+
+let decompose_applied_relation env sigma flags orig (c,l) left2right =
+  let c' = c in
+  let ctype = Typing.type_of env sigma c' in
   let find_rel ty =
-    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c,ty) l in
+    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
     let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in
     let c1 = args.(0) and c2 = args.(1) in 
     let ty1, ty2 =
@@ -283,7 +266,8 @@ let decompose_applied_relation env sigma (c,l) left2right =
       else
 	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
 	       car=ty1; rel = equiv;
-	       l2r=left2right; c1=c1; c2=c2; c=Some (c,l); abs=None }
+	       l2r=left2right; c1=c1; c2=c2; c=orig; abs=None;
+	       flags = flags }
   in
     match find_rel ctype with
     | Some c -> c
@@ -293,44 +277,81 @@ let decompose_applied_relation env sigma (c,l) left2right =
 	| 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;
-}
+open Tacinterp
+let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right =
+  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in
+    decompose_applied_relation env sigma flags (Some (is, (c,l))) cbl left2right
+
+let rewrite_db = "rewrite"
 
 let conv_transparent_state = (Idpred.empty, Cpred.full)
 
-let rewrite2_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-  Unification.use_metas_eagerly = true;
+let _ = 
+  Auto.add_auto_init
+    (fun () ->
+       Auto.create_hint_db false rewrite_db conv_transparent_state true)
+
+let rewrite_transparent_state () =
+  Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db)
+
+let rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
   Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
   Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = ExistentialSet.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = true
 }
 
-let 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 rewrite2_unif_flags = 
+  {  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+     Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+     Unification.modulo_delta = empty_transparent_state;
+     Unification.modulo_delta_types = conv_transparent_state;
+     Unification.check_applied_meta_types = true;
+     Unification.resolve_evars = true;
+     Unification.use_pattern_unification = true;
+     Unification.use_meta_bound_pattern_unification = true;
+     Unification.frozen_evars = ExistentialSet.empty;
+     Unification.restrict_conv_on_strict_subterms = false;
+     Unification.modulo_betaiota = true;
+     Unification.modulo_eta = true;
+     Unification.allow_K_in_toplevel_higher_order_unification = true
+  }
+
+let general_rewrite_unif_flags () = 
+  let ts = rewrite_transparent_state () in
+    {  Unification.modulo_conv_on_closed_terms = Some ts;
+       Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+       Unification.modulo_delta = ts;
+       Unification.modulo_delta_types = ts;
+       Unification.check_applied_meta_types = true;
+       Unification.resolve_evars = true;
+       Unification.use_pattern_unification = true;
+       Unification.use_meta_bound_pattern_unification = true;
+       Unification.frozen_evars = ExistentialSet.empty;
+       Unification.restrict_conv_on_strict_subterms = false;
+       Unification.modulo_betaiota = true;
+       Unification.modulo_eta = true;
+       Unification.allow_K_in_toplevel_higher_order_unification = true }
 
 let convertible env evd x y =
   Reductionops.is_conv env evd x y
 
-let allowK = true
-
 let refresh_hypinfo env sigma hypinfo =
   if hypinfo.abs = None then
-    let {l2r=l2r; c=c;cl=cl} = hypinfo in
+    let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in
       match c with
 	| Some c ->
 	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    decompose_applied_relation env cl.evd c l2r;
+	    decompose_applied_relation_expr env sigma flags c l2r;
 	| _ -> hypinfo
   else hypinfo
 
@@ -342,19 +363,13 @@ let unify_eqn env sigma hypinfo t =
     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
+	  let env' = clenv_unify ~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
+	  let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl
 	  in
+	  let env' = Clenvtac.clenv_pose_dependent_evars true env' in
+(* 	  let env' = Clenv.clenv_pose_metas_as_evars env' (Evd.undefined_metas env'.evd) in *)
 	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in
 	  let env' = { env' with evd = evd' } in
 	  let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in
@@ -365,34 +380,83 @@ let unify_eqn env sigma hypinfo t =
 	  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;
+	      if occur_meta_or_existential prf then
+		hypinfo := refresh_hypinfo env env'.evd !hypinfo;
 	      env', prf, c1, c2, car, rel)
 	    else raise Reduction.NotConvertible
     in
     let res =
       if l2r then (prf, (car, rel, c1, c2))
       else
-	try (mkApp (get_symmetric_proof env Evd.empty car rel,
+	try (mkApp (get_symmetric_proof env env'.evd car rel,
 		   [| c1 ; c2 ; prf |]),
 	    (car, rel, c2, c1))
 	with Not_found ->
 	  (prf, (car, inverse car rel, c2, c1))
-    in Some (env', res)
+    in Some (env'.evd, res)
   with e when Class_tactics.catchable e -> None
 
+(* let unify_eqn env sigma hypinfo t = *)
+(*   if isEvar t then None *)
+(*   else try *)
+(*     let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in *)
+(*     let left = if l2r then c1 else c2 in *)
+(*     let evd', prf, c1, c2, car, rel = *)
+(*       match abs with *)
+(*       | Some (absprf, absprfty) -> *)
+(* 	  let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in *)
+(* 	    env'.evd, prf, c1, c2, car, rel *)
+(*       | None -> *)
+(* 	  let cl' = Clenv.clenv_pose_metas_as_evars cl (Evd.undefined_metas cl.evd) in *)
+(* 	  let sigma = cl'.evd in *)
+(* 	  let c1 = Clenv.clenv_nf_meta cl' c1 *)
+(* 	  and c2 = Clenv.clenv_nf_meta cl' c2 *)
+(* 	  and prf = Clenv.clenv_nf_meta cl' prf *)
+(* 	  and car = Clenv.clenv_nf_meta cl' car *)
+(* 	  and rel = Clenv.clenv_nf_meta cl' rel *)
+(* 	  in *)
+(* 	  let sigma' = *)
+(* 	    try Evarconv.the_conv_x ~ts:empty_transparent_state env t c1 sigma *)
+(* 	    with Reduction.NotConvertible _ ->  *)
+(* 	      Evarconv.the_conv_x ~ts:conv_transparent_state env t c1 sigma *)
+(* 	  in *)
+(* 	  let sigma' = Evarconv.consider_remaining_unif_problems ~ts:conv_transparent_state env sigma' in *)
+(* 	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env sigma' in *)
+(* 	  let nf c = Evarutil.nf_evar evd' c in *)
+(* 	  let c1 = nf c1 and c2 = nf c2 *)
+(* 	  and car = nf car and rel = nf rel *)
+(* 	  and prf' = nf prf in *)
+(* 	    if occur_meta_or_existential prf then *)
+(* 	      hypinfo := refresh_hypinfo env evd' !hypinfo; *)
+(* 	    evd', prf', c1, c2, car, rel *)
+(*     in *)
+(*     let res = *)
+(*       if l2r then (prf, (car, rel, c1, c2)) *)
+(*       else *)
+(* 	try (mkApp (get_symmetric_proof env Evd.empty car rel, *)
+(* 		   [| c1 ; c2 ; prf |]), *)
+(* 	    (car, rel, c2, c1)) *)
+(* 	with Not_found -> *)
+(* 	  (prf, (car, inverse car rel, c2, c1)) *)
+(*     in Some (evd', res) *)
+(*   with Reduction.NotConvertible -> None *)
+(*   | e when Class_tactics.catchable e -> None *)
+
 let unfold_impl t =
   match kind_of_term t with
     | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
 	mkProd (Anonymous, a, lift 1 b)
     | _ -> assert false
 
-let unfold_id t =
+let unfold_all t =
   match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+	(match kind_of_term b with
+	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
+	  | _ -> assert false)
     | _ -> assert false
 
-let unfold_all t =
+let unfold_forall t =
   match kind_of_term t with
     | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
 	(match kind_of_term b with
@@ -400,9 +464,6 @@ let unfold_all t =
 	  | _ -> 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
@@ -430,31 +491,35 @@ let pointwise_or_dep_relation n t car rel =
     mkApp (Lazy.force forall_relation, 
 	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
 
-let lift_cstr env sigma evars (args : constr list) ty cstr =
+let lift_cstr env sigma evars (args : constr list) c ty cstr =
   let start env car =
     match cstr with
     | None | Some (_, None) ->
 	Evarutil.e_new_evar evars env (mk_relation car)
     | Some (ty, Some rel) -> rel
   in
-  let rec aux env prod n args = 
-    if n = 0 then Some (start env prod)
+  let rec aux env prod n = 
+    if n = 0 then start env prod
     else
       match kind_of_term (Reduction.whd_betadeltaiota env prod) with
       | Prod (na, ty, b) ->
 	  if noccurn 1 b then
 	    let b' = lift (-1) b in
-	    let rb = aux env b' (pred n) (List.tl args) in
-	      Option.map (fun rb -> mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]))
-		rb
+	    let rb = aux env b' (pred n) in
+	      mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
 	  else
-	    let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) (List.tl args) in
-	      Option.map 
-		(fun rb -> mkApp (Lazy.force forall_relation, 
-				  [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]))
-		rb
-      | _ -> None
-  in Option.map (fun rel -> (ty, rel)) (aux env ty (List.length args) args)
+	    let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in
+	      mkApp (Lazy.force forall_relation, 
+		    [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |])
+      | _ -> raise Not_found
+  in 
+  let rec find env c ty = function
+    | [] -> None
+    | arg :: args ->
+	try Some (aux env ty (succ (List.length args)), c, ty, arg :: args)
+	with Not_found ->
+	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
+  in find env c ty args
 
 let unlift_cstr env sigma = function
   | None -> None
@@ -470,7 +535,7 @@ type rewrite_proof =
   | RewPrf of constr * constr
   | RewCast of cast_kind
 
-let get_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
 
 type rewrite_result_info = {
   rew_car : constr;
@@ -482,16 +547,21 @@ type rewrite_result_info = {
 
 type rewrite_result = rewrite_result_info option
 
-type strategy = Environ.env -> evar_map -> constr -> types ->
+type strategy = Environ.env -> identifier list -> constr -> types ->
   constr option -> evars -> rewrite_result option
 
+let get_rew_rel r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel
+  | RewCast c -> mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |])
+
 let get_rew_prf r = match r.rew_prf with
-  | RewPrf (rel, prf) -> prf 
+  | RewPrf (rel, prf) -> rel, prf 
   | RewCast c ->
-      mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
-	     c, mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |]))
+    let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
+		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
 
-let resolve_subrelation env sigma car rel prf rel' res =
+let resolve_subrelation env avoid car rel prf rel' res =
   if eq_constr rel rel' then res
   else
 (*   try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *)
@@ -504,15 +574,15 @@ let resolve_subrelation env sigma car rel prf rel' res =
 	rew_prf = RewPrf (rel', appsub);
 	rew_evars = evars }
 
-let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars =
   let evars, morph_instance, proj, sigargs, m', args, args' =
     let first = try (array_find args' (fun i b -> b <> None)) 
       with Not_found -> raise (Invalid_argument "resolve_morphism") in
     let morphargs, morphobjs = array_chop first args in
     let morphargs', morphobjs' = array_chop first args' in
     let appm = mkApp(m, morphargs) in
-    let appmtype = Typing.type_of env sigma appm in
-    let cstrs = List.map (Option.map (fun r -> r.rew_car, get_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
+    let appmtype = Typing.type_of env (goalevars evars) appm in
+    let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
       (* Desired signature *)
     let evars, appmtype', signature, sigargs = 
       build_signature evars env appmtype cstrs cstr
@@ -540,7 +610,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
 		  let evars, proof = proper_proof env evars carrier relation x in
 		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
 	      | Some r ->
-		  [ get_rew_prf r; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
 	  | None ->
 	      if y <> None then error "Cannot rewrite the argument of a dependent function";
 	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
@@ -552,10 +622,10 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
 	[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
       | _ -> assert(false)
 
-let apply_constraint env sigma car rel prf cstr res =
+let apply_constraint env avoid car rel prf cstr res =
   match cstr with
   | None -> res
-  | Some r -> resolve_subrelation env sigma car rel prf r res
+  | Some r -> resolve_subrelation env avoid car rel prf r res
 
 let eq_env x y = x == y
 
@@ -564,29 +634,27 @@ let apply_rule hypinfo loccs : strategy =
   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
+    fun env avoid t ty cstr evars ->
+      if not (eq_env !hypinfo.cl.env env) then
+	hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo;
+      let unif = unify_eqn env (goalevars evars) hypinfo t in
 	if unif <> None then incr occ;
 	match unif with
-	| Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ ->
+	| Some (evd', (prf, (car, rel, c1, c2))) when is_occ !occ ->
 	    begin
 	      if eq_constr t c2 then Some None
 	      else
-		let goalevars = Evd.evar_merge (fst evars)
-		  (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd))
-		in
 		let res = { rew_car = ty; rew_from = c1;
-			    rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars }
-		in Some (Some (apply_constraint env sigma car rel prf cstr res))
+			    rew_to = c2; rew_prf = RewPrf (rel, prf); 
+			    rew_evars = evd', cstrevars evars }
+		in Some (Some (apply_constraint env avoid car rel prf cstr res))
 	    end
 	| _ -> None
 
-let apply_lemma (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 apply_lemma flags (evm,c) left2right loccs : strategy =
+  fun env avoid t ty cstr evars ->
+    let hypinfo = ref (decompose_applied_relation env (goalevars evars) flags None c left2right) in
+      apply_rule hypinfo loccs env avoid t ty cstr evars
 
 let make_leibniz_proof c ty r =
   let prf = 
@@ -658,9 +726,15 @@ let unfold_match env sigma sk app =
       let v = Environ.constant_value (Global.env ()) sk in
 	Reductionops.whd_beta sigma (mkApp (v, args))
   | _ -> app
-    
+
+let is_rew_cast = function RewCast _ -> true | _ -> false
+
+let coerce env avoid cstr res = 
+  let rel, prf = get_rew_prf res in
+    apply_constraint env avoid res.rew_car rel prf cstr res
+
 let subterm all flags (s : strategy) : strategy =
-  let rec aux env sigma t ty cstr evars =
+  let rec aux env avoid t ty cstr evars =
     let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
       match kind_of_term t with
       | App (m, args) ->
@@ -670,7 +744,7 @@ let subterm all flags (s : strategy) : strategy =
 		(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
+		    let res = s env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in
 		      match res with
 		      | Some None -> (None :: acc, evars, if progress = None then Some false else progress)
 		      | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true)
@@ -682,19 +756,38 @@ let subterm all flags (s : strategy) : strategy =
 	      | 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_from = c1;
-			      rew_to = c2; rew_prf = RewPrf (rel, prf);
-			      rew_evars = evars' } 
-		  in
-		    Some (Some res)
+		    if array_exists
+		      (function 
+			 | None -> false 
+			 | Some r -> not (is_rew_cast r.rew_prf)) args'
+		    then
+		      let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in
+		      let res = { rew_car = ty; rew_from = c1;
+				  rew_to = c2; rew_prf = RewPrf (rel, prf);
+				  rew_evars = evars' } 
+		      in Some (Some res)
+		    else 
+		      let args' = array_map2
+			(fun aorig anew ->
+			   match anew with None -> aorig
+			   | Some r -> r.rew_to) args args' 
+		      in
+		      let res = { rew_car = ty; rew_from = t;
+				  rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast;
+				  rew_evars = evars' }
+		      in Some (Some res)
+
 	  in
 	    if flags.on_morphisms then
 	      let evarsref = ref (snd evars) in
-	      let mty = Typing.type_of env sigma m in
-	      let argsl = Array.to_list args in
-	      let cstr' = lift_cstr env sigma evarsref argsl mty None in
-	      let m' = s env sigma m mty (Option.map snd cstr') (fst evars, !evarsref) in
+	      let mty = Typing.type_of env (goalevars evars) m in
+	      let cstr', m, mty, argsl, args = 
+		let argsl = Array.to_list args in
+		  match lift_cstr env (goalevars evars) evarsref argsl m mty None with
+		  | Some (cstr', m, mty, args) -> Some cstr', m, mty, args, Array.of_list args
+		  | None -> None, m, mty, argsl, args
+	      in
+	      let m' = s env avoid m mty cstr' (fst evars, !evarsref) in
 		match m' with
 		| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
 		| Some None -> rewrite_args (Some false)
@@ -714,14 +807,14 @@ let subterm all flags (s : strategy) : strategy =
 		    in 
 		      match prf with
 		      | RewPrf (rel, prf) ->
-			  Some (Some (apply_constraint env sigma res.rew_car rel prf cstr res))
+			Some (Some (apply_constraint env avoid res.rew_car rel prf cstr res))
 		      | _ -> Some (Some res)
 	    else rewrite_args None
-
+	      
       | Prod (n, x, b) when noccurn 1 b ->
 	  let b = subst1 mkProp b in
-	  let tx = Typing.type_of env 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
+	  let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in
+	  let res = aux env avoid (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)
@@ -740,22 +833,28 @@ let subterm all flags (s : strategy) : strategy =
       (* 		  in res, occ *)
       (* 		else *)
 
-      | Prod (n, dom, codom) when eq_constr ty mkProp ->
+      | Prod (n, dom, codom) ->
 	  let lam = mkLambda (n, dom, codom) in
-	  let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in
+	  let app, unfold = 
+	    if eq_constr ty mkProp then
+	      mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all
+	    else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall
+	  in
+	  let res = aux env avoid app ty cstr evars in
 	    (match res with
-	    | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to })
-	    | _ -> res)
+	     | Some (Some r) -> Some (Some { r with rew_to = unfold 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
+	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
+	  let env' = Environ.push_rel (n', None, t) env in
+	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in
 	    (match b' with
 	    | Some (Some r) ->
 		let prf = match r.rew_prf with
 		  | RewPrf (rel, prf) ->
-		      let rel = pointwise_or_dep_relation n t r.rew_car rel in
-		      let prf = mkLambda (n, t, prf) in
+		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in
+		      let prf = mkLambda (n', t, prf) in
 			RewPrf (rel, prf)
 		  | x -> x
 		in
@@ -767,38 +866,47 @@ let subterm all flags (s : strategy) : strategy =
 	    | _ -> b')
 
       | Case (ci, p, c, brs) ->
-	  let cty = Typing.type_of env sigma c in
+	  let cty = Typing.type_of env (goalevars evars) 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
+	  let c' = s env avoid c cty cstr' evars in
+	  let res = 
+	    match c' with
 	    | Some (Some r) ->
-		Some (Some (make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r))
+		let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in
+		  Some (Some (coerce env avoid cstr res))
 	    | x ->
-		if array_for_all ((=) 0) ci.ci_cstr_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 -> lift 1 br :: acc x)
-		    else
-		      match s env sigma br ty cstr evars with
-		      | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
-		      | _ -> (None, fun x -> lift 1 br :: acc x))
-		    (None, fun x -> []) brs
-		  in
-		    match found with
-		    | Some r ->
-			let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
-			  Some (Some (make_leibniz_proof ctxc ty r))
-		    | None -> x
-		else
-		  match try Some (fold_match env sigma t) with Not_found -> None with
+	      if array_for_all ((=) 0) ci.ci_cstr_ndecls then
+		let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
+		let found, brs' = Array.fold_left 
+		  (fun (found, acc) br ->
+		   if found <> None then (found, fun x -> lift 1 br :: acc x)
+		   else
+		     match s env avoid br ty cstr evars with
+		     | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
+		     | _ -> (None, fun x -> lift 1 br :: acc x))
+		  (None, fun x -> []) brs
+		in
+		  match found with
+		  | Some r ->
+		    let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
+		      Some (Some (make_leibniz_proof ctxc ty r))
 		  | None -> x
-		  | Some (cst, _, t') ->
-		      match aux env sigma t' ty cstr evars with
-		      | Some (Some prf) -> Some (Some { prf with
-			  rew_from = t; rew_to = unfold_match env sigma cst prf.rew_to })
-		      | x' -> x)
-
-      | _ -> if all then Some None else None
+	      else
+		match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+		| None -> x
+		| Some (cst, _, t') ->
+		  match aux env avoid t' ty cstr evars with
+		  | Some (Some prf) -> 
+		    Some (Some { prf with
+				 rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to })
+		  | x' -> x
+	  in 
+	    (match res with
+	     | Some (Some r) ->  
+	       let rel, prf = get_rew_prf r in
+		 Some (Some (apply_constraint env avoid r.rew_car rel prf cstr r))
+	     | x -> x)
+      | _ -> None
   in aux
 
 let all_subterms = subterm true default_flags
@@ -807,8 +915,8 @@ let one_subterm = subterm false default_flags
 (** Requires transitivity of the rewrite step, if not a reduction.
     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 (get_rew_rel res.rew_prf) res.rew_evars with
+let transitivity env avoid (res : rewrite_result_info) (next : strategy) : rewrite_result option =
+  match next env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars with
   | None -> None
   | Some None -> Some (Some res)
   | Some (Some res') ->
@@ -835,13 +943,13 @@ module Strategies =
   struct
 
     let fail : strategy =
-      fun env sigma t ty cstr evars -> None
+      fun env avoid t ty cstr evars -> None
 
     let id : strategy =
-      fun env sigma t ty cstr evars -> Some None
+      fun env avoid t ty cstr evars -> Some None
 
     let refl : strategy =
-      fun env sigma t ty cstr evars ->
+      fun env avoid t ty cstr evars ->
 	let evars, rel = match cstr with
 	  | None -> new_cstr_evar evars env (mk_relation ty)
 	  | Some r -> evars, r
@@ -854,23 +962,23 @@ module Strategies =
 		       rew_prf = RewPrf (rel, 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
+      fun env avoid t ty cstr evars ->
+	match s env avoid t ty cstr evars with
 	| None -> None
 	| Some None -> None
 	| r -> r
 
     let seq fst snd : strategy =
-      fun env sigma t ty cstr evars ->
-	match fst env sigma t ty cstr evars with
+      fun env avoid t ty cstr evars ->
+	match fst env avoid t ty cstr evars with
 	| None -> None
-	| Some None -> snd env sigma t ty cstr evars
-	| Some (Some res) -> transitivity env sigma res snd
+	| Some None -> snd env avoid t ty cstr evars
+	| Some (Some res) -> transitivity env avoid 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
+      fun env avoid t ty cstr evars ->
+	match fst env avoid t ty cstr evars with
+	| None -> snd env avoid t ty cstr evars
 	| res -> res
 
     let try_ str : strategy = choice str id
@@ -896,33 +1004,51 @@ module Strategies =
     let outermost (s : strategy) : strategy =
       fix (fun out -> choice s (one_subterm out))
 
-    let lemmas cs : strategy =
+    let lemmas flags cs : strategy =
       List.fold_left (fun tac (l,l2r) ->
-	choice tac (apply_lemma l l2r (false,[])))
+	choice tac (apply_lemma flags l l2r (false,[])))
 	fail cs
 
     let inj_open c = (Evd.empty,c)
 
     let old_hints (db : string) : strategy =
       let rules = Autorewrite.find_rewrites db in
-	lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
+	lemmas rewrite_unif_flags
+	  (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
 
     let hints (db : string) : strategy =
-      fun env sigma t ty cstr evars ->
+      fun env avoid t ty cstr evars ->
       let rules = Autorewrite.find_matches db t in
-	lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
-	  env sigma t ty cstr evars
+      let lemma hint = (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r) in
+      let lems = List.map lemma rules in
+	lemmas rewrite_unif_flags lems env avoid t ty cstr evars
 
     let reduce (r : Redexpr.red_expr) : strategy =
       let rfn, ckind = Redexpr.reduction_of_red_expr r in
-	fun env sigma t ty cstr evars ->
-	  let t' = rfn env sigma t in
+	fun env avoid t ty cstr evars ->
+	  let t' = rfn env (goalevars evars) t in
 	    if eq_constr t' t then
 	      Some None
 	    else
 	      Some (Some { rew_car = ty; rew_from = t; rew_to = t';
 			   rew_prf = RewCast ckind; rew_evars = evars })
-	  
+	
+    let fold c : strategy =
+      fun env avoid t ty cstr evars ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with _ -> error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
+			   rew_prf = RewCast DEFAULTcast; 
+			   rew_evars = sigma, cstrevars evars })
+	  with _ -> None
+  
 
 end
 
@@ -934,49 +1060,34 @@ let rewrite_strat flags occs hyp =
     Strategies.choice app (subterm true flags (fun env -> aux () env))
   in aux ()
 
-let rewrite_with {it = c; sigma = evm} 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 get_hypinfo_ids {c = opt} =
+  match opt with
+  | None -> []
+  | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids
 
-let apply_strategy (s : strategy) env sigma concl cstr evars =
+let rewrite_with flags c left2right loccs : strategy =
+  fun env avoid t ty cstr evars ->
+    let gevars = goalevars evars in
+    let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in
+    let avoid = get_hypinfo_ids !hypinfo @ avoid in
+      rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars)
+
+let apply_strategy (s : strategy) env avoid concl cstr evars =
   let res =
-    s env sigma concl (Typing.type_of env sigma concl)
-      (Option.map snd cstr) !evars
+    s env avoid
+ concl (Typing.type_of env (goalevars evars) concl)
+      (Option.map snd cstr) evars
   in
     match res with
     | None -> None
     | Some None -> Some None
     | Some (Some res) ->
-	evars := res.rew_evars;
-	Some (Some (res.rew_prf, (res.rew_car, 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)
+	Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to))
 
 let merge_evars (goal,cstr) = Evd.merge goal cstr
 let solve_constraints env evars =
-  Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars)
+  Typeclasses.resolve_typeclasses env ~split:false ~fail:true
+    (merge_evars evars)
 
 let nf_zeta =
   Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
@@ -987,12 +1098,9 @@ let map_rewprf f = function
 
 exception RewriteFailure
 
-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
+type result = (evar_map * constr option * types) option option
+
+let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
   let cstr =
     let sort = mkProp in
     let impl = Lazy.force impl in
@@ -1000,82 +1108,205 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
       | 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
+  let evars = (sigma, Evd.empty) in
+  let eq = apply_strategy strat env avoid concl (Some cstr) evars in
     match eq with
-    | Some (Some (p, (car, oldt, newt))) ->
-	(try
-	    let cstrevars = !evars in
-	    let evars = solve_constraints env cstrevars in
-	    let p = map_rewprf 
-	      (fun p -> nf_zeta env evars (Evarutil.nf_evar evars p)) 
-	      p 
-	    in
-	    let newt = Evarutil.nf_evar evars newt in
-	    let abs = Option.map (fun (x, y) ->
-	      Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in
-	    let undef = split_evars (fst cstrevars) evars in
-	    let rewtac =
-	      match is_hyp with
-	      | Some id ->
-		  (match p with
-		  | RewPrf (rel, p) ->
-		      let term =
-			match abs with
-			| None -> p
-			| Some (t, ty) ->
-			    mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
-		      in
-			cut_replacing id newt
-			  (Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
-		  | RewCast c ->
-		      change_in_hyp None newt (id, InHypTypeOnly))
-		    
-	      | None ->
-		  (match p with
-		  | RewPrf (rel, p) ->
-		      (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 |])))
-		  | RewCast c -> 
-		      change_in_concl None newt)
-	    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 (Some (p, evars, car, oldt, newt)) ->
+	let evars' = solve_constraints env evars in
+	let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in
+	let newt = Evarutil.nf_evar evars' newt in
+	let abs = Option.map (fun (x, y) ->
+				Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in
+	let evars = (* Keep only original evars (potentially instantiated) and goal evars,
+		       the rest has been defined and substituted already. *)
+(* 	  let cstrs = cstrevars evars in *)
+	    (* cstrs is small *)
+	  let gevars = goalevars evars in
+	    Evd.fold (fun ev evi acc -> 
+			if Evd.mem gevars ev then Evd.add acc ev evi
+			else acc) evars' Evd.empty
+(* 	    Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *)
+	in
+	let res =
+	  match is_hyp with
+	  | Some id ->
+	      (match p with
+	       | RewPrf (rel, p) ->
+		   let term =
+		     match abs with
+		     | None -> p
+		     | Some (t, ty) ->
+			 mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
+		   in
+		     Some (evars, Some (mkApp (term, [| mkVar id |])), newt)
+	       | RewCast c ->
+		   Some (evars, None, newt))
+		
+	  | None ->
+	      (match p with
+	       | RewPrf (rel, p) ->
+		   (match abs with
+		    | None -> Some (evars, Some p, newt)
+		    | Some (t, ty) ->
+			let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in
+			  Some (evars, Some proof, newt))
+	       | RewCast c -> Some (evars, None, newt))
+	in Some res
+    | Some None -> Some None
+    | None -> None
+		   
+let rewrite_refine (evd,c) = 
+  Tacmach.refine c
+
+let cl_rewrite_clause_tac ?abs strat meta clause gl =
+  let evartac evd = Refiner.tclEVARS evd in
+  let treat res =
+    match res with
+    | None -> raise RewriteFailure
     | Some None ->
-	tclFAIL 0 (str"setoid rewrite failed: no progress made") gl
+	tclFAIL 0 (str"setoid rewrite failed: no progress made")
+    | Some (Some (undef, p, newt)) ->
+	let tac = 
+	  match clause, p with
+	  | Some id, Some p ->
+	      cut_replacing id newt (Tacmach.refine p)
+	  | Some id, None -> 
+	      change_in_hyp None newt (id, InHypTypeOnly)
+	  | None, Some p ->
+	      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+		tclTHENLAST
+		  (Tacmach.internal_cut_no_check false name newt)
+		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
+	  | None, None -> change_in_concl None newt
+	in tclTHEN (evartac undef) tac
+  in
+  let tac =
+    try
+      let concl, is_hyp =
+	match clause with
+	| Some id -> pf_get_hyp_typ gl id, Some id
+	| None -> pf_concl gl, None
+      in
+      let sigma = project gl in
+      let concl = Evarutil.nf_evar sigma concl in 
+      let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in
+	treat res
+    with
+    | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+    | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	Refiner.tclFAIL_lazy 0
+	  (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+		 ++ fnl () ++ Himsg.explain_typeclass_error env e))
+  in tac gl
+
+open Goal
+open Environ
+
+let bind_gl_info f =
+  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
+
+let fail l s =
+  raise (Refiner.FailError (l, lazy s))
+
+let new_refine c : Goal.subgoals Goal.sensitive =
+  let refable = Goal.Refinable.make
+    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) 
+  in Goal.bind refable Goal.refine
+
+let assert_replacing id newt tac = 
+  let sens = bind_gl_info 
+    (fun concl env sigma ->
+       let nc' = 
+	 Environ.fold_named_context
+	   (fun _ (n, b, t as decl) nc' ->
+	      if n = id then (n, b, newt) :: nc'
+	      else decl :: nc')
+	   env ~init:[]
+       in
+       let reft = Refinable.make 
+	 (fun h -> 
+	    Goal.bind (Refinable.mkEvar h
+			 (Environ.reset_with_named_context (val_of_named_context nc') env) concl)
+	      (fun ev -> 
+		 Goal.bind (Refinable.mkEvar h env newt)
+		   (fun ev' ->
+		      let inst = 
+			fold_named_context
+			  (fun _ (n, b, t) inst ->
+			     if n = id then ev' :: inst
+			     else if b = None then mkVar n :: inst else inst)
+			  env ~init:[]
+		      in
+		      let (e, args) = destEvar ev in
+			Goal.return (mkEvar (e, Array.of_list inst)))))
+       in Goal.bind reft Goal.refine)
+  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
+       (Proofview.tclFOCUS 2 2 tac)
+
+let cl_rewrite_clause_newtac ?abs strat clause =
+  let treat (res, is_hyp) = 
+    match res with
     | None -> raise RewriteFailure
-
-let cl_rewrite_clause_strat strat clause gl =
+    | Some None ->
+	fail 0 (str"setoid rewrite failed: no progress made")
+    | Some (Some res) ->
+	match is_hyp, res with
+	| Some id, (undef, Some p, newt) ->
+	    assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p)))
+	| Some id, (undef, None, newt) -> 
+	    Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt))
+	| None, (undef, Some p, newt) ->
+	    let refable = Goal.Refinable.make
+	      (fun handle -> 
+		 Goal.bind env
+		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
+		      (fun ev ->
+			 Goal.Refinable.constr_of_open_constr handle true 
+			   (undef, mkApp (p, [| ev |])))))
+	    in
+	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
+	| None, (undef, None, newt) ->
+	    Proofview.tclSENSITIVE (Goal.convert_concl false newt)
+  in
+  let info =
+    bind_gl_info
+      (fun concl env sigma ->
+	 let ty, is_hyp =
+	   match clause with
+	   | Some id -> Environ.named_type id env, Some id
+	   | None -> concl, None
+	 in
+	 let res = 
+	   try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
+	   with
+	   | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	       fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+		       ++ fnl () ++ Himsg.explain_typeclass_error env e)
+	 in return (res, is_hyp))
+  in Proofview.tclGOALBINDU info (fun i -> treat i)
+  
+let cl_rewrite_clause_new_strat ?abs strat clause =
   init_setoid ();
-  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
+    try cl_rewrite_clause_newtac ?abs strat clause
     with RewriteFailure ->
-      tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
+      fail 0 (str"setoid rewrite failed: strategy failed")
+
+let cl_rewrite_clause_newtac' l left2right occs clause =
+  Proof_global.run_tactic 
+    (Proofview.tclFOCUS 1 1 
+       (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause))
+
+let 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_tac strat (mkMeta meta) clause gl
+      with RewriteFailure ->
+        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
+  cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl
 
 open Pp
 open Pcoq
@@ -1093,18 +1324,10 @@ let occurrences_of = function
 	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 evd, c = Constrintern.interp_open_constr sigma env c in
-    apply_lemma (evd, (c, NoBindings)) l2r occs env sigma
+let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars ->
+  let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in
+    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
+      l2r occs env avoid t ty cstr (evd, cstrevars evars)
 
 let interp_constr_list env sigma =
   List.map (fun c -> 
@@ -1113,13 +1336,49 @@ let interp_constr_list env sigma =
 
 open Pcoq
 
-let (wit_strategy, globwit_strategy, rawwit_strategy) =
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
+
+
+ARGUMENT EXTEND glob_constr_with_bindings 
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_TYPED AS constr_expr_with_bindings
+    RAW_PRINTED BY pr_constr_expr_with_bindings
+
+    GLOB_TYPED AS glob_constr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+   
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+let _ =
   (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))
 
 
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+
+let interp_strategy ist gl c = c
+let glob_strategy ist l = l
+let subst_strategy evm l = l
+
+
 ARGUMENT EXTEND rewstrategy TYPED AS strategy
     PRINTED BY pr_strategy
     INTERPRETED BY interp_strategy
@@ -1146,57 +1405,62 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy
   | [ "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 ]
-  | [ "eval" red_expr(r) ] -> [ fun env sigma -> 
-      Strategies.reduce (Tacinterp.interp_redexp env sigma r) env sigma ]
+  | [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars -> 
+      Strategies.lemmas rewrite_unif_flags (interp_constr_list env (goalevars evars) h) env avoid t ty cstr evars ]
+  | [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars -> 
+      Strategies.reduce (Tacinterp.interp_redexp env (goalevars evars) r) env avoid t ty cstr evars ]
+  | [ "fold" constr(c) ] -> [ Strategies.fold c ]
 END
 
-TACTIC EXTEND class_rewrite
-| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
-| [ "clrewrite" orient(o) constr_with_bindings(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) ] *)
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
 END
 
-
 let clsubstitute o c =
-  let is_tac id = match kind_of_term (fst c.it) with Var id' when id' = id -> true | _ -> false in
+  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id' = id -> true | _ -> false in
     Tacticals.onAllHypsAndConcl
       (fun cl ->
 	match cl with
 	  | Some id when is_tac id -> tclIDTAC
-	  | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
+	  | _ -> cl_rewrite_clause c o all_occurrences cl)
 
 TACTIC EXTEND substitute
-| [ "substitute" orient(o) constr_with_bindings(c) ] -> [ clsubstitute o c ]
+| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ]
 END
 
 
 (* Compatibility with old Setoids *)
 
 TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(o) constr_with_bindings(c) ]
+   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
    -> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
       [ cl_rewrite_clause c o all_occurrences (Some id)]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
       [ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
       [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
       [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
 END
 
-(* let 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 cl_rewrite_clause_newtac_tac c o occ cl gl =
+  cl_rewrite_clause_newtac' c o occ cl;
+  tclIDTAC gl
+  
+TACTIC EXTEND GenRew
+| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
+    [ cl_rewrite_clause_newtac_tac c o all_occurrences (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) ] ->
+    [ cl_rewrite_clause_newtac_tac c o all_occurrences None ]
+END
 
 let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l)
 
@@ -1207,78 +1471,75 @@ let declare_an_instance n 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 anew_instance global binders instance fields =
+  new_instance binders instance (Some (CRecord (dummy_loc,None,fields)))
+    ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None
 
-let 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 declare_instance_refl global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
-  in anew_instance binders instance
+  in anew_instance global binders instance
        [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)]
 
-let declare_instance_sym binders a aeq n lemma =
+let declare_instance_sym global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
-  in anew_instance binders instance
+  in anew_instance global binders instance
        [(Ident (dummy_loc,id_of_string "symmetry"),lemma)]
 
-let declare_instance_trans binders a aeq n lemma =
+let declare_instance_trans global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
-  in anew_instance binders instance
+  in anew_instance global 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 global = not (Vernacexpr.use_section_locality ()) in
   let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
-  in ignore(anew_instance binders instance []);
+  in ignore(anew_instance global binders instance []);
   match (refl,symm,trans) with
       (None, None, None) -> ()
     | (Some lemma1, None, None) ->
-	ignore (declare_instance_refl binders a aeq n lemma1)
+	ignore (declare_instance_refl global binders a aeq n lemma1)
     | (None, Some lemma2, None) ->
-	ignore (declare_instance_sym binders a aeq n lemma2)
+	ignore (declare_instance_sym global binders a aeq n lemma2)
     | (None, None, Some lemma3) ->
-	ignore (declare_instance_trans binders a aeq n lemma3)
+	ignore (declare_instance_trans global 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)
+	ignore (declare_instance_refl global binders a aeq n lemma1);
+	ignore (declare_instance_sym global binders a aeq n lemma2)
     | (Some lemma1, None, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
 	in ignore(
-	    anew_instance binders instance
+	    anew_instance global binders instance
 	      [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1);
 	       (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)])
     | (None, Some lemma2, Some lemma3) ->
-	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
 	in ignore(
-	    anew_instance binders instance
+	    anew_instance global binders instance
 	      [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2);
 	       (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)])
      | (Some lemma1, Some lemma2, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl 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 _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
 	in ignore(
-	  anew_instance binders instance
+	  anew_instance global binders instance
 	    [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1);
 	     (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
 	     (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
 
 type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
 
-let (wit_binders : Genarg.tlevel binders_argtype),
-  (globwit_binders : Genarg.glevel binders_argtype),
-  (rawwit_binders : Genarg.rlevel binders_argtype) =
-  Genarg.create_arg "binders"
+let _, _, rawwit_binders =
+ (Genarg.create_arg "binders" :
+    Genarg.tlevel binders_argtype *
+    Genarg.glevel binders_argtype *
+    Genarg.rlevel binders_argtype)
 
 open Pcoq.Constr
 
@@ -1349,9 +1610,6 @@ VERNAC COMMAND EXTEND AddParametricRelation3
       [ 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
@@ -1392,9 +1650,9 @@ let declare_projection n instance_id r =
   let typ = it_mkProd_or_LetIn typ ctx in
   let cst =
     { const_entry_body = term;
+      const_entry_secctx = None;
       const_entry_type = Some typ;
-      const_entry_opaque = false;
-      const_entry_boxed = false }
+      const_entry_opaque = false }
   in
     ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
 
@@ -1441,14 +1699,14 @@ let default_morphism sign m =
   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 =
+let add_setoid global 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 _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
+  let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
   let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
   in ignore(
-    anew_instance binders instance
+    anew_instance global binders instance
       [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
        (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
        (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
@@ -1458,8 +1716,8 @@ let add_morphism_infer glob m n =
   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)
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
+				(Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
       in
 	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
 	declare_projection n instance_id (ConstRef cst)
@@ -1487,14 +1745,14 @@ let add_morphism glob binders m s n =
 	     [cHole; s; m]))
   in
   let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
-    ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[]))
+    ignore(new_instance ~global:glob binders instance (Some (CRecord (dummy_loc,None,[])))
 	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
 
 VERNAC COMMAND EXTEND AddSetoid1
    [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [ add_setoid [] a aeq t n ]
+     [ add_setoid (not (Vernacexpr.use_section_locality ())) [] a aeq t n ]
   | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [	add_setoid binders a aeq t n ]
+     [	add_setoid (not (Vernacexpr.use_section_locality ())) binders a aeq t n ]
   | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
       [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ]
   | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
@@ -1529,40 +1787,43 @@ let check_evar_map_of_evars_defs evd =
          check_freemetas_is_empty rebus2 freemetas2
    ) metas
 
-let unification_rewrite l2r c1 c2 cl car rel but gl =
+let unification_rewrite flags l2r c1 c2 cl car rel but gl =
   let env = pf_env gl in
   let (evd',c') =
     try
       (* ~flags:(false,true) to allow to mark occurrences that must not be
          rewritten simply by replacing them with let-defined definitions
          in the context *)
-      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd
+      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env cl.evd ((if l2r then c1 else c2),but)
     with
 	Pretype_errors.PretypeError _ ->
 	  (* ~flags:(true,true) to make Ring work (since it really
              exploits conversion) *)
-	  Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags
-	    env ((if l2r then c1 else c2),but) cl.evd
+	  Unification.w_unify_to_subterm ~flags:flags
+	    env cl.evd ((if l2r then c1 else c2),but)
   in
   let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in
   let cl' = {cl with evd = evd'} in
-  let cl' =
-    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 cl' = Clenvtac.clenv_pose_dependent_evars true cl' in
+  let nf c = Evarutil.nf_evar cl'.evd (Clenv.clenv_nf_meta cl' c) in
   let c1 = if l2r then nf c' else nf c1
   and c2 = if l2r then nf c2 else nf c'
   and car = nf car and rel = nf rel in
   check_evar_map_of_evars_defs cl'.evd;
   let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in
   let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
-    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)}
+    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty);
+     flags = flags}
 
 let get_hyp gl evars (c,l) clause l2r =
-  let hi = decompose_applied_relation (pf_env gl) evars (c,l) 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 flags = rewrite2_unif_flags in
+  let hi = decompose_applied_relation (pf_env gl) evars flags None (c,l) l2r in
+  let but = match clause with
+    | Some id -> pf_get_hyp_typ gl id 
+    | None -> Evarutil.nf_evar evars (pf_concl gl)
+  in
+    { unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl with
+	flags = rewrite_unif_flags }
 
 let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
 
@@ -1578,13 +1839,14 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
   let meta = Evarutil.new_meta() in
   let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in
     try
-      tclTHEN
-        (Refiner.tclEVARS hypinfo.cl.evd)
-        (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl
+      tclWEAK_PROGRESS 
+	(tclTHEN
+           (Refiner.tclEVARS hypinfo.cl.evd)
+	   (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl
     with RewriteFailure ->
       let {l2r=l2r; c1=x; c2=y} = hypinfo in
 	raise (Pretype_errors.PretypeError
-		  (pf_env gl,
+		  (pf_env gl,project gl,
 		  Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl)))
 
 let general_s_rewrite_clause x =
@@ -1595,15 +1857,6 @@ let general_s_rewrite_clause x =
 
 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 =
@@ -1641,7 +1894,7 @@ let setoid_transitivity c gl =
       let proof = get_transitive_proof env evm car rel in
       match c with
       | None -> eapply proof
-      | Some c -> apply_with_bindings (proof,Rawterm.ImplicitBindings [ c ]))
+      | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ]))
     (transitivity_red true c)
 
 let setoid_symmetry_in id gl =
@@ -1721,3 +1974,35 @@ TACTIC EXTEND fold_matches
   let c' = fold_matches (pf_env gl) (project gl) c in
     change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
 END
+
+TACTIC EXTEND myapply
+| [ "myapply" global(id) constr_list(l) ] -> [ 
+    fun gl -> 
+      let gr = id in
+      let _, impls = List.hd (Impargs.implicits_of_global gr) in
+      let ty = Global.type_of_global gr in
+      let env = pf_env gl in
+      let evars = ref (project gl) in
+      let app =
+	let rec aux ty impls args args' =
+	  match impls, kind_of_term ty with
+	  | Some (_, _, (_, _)) :: impls, Prod (n, t, t') ->
+	      let arg = Evarutil.e_new_evar evars env t in
+		aux (subst1 arg t') impls args (arg :: args')
+	  | None :: impls, Prod (n, t, t') ->
+	      (match args with
+	       | [] ->
+		   if dependent (mkRel 1) t' then
+		     let arg = Evarutil.e_new_evar evars env t in
+		       aux (subst1 arg t') impls args (arg :: args')
+		   else
+		     let arg = Evarutil.mk_new_meta () in
+		       evars := meta_declare (destMeta arg) t !evars;
+		       aux (subst1 arg t') impls args (arg :: args')
+	       | arg :: args -> 
+		   aux (subst1 arg t') impls args (arg :: args'))
+	  | _, _ -> mkApp (constr_of_global gr, Array.of_list (List.rev args'))
+	in aux ty impls l []
+      in
+	tclTHEN (Refiner.tclEVARS !evars) (apply app) gl ]
+END
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 6a11384b..a41cd6e7 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml 14677 2011-11-17 22:19:38Z herbelin $ *)
-
 open Constrintern
 open Closure
 open RedFlags
@@ -17,7 +15,7 @@ open Libobject
 open Pattern
 open Matching
 open Pp
-open Rawterm
+open Glob_term
 open Sign
 open Tacred
 open Util
@@ -48,6 +46,8 @@ open Pretyping
 open Pretyping.Default
 open Extrawit
 open Pcoq
+open Compat
+open Evd
 
 let safe_msgnl s =
     try msgnl s with e ->
@@ -60,20 +60,18 @@ let error_syntactic_metavariables_not_allowed loc =
     (loc,"out_ident",
      str "Syntactic metavariables allowed only in quotations.")
 
+let error_tactic_expected loc =
+  user_err_loc (loc,"",str "Tactic expected.")
+
 let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid
 
 let skip_metaid = function
   | AI x -> x
   | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc
 
-type ltac_type =
-  | LtacFun of ltac_type
-  | LtacBasic
-  | LtacTactic
-
 (* Values for interpretation *)
 type value =
-  | VRTactic of (goal list sigma * validation) (* For Match results *)
+  | VRTactic of (goal list sigma) (* For Match results *)
                                                (* Not a true value *)
   | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
@@ -93,15 +91,15 @@ let dloc = dummy_loc
 let catch_error call_trace tac g =
   if call_trace = [] then tac g else try tac g with
   | LtacLocated _ as e -> raise e
-  | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e
+  | Loc.Exc_located (_,LtacLocated _) as e -> raise e
   | e ->
     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
+    let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
     if tail = [] then
       let loc = if loc = dloc then loc' else loc in
-      raise (Stdpp.Exc_located(loc,e'))
+      raise (Loc.Exc_located(loc,e'))
     else
-      raise (Stdpp.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
+      raise (Loc.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
 
 (* Signature for interpretation: val_interp and interpretation functions *)
 type interp_sign =
@@ -137,9 +135,9 @@ let rec pr_value env = function
   | VList (a::_) ->
       str "a list (first element is " ++ pr_value env a ++ str")"
 
-(* Transforms an id into a constr if possible, or fails *)
+(* Transforms an id into a constr if possible, or fails with Not_found *)
 let constr_of_id env id =
-  construct_reference (Environ.named_context env) id
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
 
 (* To embed tactics *)
 let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
@@ -159,25 +157,6 @@ let valueOut = function
   | ast ->
     anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
 
-(* To embed constr *)
-let constrIn t = CDynamic (dummy_loc,constr_in t)
-let constrOut = function
-  | CDynamic (_,d) ->
-    if (Dyn.tag d) = "constr" then
-      constr_out d
-    else
-      anomalylabstrm "constrOut" (str "Dynamic tag should be constr")
-  | ast ->
-    anomalylabstrm "constrOut" (str "Not a Dynamic ast")
-
-(* Globalizes the identifier *)
-let find_reference env qid =
-  (* We first look for a variable of the current proof *)
-  match repr_qualid qid with
-    | (d,id) when repr_dirpath d = [] & List.mem id (ids_of_context env)
-	-> VarRef id
-    | _ -> Nametab.locate qid
-
 (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
 let atomic_mactab = ref Idmap.empty
 let add_primitive_tactic s tac =
@@ -213,7 +192,7 @@ let _ =
       (fun (s,t) -> add_primitive_tactic s t)
       [ "idtac",TacId [];
         "fail", TacFail(ArgArg 0,[]);
-        "fresh", TacArg(TacFreshId [])
+        "fresh", TacArg(dloc,TacFreshId [])
       ]
 
 let lookup_atomic id = Idmap.find id !atomic_mactab
@@ -347,15 +326,6 @@ let intern_name l ist = function
   | Anonymous -> Anonymous
   | Name id -> Name (intern_ident l ist id)
 
-let vars_of_ist (lfun,_,_,env) =
-  List.fold_left (fun s id -> Idset.add id s)
-    (vars_of_env env) lfun
-
-let get_current_context () =
-    try Pfedit.get_current_goal_context ()
-    with e when Logic.catchable_exception e ->
-      (Evd.empty, Global.env())
-
 let strict_check = ref false
 
 let adjust_loc loc = if !strict_check then dloc else loc
@@ -402,12 +372,12 @@ let intern_ltac_variable ist = function
 
 let intern_constr_reference strict ist = function
   | Ident (_,id) as r when not strict & find_hyp id ist ->
-      RVar (dloc,id), Some (CRef r)
+      GVar (dloc,id), Some (CRef r)
   | Ident (_,id) as r when find_ctxvar id ist ->
-      RVar (dloc,id), if strict then None else Some (CRef r)
+      GVar (dloc,id), if strict then None else Some (CRef r)
   | r ->
       let loc,_ as lqid = qualid_of_reference r in
-      RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
+      GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
 
 let intern_move_location ist = function
   | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
@@ -525,12 +495,6 @@ let intern_bindings ist = function
 let intern_constr_with_bindings ist (c,bl) =
   (intern_constr ist c, intern_bindings ist bl)
 
-let intern_clause_pattern ist (l,occl) =
-  let rec check = function
-    | (hyp,l) :: rest -> (intern_hyp ist (skip_metaid hyp),l)::(check rest)
-    | [] -> []
-  in (l,check occl)
-
   (* TODO: catch ltac vars *)
 let intern_induction_arg ist = function
   | ElimOnConstr c -> ElimOnConstr (intern_constr_with_bindings ist c)
@@ -539,7 +503,7 @@ let intern_induction_arg ist = function
       if !strict_check then
 	(* If in a defined tactic, no intros-until *)
 	match intern_constr ist (CRef (Ident (dloc,id))) with
-	| RVar (loc,id),_ -> ElimOnIdent (loc,id)
+	| GVar (loc,id),_ -> ElimOnIdent (loc,id)
 	| c -> ElimOnConstr (c,NoBindings)
       else
 	ElimOnIdent (loc,id)
@@ -592,7 +556,7 @@ 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 *)
+  (* type it, so we remember the pattern as a glob_constr only *)
   (intern_constr_gen true false ist p,dummy_pat)
 
 let intern_typed_pattern_with_occurrences ist (l,p) =
@@ -735,7 +699,7 @@ let rec intern_atomic lf ist x =
       TacMutualCofix (b,intern_ident lf ist id, List.map f l)
   | TacCut c -> TacCut (intern_type ist c)
   | TacAssert (otac,ipat,c) ->
-      TacAssert (Option.map (intern_tactic ist) otac,
+      TacAssert (Option.map (intern_pure_tactic ist) otac,
                  Option.map (intern_intro_pattern lf ist) ipat,
                  intern_constr_gen false (otac<>None) ist c)
   | TacGeneralize cl ->
@@ -797,8 +761,8 @@ let rec intern_atomic lf ist x =
   | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl)
   | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl)
   | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll)
-  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl)
+  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_pure_tactic ist) t)
+  | TacConstructor (ev,n,bl) -> TacConstructor (ev,intern_or_var ist n,intern_bindings ist bl)
 
   (* Conversion *)
   | TacReduce (r,cl) ->
@@ -826,7 +790,7 @@ let rec intern_atomic lf ist x =
 	(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)
+	Option.map (intern_pure_tactic ist) by)
   | TacInversion (inv,hyp) ->
       TacInversion (intern_inversion_strength lf ist inv,
         intern_quantified_hypothesis ist hyp)
@@ -839,9 +803,9 @@ let rec intern_atomic lf ist x =
       let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
       TacAlias (loc,s,l,(dir,body))
 
-and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr)
+and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
 
-and intern_tactic_seq ist = function
+and intern_tactic_seq onlytac ist = function
   | TacAtom (loc,t) ->
       let lf = ref ist.ltacvars in
       let t = intern_atomic lf ist t in
@@ -851,50 +815,68 @@ and intern_tactic_seq ist = function
       let (l1,l2) = ist.ltacvars in
       let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in
       let l = List.map (fun (n,b) ->
-	  (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in
-      ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u)
+	  (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
+      ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
+
   | TacMatchGoal (lz,lr,lmr) ->
-      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule ist lmr)
+      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)
   | TacMatch (lz,c,lmr) ->
-      ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr)
+      ist.ltacvars,
+      TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
   | TacId l -> ist.ltacvars, TacId (intern_message ist l)
   | TacFail (n,l) ->
       ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
-  | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
-  | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
+  | TacAbstract (tac,s) ->
+      ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
   | TacThen (t1,[||],t2,[||]) ->
-      let lfun', t1 = intern_tactic_seq ist t1 in
-      let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
       lfun'', TacThen (t1,[||],t2,[||])
   | TacThen (t1,tf,t2,tl) ->
-      let lfun', t1 = intern_tactic_seq ist t1 in
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
       let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThen (t1,Array.map (intern_tactic ist') tf,intern_tactic ist' t2,
-		       Array.map (intern_tactic ist') tl)
+      lfun', TacThen (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
+		       Array.map (intern_pure_tactic ist') tl)
   | TacThens (t,tl) ->
-      let lfun', t = intern_tactic_seq ist t in
+      let lfun', t = intern_tactic_seq true ist t in
       let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThens (t, List.map (intern_tactic ist') tl)
+      lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
   | 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)
-  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_tactic ist tac)
+      ist.ltacvars, TacDo (intern_or_var ist n,intern_pure_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
+  | TacTimeout (n,tac) ->
+      ist.ltacvars, TacTimeout (intern_or_var ist n,intern_tactic onlytac ist tac)
   | TacOrelse (tac1,tac2) ->
-      ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2)
-  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l)
-  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l)
-  | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac)
-  | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
+      ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
+  | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
+  | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
+
+and intern_tactic_as_arg loc onlytac ist a =
+  match intern_tacarg !strict_check onlytac ist a with
+  | TacCall _ | TacExternal _ | Reference _ | TacDynamic _ as a -> TacArg (loc,a)
+  | Tacexp a -> a
+  | TacVoid | IntroPattern _ | Integer _
+  | ConstrMayEval _ | TacFreshId _ as a ->
+      if onlytac then error_tactic_expected loc else TacArg (loc,a)
+  | MetaIdArg _ -> assert false
+
+and intern_tactic_or_tacarg ist = intern_tactic false ist
+
+and intern_pure_tactic ist = intern_tactic true ist
 
 and intern_tactic_fun ist (var,body) =
   let (l1,l2) = ist.ltacvars in
   let lfun' = List.rev_append (Option.List.flatten var) l1 in
-  (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
+  (var,intern_tactic_or_tacarg { ist with ltacvars = (lfun',l2) } body)
 
-and intern_tacarg strict ist = function
+and intern_tacarg strict onlytac ist = function
   | TacVoid -> TacVoid
   | Reference r -> intern_non_tactic_reference strict ist r
   | IntroPattern ipat ->
@@ -907,34 +889,35 @@ and intern_tacarg strict ist = function
       let id = id_of_string s in
       if find_ltacvar id ist then
 	if istac then Reference (ArgVar (adjust_loc loc,id))
-	else ConstrMayEval (ConstrTerm (RVar (adjust_loc loc,id), None))
+	else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None))
       else error_syntactic_metavariables_not_allowed loc
   | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
   | TacCall (loc,f,l) ->
       TacCall (loc,
         intern_applied_tactic_reference ist f,
-        List.map (intern_tacarg !strict_check ist) l)
+        List.map (intern_tacarg !strict_check false ist) l)
   | TacExternal (loc,com,req,la) ->
-      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la)
+      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check false ist) la)
   | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x)
-  | Tacexp t -> Tacexp (intern_tactic ist t)
+  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
   | TacDynamic(loc,t) as x ->
       (match Dyn.tag t with
-	| "tactic" | "value" | "constr" -> x
+	| "tactic" | "value" -> x
+        | "constr" -> if onlytac then error_tactic_expected loc else x
 	| s -> anomaly_loc (loc, "",
                  str "Unknown dynamic: <" ++ str s ++ str ">"))
 
 (* Reads the rules of a Match Context or a Match *)
-and intern_match_rule ist = function
+and intern_match_rule onlytac ist = function
   | (All tc)::tl ->
-      All (intern_tactic ist tc) :: (intern_match_rule ist tl)
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
   | (Pat (rl,mp,tc))::tl ->
       let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
       let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
       let ido,metas2,pat = intern_pattern ist lfun mp in
       let metas = list_uniquize (metas1@metas2) in
       let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in
-      Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
   | [] -> []
 
 and intern_genarg ist x =
@@ -990,30 +973,16 @@ and intern_genarg ist x =
       match tactic_genarg_level s with
       | Some n ->
           (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n) (intern_tactic ist
+          in_gen (globwit_tactic n) (intern_tactic_or_tacarg ist
 	    (out_gen (rawwit_tactic n) x))
       | None ->
           lookup_genarg_glob s ist x
 
-let intern_pure_tactic ist a =
-  match intern_tactic ist a with
-  | TacArg (TacCall _ | TacExternal _ | Reference _ | TacDynamic _ | Tacexp _) as a -> a
-  | TacArg _ | TacFun _ -> error "Tactic expected."
-  | a -> a
-
 (************* End globalization ************)
 
 (***************************************************************************)
 (* Evaluation/interpretation *)
 
-let constr_to_id loc = function
-  | VConstr ([],c) when isVar c -> destVar c
-  | _ -> invalid_arg_loc (loc, "Not an identifier")
-
-let constr_to_qid loc c =
-  try shortest_qualid_of_global Idset.empty (global_of_constr c)
-  with _ -> invalid_arg_loc (loc, "Not a global reference")
-
 let is_variable env id =
   List.mem id (ids_of_named_context (Environ.named_context env))
 
@@ -1053,7 +1022,7 @@ let try_interp_ltac_var coerce ist env (loc,id) =
 
 let interp_ltac_var coerce ist env locid =
   try try_interp_ltac_var coerce ist env locid
-  with Not_found -> anomaly "Detected as ltac var at interning time"
+  with Not_found -> anomaly ("Detected '" ^ (string_of_id (snd locid)) ^ "' as ltac var at interning time")
 
 (* Interprets an identifier which must be fresh *)
 let coerce_to_ident fresh env = function
@@ -1161,16 +1130,6 @@ let interp_hyp_list_as_list ist gl (loc,id as x) =
 let interp_hyp_list ist gl l =
   List.flatten (List.map (interp_hyp_list_as_list ist gl) l)
 
-let interp_clause_pattern ist gl (l,occl) =
-  let rec check acc = function
-    | (hyp,l) :: rest ->
-	let hyp = interp_hyp ist gl hyp in
-	if List.mem hyp acc then
-	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice.");
-	(hyp,l)::(check (hyp::acc) rest)
-    | [] -> []
-  in (l,check [] occl)
-
 let interp_move_location ist gl = function
   | MoveAfter id -> MoveAfter (interp_hyp ist gl id)
   | MoveBefore id -> MoveBefore (interp_hyp ist gl id)
@@ -1284,58 +1243,6 @@ let interp_fresh_id ist env l =
 
 let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl)
 
-let implicit_tactic = ref None
-
-let declare_implicit_tactic tac = implicit_tactic := Some tac
-
-open Evd
-
-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 =
-	Environ.named_context env ->
-      let id = id_of_string "H" in
-      start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl
-	(fun _ _ -> ());
-      begin
-	try
-	  by (tclCOMPLETE tac);
-	  let _,(const,_,_,_) = cook_proof ignore in
-	  delete_current_proof (); const.const_entry_body
-	with e when Logic.catchable_exception e ->
-	  delete_current_proof();
-	  raise Exit
-      end
-  | _ -> raise Exit
-
-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 =
-    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 =  !evdref in
-	    let evi = Evd.find sigma ev in
-	    (try
-	      let c = solvable_by_tactic env evi k src in
-	      evdref := Evd.define ev c !evdref;
-	      c
-	    with Exit ->
-              if fail_evar then
-	        Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
-              else
-                c)
-      | _ -> map_constr proc_rec c
-  in
-  let c = proc_rec c in
-  (* Side-effect *)
-  !evdref,c
-
 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
@@ -1348,13 +1255,14 @@ let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma
       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 =
+  let evdc =
     catch_error trace (understand_ltac expand_evar sigma env vars kind) c in
-  let evd,c =
+  let (evd,c) =
     if expand_evar then
-      solve_remaining_evars fail_evar use_classes env sigma evd c
+      solve_remaining_evars fail_evar use_classes
+        solve_by_implicit_tactic env sigma evdc
     else
-      evd,c in
+      evdc in
   db_constr ist.debug env c;
   (evd,c)
 
@@ -1373,6 +1281,9 @@ let interp_open_constr_gen kind ist =
 let interp_open_constr ccl =
   interp_open_constr_gen (OfType ccl)
 
+let interp_pure_open_constr ist =
+  interp_gen (OfType None) ist false false false false
+
 let interp_typed_pattern ist env sigma (c,_) =
   let sigma, c =
     interp_gen (OfType None) ist true false false false env sigma c in
@@ -1393,7 +1304,7 @@ let constr_list_of_VList env = function
 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), _ ->	
+    | GVar (_,id), _ ->	
         sigma,
         List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
     | _ ->
@@ -1408,12 +1319,14 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma 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 interp_open_constr_list =
   interp_constr_in_compound_list (fun x -> x) (fun x -> x)
     (interp_open_constr None)
 
+let interp_auto_lemmas ist env sigma lems =
+  let local_sigma, lems = interp_open_constr_list ist env sigma lems in
+  List.map (fun lem -> (local_sigma,lem)) lems
+
 (* Interprets a type expression *)
 let pf_interp_type ist gl =
   interp_type ist (pf_env gl) (project gl)
@@ -1476,7 +1389,7 @@ let interp_may_eval f ist gl = function
 	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));
+         str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c));
        raise e
 
 (* Interprets a constr expression possibly to first evaluate *)
@@ -1612,41 +1525,48 @@ let interp_open_constr_with_bindings ist env sigma (c,bl) =
 
 let loc_of_bindings = function
 | NoBindings -> dummy_loc
-| ImplicitBindings l -> loc_of_rawconstr (fst (list_last l))
+| ImplicitBindings l -> loc_of_glob_constr (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 loc1 = loc_of_glob_constr c in
   let loc2 = loc_of_bindings bl in
   let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in
   let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in
   sigma, (loc,cb)
 
-let interp_induction_arg ist gl sigma arg =
-  let env = pf_env gl in
+let interp_induction_arg ist gl arg =
+  let env = pf_env gl and sigma = project gl in
   match arg with
   | ElimOnConstr c ->
-      let sigma', (c,b) = interp_constr_with_bindings ist env sigma c in
-      let sigma, c = solve_remaining_evars false true env sigma sigma' c in
-      sigma, ElimOnConstr (c,b)
-  | ElimOnAnonHyp n as x -> sigma, x
+      ElimOnConstr (interp_constr_with_bindings ist env sigma c)
+  | ElimOnAnonHyp n as x -> x
   | ElimOnIdent (loc,id) ->
       try
-	sigma,
         match List.assoc id ist.lfun with
-	| VInteger n -> ElimOnAnonHyp n
-	| VIntroPattern (IntroIdentifier id) -> ElimOnIdent (loc,id)
-	| VConstr ([],c) -> ElimOnConstr (c,NoBindings)
+	| VInteger n ->
+	    ElimOnAnonHyp n
+	| VIntroPattern (IntroIdentifier id') ->
+	    if Tactics.is_quantified_hypothesis id' gl
+	    then ElimOnIdent (loc,id')
+	    else
+	      (try ElimOnConstr (sigma,(constr_of_id env id',NoBindings))
+	       with Not_found ->
+		user_err_loc (loc,"",
+		pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis."))
+	| VConstr ([],c) ->
+	    ElimOnConstr (sigma,(c,NoBindings))
 	| _ -> user_err_loc (loc,"",
 	      strbrk "Cannot coerce " ++ pr_id id ++
 	      strbrk " neither to a quantified hypothesis nor to a term.")
       with Not_found ->
-	(* Interactive mode *)
+	(* We were in non strict (interactive) mode *)
 	if Tactics.is_quantified_hypothesis id gl then
-          sigma, ElimOnIdent (loc,id)
+          ElimOnIdent (loc,id)
 	else
-          let c = interp_constr ist env sigma (RVar (loc,id),Some (CRef (Ident (loc,id)))) in
-          sigma, ElimOnConstr (c,NoBindings)
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
+          let c = interp_constr ist env sigma c in
+          ElimOnConstr (sigma,(c,NoBindings))
 
 (* Associates variables with values and gives the remaining variables and
    values *)
@@ -1811,11 +1731,11 @@ 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 } }
+let extend_gl_hyps { it=gl ; sigma=sigma } sign =
+  let hyps = Goal.V82.hyps sigma gl in
+  let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in
+  (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *)
+  Goal.V82.new_goal_with sigma gl new_hyps
 
 (* Interprets an l-tac expression into a value *)
 let rec val_interp ist gl (tac:glob_tactic_expr) =
@@ -1827,7 +1747,7 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
   | TacLetIn (false,l,u) -> interp_letin ist gl l u
   | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
   | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
-  | TacArg a -> interp_tacarg ist gl a
+  | TacArg (loc,a) -> interp_tacarg ist gl a
   (* Delayed evaluation *)
   | t -> VFun (ist.trace,ist.lfun,[],t)
 
@@ -1860,6 +1780,7 @@ and eval_tactic ist = function
 	(Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl)
   | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
   | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
   | TacTry tac -> tclTRY (interp_tactic ist tac)
   | TacInfo tac ->
       let t = (interp_tactic ist tac) in
@@ -1867,7 +1788,7 @@ and eval_tactic ist = function
 	  begin
 	    match tac with
 		TacAtom (_,_) -> t
-	      | _ -> abstract_tactic_expr (TacArg (Tacexp tac)) t
+	      | _ -> abstract_tactic_expr (TacArg (dloc,Tacexp tac)) t
 	  end
   | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
   | TacOrelse (tac1,tac2) ->
@@ -1979,19 +1900,19 @@ 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))
-    | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
+    | FailError (0,s) | Loc.Exc_located(_, FailError (0,s))
+    | Loc.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
 	raise (Eval_fail (Lazy.force s))
     | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
-    | Stdpp.Exc_located(s,FailError (lvl,s')) ->
-	raise (Stdpp.Exc_located(s,FailError (lvl - 1, s')))
-    | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
-	raise (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
+    | Loc.Exc_located(s,FailError (lvl,s')) ->
+	raise (Loc.Exc_located(s,FailError (lvl - 1, s')))
+    | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
+	raise (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
 
 (* Interprets the clauses of a recursive LetIn *)
 and interp_letrec ist gl llc u =
   let lref = ref ist.lfun in
-  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg b))) llc in
+  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg (dloc,b)))) llc in
   lref := lve@ist.lfun;
   let ist = { ist with lfun = lve@ist.lfun } in
   val_interp ist gl u
@@ -2005,6 +1926,8 @@ and interp_letin ist gl llc u =
 
 (* Interprets the Match Context expressions *)
 and interp_match_goal ist goal lz lr lmr =
+  let (gl,sigma) = Goal.V82.nf_evar (project goal) (sig_it goal) in
+  let goal = { it = gl ; sigma = sigma } in
   let hyps = pf_hyps goal in
   let hyps = if lr then List.rev hyps else hyps in
   let concl = pf_concl goal in
@@ -2116,7 +2039,7 @@ and interp_genarg ist gl x =
       in_gen wit_sort
         (destSort
 	  (pf_interp_constr ist gl
-	    (RSort (dloc,out_gen globwit_sort x), None)))
+	    (GSort (dloc,out_gen globwit_sort x), None)))
   | ConstrArgType ->
       in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
   | ConstrMayEvalArgType ->
@@ -2152,7 +2075,7 @@ and interp_genarg ist gl x =
       | Some n ->
           (* Special treatment of tactic arguments *)
           in_gen (wit_tactic n)
-	    (TacArg(valueIn(VFun(ist.trace,ist.lfun,[],
+	    (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
 				 out_gen (globwit_tactic n) x))))
       | None ->
           lookup_interp_genarg s ist gl x
@@ -2189,9 +2112,9 @@ and interp_match ist g lz constr lmr =
         match_next_pattern find_next' () in
     match_next_pattern (fun () -> match_subterm_gen app c csr) () in
   let rec apply_match ist csr = function
-    | (All t)::_ ->
+    | (All t)::tl ->
         (try eval_with_fail ist lz g t
-         with e when is_match_catchable e -> apply_match ist csr [])
+         with e when is_match_catchable e -> apply_match ist csr tl)
     | (Pat ([],Term c,mt))::tl ->
         (try
             let lmatch =
@@ -2337,23 +2260,31 @@ and interp_atomic ist gl tac =
   | 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 env na) (pf_interp_constr ist gl c) clp
+      if clp = nowhere then
+        (* We try to fully-typechect the term *)
+        h_let_tac b (interp_fresh_name ist env na)
+          (pf_interp_constr ist gl c) clp
+      else
+        (* We try to keep the pattern structure as much as possible *)
+        h_let_pat_tac b (interp_fresh_name ist env na)
+          (interp_pure_open_constr ist env sigma c) clp
 
   (* Automation tactics *)
   | TacTrivial (lems,l) ->
-      Auto.h_trivial (interp_constr_list ist env sigma lems)
+      Auto.h_trivial
+	(interp_auto_lemmas 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)
-      (interp_constr_list ist env sigma lems)
-      (Option.map (List.map (interp_hint_base ist)) l)
+	(interp_auto_lemmas 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)
   | TacDestructConcl -> Dhyp.h_destructConcl
   | 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)
-      (interp_constr_list ist env sigma lems)
+      (interp_auto_lemmas ist env sigma lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
@@ -2361,8 +2292,7 @@ and interp_atomic ist gl tac =
   | 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 lc = List.map (interp_induction_arg ist gl) lc in
 	  let sigma,cbo =
             Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
           (sigma,(lc,cbo,
@@ -2410,7 +2340,7 @@ and interp_atomic ist gl tac =
         (Tactics.any_constructor ev (Option.map (interp_tactic ist) t))
   | TacConstructor (ev,n,bl) ->
       let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_constructor ev (skip_metaid n)) sigma bl
+      tclWITHHOLES ev (h_constructor ev (interp_int_or_var ist n)) sigma bl
 
   (* Conversion *)
   | TacReduce (r,cl) ->
@@ -2553,7 +2483,7 @@ let make_empty_glob_sign () =
 (* Initial call for interpretation *)
 let interp_tac_gen lfun avoid_ids debug t gl =
   interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] }
-    (intern_tactic {
+    (intern_tactic true {
       ltacvars = (List.map fst lfun, []); ltacrecvars = [];
       gsigma = project gl; genv = pf_env gl } t) gl
 
@@ -2566,18 +2496,18 @@ let interp t = interp_tac_gen [] [] (get_debug()) t
 let eval_ltac_constr gl t =
   interp_ltac_constr
     { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl
-    (intern_tactic (make_empty_glob_sign ()) t )
+    (intern_tactic_or_tacarg (make_empty_glob_sign ()) t )
 
 (* Hides interpretation for pretty-print *)
 let hide_interp t ot gl =
   let ist = { ltacvars = ([],[]); ltacrecvars = [];
             gsigma = project gl; genv = pf_env gl } in
-  let te = intern_tactic ist t in
+  let te = intern_tactic true ist t in
   let t = eval_tactic te in
   match ot with
-  | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl
+  | None -> abstract_tactic_expr (TacArg (dloc,Tacexp te)) t gl
   | Some t' ->
-      abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl
+      abstract_tactic_expr ~dflt:true (TacArg (dloc,Tacexp te)) (tclTHEN t t') gl
 
 (***************************************************************************)
 (* Substitution at module closing time *)
@@ -2586,25 +2516,25 @@ let subst_quantified_hypothesis _ x = x
 
 let subst_declared_or_quantified_hypothesis _ x = x
 
-let subst_rawconstr_and_expr subst (c,e) =
+let subst_glob_constr_and_expr subst (c,e) =
   assert (e=None); (* e<>None only for toplevel tactics *)
-  (Detyping.subst_rawconstr subst c,None)
+  (Detyping.subst_glob_constr subst c,None)
 
-let subst_rawconstr = subst_rawconstr_and_expr (* shortening *)
+let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
 
 let subst_binding subst (loc,b,c) =
-  (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c)
+  (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c)
 
 let subst_bindings subst = function
   | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map (subst_rawconstr subst) l)
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l)
   | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
 
-let subst_raw_with_bindings subst (c,bl) =
-  (subst_rawconstr subst c, subst_bindings subst bl)
+let subst_glob_with_bindings subst (c,bl) =
+  (subst_glob_constr subst c, subst_bindings subst bl)
 
 let subst_induction_arg subst = function
-  | ElimOnConstr c -> ElimOnConstr (subst_raw_with_bindings subst c)
+  | ElimOnConstr c -> ElimOnConstr (subst_glob_with_bindings subst c)
   | ElimOnAnonHyp n as x -> x
   | ElimOnIdent id as x -> x
 
@@ -2645,17 +2575,17 @@ let subst_unfold subst (l,e) =
 let subst_flag subst red =
   { red with rConst = List.map (subst_evaluable subst) red.rConst }
 
-let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c)
+let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c)
 
-let subst_rawconstr_or_pattern subst (c,p) =
-  (subst_rawconstr subst c,subst_pattern subst p)
+let subst_glob_constr_or_pattern subst (c,p) =
+  (subst_glob_constr subst c,subst_pattern subst p)
 
 let subst_pattern_with_occurrences subst (l,p) =
-  (l,subst_rawconstr_or_pattern subst p)
+  (l,subst_glob_constr_or_pattern subst p)
 
 let subst_redexp subst = function
   | Unfold l -> Unfold (List.map (subst_unfold subst) l)
-  | Fold l -> Fold (List.map (subst_rawconstr subst) l)
+  | Fold l -> Fold (List.map (subst_glob_constr subst) l)
   | Cbv f -> Cbv (subst_flag subst f)
   | Lazy f -> Lazy (subst_flag subst f)
   | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l)
@@ -2663,14 +2593,14 @@ let subst_redexp subst = function
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let subst_raw_may_eval subst = function
-  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c)
-  | ConstrContext (locid,c) -> ConstrContext (locid,subst_rawconstr subst c)
-  | ConstrTypeOf c -> ConstrTypeOf (subst_rawconstr subst c)
-  | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
 
 let subst_match_pattern subst = function
-  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_rawconstr_or_pattern subst pc))
-  | Term pc -> Term (subst_rawconstr_or_pattern subst pc)
+  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
+  | Term pc -> Term (subst_glob_constr_or_pattern subst pc)
 
 let rec subst_match_goal_hyps subst = function
   | Hyp (locs,mp) :: tl ->
@@ -2685,54 +2615,54 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   (* Basic tactics *)
   | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
   | TacAssumption as x -> x
-  | TacExact c -> TacExact (subst_rawconstr subst c)
-  | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
-  | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c)
+  | TacExact c -> TacExact (subst_glob_constr subst c)
+  | TacExactNoCheck c -> TacExactNoCheck (subst_glob_constr subst c)
+  | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_glob_constr subst c)
   | TacApply (a,ev,cb,cl) ->
-      TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl)
+      TacApply (a,ev,List.map (subst_glob_with_bindings subst) cb,cl)
   | TacElim (ev,cb,cbo) ->
-      TacElim (ev,subst_raw_with_bindings subst cb,
-               Option.map (subst_raw_with_bindings subst) cbo)
-  | TacElimType c -> TacElimType (subst_rawconstr subst c)
-  | TacCase (ev,cb) -> TacCase (ev,subst_raw_with_bindings subst cb)
-  | TacCaseType c -> TacCaseType (subst_rawconstr subst c)
+      TacElim (ev,subst_glob_with_bindings subst cb,
+               Option.map (subst_glob_with_bindings subst) cbo)
+  | TacElimType c -> TacElimType (subst_glob_constr subst c)
+  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings subst cb)
+  | TacCaseType c -> TacCaseType (subst_glob_constr subst c)
   | TacFix (idopt,n) as x -> x
   | TacMutualFix (b,id,n,l) ->
-      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
+      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
   | TacCofix idopt as x -> x
   | TacMutualCofix (b,id,l) ->
-      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
-  | TacCut c -> TacCut (subst_rawconstr subst c)
+      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
+  | TacCut c -> TacCut (subst_glob_constr subst c)
   | TacAssert (b,na,c) ->
-      TacAssert (Option.map (subst_tactic subst) b,na,subst_rawconstr subst c)
+      TacAssert (Option.map (subst_tactic subst) b,na,subst_glob_constr subst c)
   | TacGeneralize cl ->
       TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c)
-  | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_rawconstr subst c,clp,b)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
+  | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_glob_constr subst c,clp,b)
 
   (* Automation tactics *)
-  | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l)
-  | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l)
+  | TacTrivial (lems,l) -> TacTrivial (List.map (subst_glob_constr subst) lems,l)
+  | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_glob_constr subst) lems,l)
   | TacAutoTDB n -> TacAutoTDB n
   | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
   | TacDestructConcl -> TacDestructConcl
   | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
-  | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems)
+  | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_glob_constr subst) lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) as x -> x
   | 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) l, cls))
+        Option.map (subst_glob_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)
+  | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c)
+  | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c)
   | TacDecompose (l,c) ->
       let l = List.map (subst_or_var (subst_inductive subst)) l in
-      TacDecompose (l,subst_rawconstr subst c)
-  | TacSpecialize (n,l) -> TacSpecialize (n,subst_raw_with_bindings subst l)
-  | TacLApply c -> TacLApply (subst_rawconstr subst c)
+      TacDecompose (l,subst_glob_constr subst c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l)
+  | TacLApply c -> TacLApply (subst_glob_constr subst c)
 
   (* Context management *)
   | TacClear _ as x -> x
@@ -2751,24 +2681,24 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   (* Conversion *)
   | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
   | TacChange (op,c,cl) ->
-      TacChange (Option.map (subst_rawconstr_or_pattern subst) op,
-        subst_rawconstr subst c, cl)
+      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
+        subst_glob_constr subst c, cl)
 
   (* Equivalence relations *)
   | TacReflexivity | TacSymmetry _ as x -> x
-  | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c)
+  | TacTransitivity c -> TacTransitivity (Option.map (subst_glob_constr subst) c)
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
       TacRewrite (ev,
 		  List.map (fun (b,m,c) ->
-			      b,m,subst_raw_with_bindings subst c) l,
+			      b,m,subst_glob_with_bindings subst c) l,
 		 cl,Option.map (subst_tactic subst) by)
   | TacInversion (DepInversion (k,c,l),hyp) ->
-     TacInversion (DepInversion (k,Option.map (subst_rawconstr subst) c,l),hyp)
+     TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp)
   | TacInversion (NonDepInversion _,_) as x -> x
   | TacInversion (InversionUsing (c,cl),hyp) ->
-      TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp)
+      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
 
   (* For extensions *)
   | TacExtend (_loc,opn,l) ->
@@ -2796,6 +2726,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | TacThens (t,tl) ->
       TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
   | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
   | TacTry tac -> TacTry (subst_tactic subst tac)
   | TacInfo tac -> TacInfo (subst_tactic subst tac)
   | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
@@ -2804,7 +2735,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
   | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
   | TacComplete tac -> TacComplete (subst_tactic subst tac)
-  | TacArg a -> TacArg (subst_tacarg subst a)
+  | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
 
 and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
 
@@ -2855,7 +2786,7 @@ and subst_genarg subst (x:glob_generic_argument) =
   | SortArgType ->
       in_gen globwit_sort (out_gen globwit_sort x)
   | ConstrArgType ->
-      in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x))
+      in_gen globwit_constr (subst_glob_constr subst (out_gen globwit_constr x))
   | ConstrMayEvalArgType ->
       in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
   | QuantHypArgType ->
@@ -2866,10 +2797,10 @@ and subst_genarg subst (x:glob_generic_argument) =
       in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
   | OpenConstrArgType b ->
       in_gen (globwit_open_constr_gen b)
-        ((),subst_rawconstr subst (snd (out_gen (globwit_open_constr_gen b) x)))
+        ((),subst_glob_constr subst (snd (out_gen (globwit_open_constr_gen b) x)))
   | ConstrWithBindingsArgType ->
       in_gen globwit_constr_with_bindings
-        (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x))
+        (subst_glob_with_bindings subst (out_gen globwit_constr_with_bindings x))
   | BindingsArgType ->
       in_gen globwit_bindings
         (subst_bindings subst (out_gen globwit_bindings x))
@@ -2889,11 +2820,6 @@ and subst_genarg subst (x:glob_generic_argument) =
 (***************************************************************************)
 (* Tactic registration *)
 
-(* For bad tactic calls *)
-let bad_tactic_args s =
-  anomalylabstrm s
-    (str "Tactic " ++ str s ++ str " called with bad arguments")
-
 (* Declaration of the TAC-DEFINITION object *)
 let add (kn,td) = mactab := Gmap.add kn td !mactab
 let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab)
@@ -2938,7 +2864,7 @@ let subst_md (subst,(local,defs)) =
 let classify_md (local,defs as o) =
   if local then Dispose else Substitute o
 
-let (inMD,outMD) =
+let inMD : bool * (tacdef_kind * glob_tactic_expr) list -> obj =
   declare_object {(default_object "TAC-DEFINITION") with
      cache_function  = cache_md;
      load_function   = load_md;
@@ -2946,12 +2872,22 @@ let (inMD,outMD) =
      subst_function = subst_md;
      classify_function = classify_md}
 
+let rec split_ltac_fun = function
+  | TacFun (l,t) -> (l,t)
+  | t -> ([],t)
+
+let pr_ltac_fun_arg = function
+  | None -> spc () ++ str "_"
+  | Some id -> spc () ++ pr_id id
+
 let print_ltac id =
  try
   let kn = Nametab.locate_tactic id in
-  let t = lookup kn in
-   str "Ltac" ++ spc() ++ pr_qualid id ++ str " :=" ++ spc() ++
-    Pptactic.pr_glob_tactic (Global.env ()) t
+  let l,t = split_ltac_fun (lookup kn) in
+  hv 2 (
+    hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
+           prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
+    ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t)
  with
   Not_found ->
    errorlabstrm "print_ltac"
@@ -2991,7 +2927,7 @@ let add_tacdef local isrec tacl =
   let gtacl =
     List.map2 (fun (_,b,def) (id, qid) ->
       let k = if b then UpdateTac qid else NewTac (Option.get id) in
-      let t = Flags.with_option strict_check (intern_tactic ist) def in
+      let t = Flags.with_option strict_check (intern_tactic_or_tacarg ist) def in
 	(k, t))
       tacl rfun in
   let id0 = fst (List.hd rfun) in
@@ -3009,11 +2945,11 @@ let add_tacdef local isrec tacl =
 (* Other entry points *)
 
 let glob_tactic x =
-  Flags.with_option strict_check (intern_tactic (make_empty_glob_sign ())) x
+  Flags.with_option strict_check (intern_tactic true (make_empty_glob_sign ())) x
 
 let glob_tactic_env l env x =
   Flags.with_option strict_check
-  (intern_tactic
+  (intern_pure_tactic
     { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
     x
 
@@ -3025,14 +2961,16 @@ 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 globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t))
 let tacticIn t =
   globTacticIn (fun ist ->
     try glob_tactic (t ist)
-    with e -> raise (AnomalyOnError ("Incorrect tactic expression", e)))
+    with e -> anomalylabstrm "tacticIn"
+      (str "Incorrect tactic expression. Received exception is:" ++
+       Errors.print e))
 
 let tacticOut = function
-  | TacArg (TacDynamic (_,d)) ->
+  | TacArg (_,TacDynamic (_,d)) ->
     if (Dyn.tag d) = "tactic" then
       tactic_out d
     else
@@ -3051,6 +2989,6 @@ let _ = Auto.set_extern_interp
 let _ = Auto.set_extern_intern_tac
   (fun l ->
     Flags.with_option strict_check
-    (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
+    (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
 let _ = Auto.set_extern_subst_tactic subst_tactic
 let _ = Dhyp.set_extern_interp eval_tactic
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 8f585781..d9dc8094 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacinterp.mli 14677 2011-11-17 22:19:38Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
@@ -21,11 +18,10 @@ open Genarg
 open Topconstr
 open Mod_subst
 open Redexpr
-(*i*)
 
-(* Values for interpretation *)
+(** Values for interpretation *)
 type value =
-  | VRTactic of (goal list sigma * validation)
+  | VRTactic of (goal list sigma)
   | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
   | VVoid
@@ -36,7 +32,7 @@ type value =
   | VList of value list
   | VRec of (identifier*value) list ref * glob_tactic_expr
 
-(* Signature for interpretation: val\_interp and interpretation functions *)
+(** Signature for interpretation: val\_interp and interpretation functions *)
 and interp_sign =
   { lfun : (identifier * value) list;
     avoid_ids : identifier list;
@@ -46,31 +42,27 @@ and interp_sign =
 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
-
-(* To embed several objects in Coqast.t *)
+(** 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
-val constrIn : constr -> constr_expr
 
-(* Sets the debugger mode *)
+(** Sets the debugger mode *)
 val set_debug : debug_info -> unit
 
-(* Gives the state of debug *)
+(** Gives the state of debug *)
 val get_debug : unit -> debug_info
 
-(* Adds a definition for tactics in the table *)
+(** Adds a definition for tactics in the table *)
 val add_tacdef :
   Vernacexpr.locality_flag -> bool ->
   (Libnames.reference * bool * raw_tactic_expr) list -> unit
 val add_primitive_tactic : string -> glob_tactic_expr -> unit
 
-(* Tactic extensions *)
+(** Tactic extensions *)
 val add_tactic :
   string -> (typed_generic_argument list -> tactic) -> unit
 val overwriting_add_tactic :
@@ -78,7 +70,7 @@ val overwriting_add_tactic :
 val lookup_tactic :
   string -> (typed_generic_argument list) -> tactic
 
-(* Adds an interpretation function for extra generic arguments *)
+(** Adds an interpretation function for extra generic arguments *)
 type glob_sign = {
   ltacvars : identifier list * identifier list;
   ltacrecvars : (identifier * Nametab.ltac_constant) list;
@@ -99,18 +91,15 @@ val interp_genarg :
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_tactic :
-  glob_sign -> raw_tactic_expr -> glob_tactic_expr
-
 val intern_pure_tactic :
   glob_sign -> raw_tactic_expr -> glob_tactic_expr
 
 val intern_constr :
-  glob_sign -> constr_expr -> rawconstr_and_expr
+  glob_sign -> constr_expr -> glob_constr_and_expr
 
 val intern_constr_with_bindings :
-  glob_sign -> constr_expr * constr_expr Rawterm.bindings ->
-  rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings
+  glob_sign -> constr_expr * constr_expr Glob_term.bindings ->
+  glob_constr_and_expr * glob_constr_and_expr Glob_term.bindings
 
 val intern_hyp :
   glob_sign -> identifier Util.located -> identifier Util.located
@@ -118,28 +107,34 @@ val intern_hyp :
 val subst_genarg :
   substitution -> glob_generic_argument -> glob_generic_argument
 
-val subst_rawconstr_and_expr :
-  substitution -> rawconstr_and_expr -> rawconstr_and_expr
+val subst_glob_constr_and_expr :
+  substitution -> glob_constr_and_expr -> glob_constr_and_expr
 
-(* Interprets any expression *)
+val subst_glob_with_bindings :
+  substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
+
+(** Interprets any expression *)
 val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
 
-(* Interprets an expression that evaluates to a constr *)
+(** Interprets an expression that evaluates to a constr *)
 val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
   constr
 
-(* Interprets redexp arguments *)
+(** Interprets redexp arguments *)
 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
 
-(* Interprets tactic expressions *)
+(** Interprets tactic expressions *)
 val interp_tac_gen : (identifier * value) list -> identifier list ->
                  debug_info -> raw_tactic_expr -> tactic
 
 val interp_hyp :  interp_sign -> goal sigma -> identifier located -> identifier
 
-val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> rawconstr_and_expr Rawterm.bindings -> Evd.evar_map * constr Rawterm.bindings
+val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr Glob_term.bindings -> Evd.evar_map * constr Glob_term.bindings
+
+val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> 
+  glob_constr_and_expr Glob_term.with_bindings -> Evd.evar_map * constr Glob_term.with_bindings
 
-(* Initial call for interpretation *)
+(** Initial call for interpretation *)
 val glob_tactic : raw_tactic_expr -> glob_tactic_expr
 
 val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
@@ -152,21 +147,18 @@ val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
 
 val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
 
-(* Hides interpretation for pretty-print *)
+(** Hides interpretation for pretty-print *)
 
 val hide_interp : raw_tactic_expr -> tactic option -> tactic
 
-(* Declare the default tactic to fill implicit arguments *)
-val declare_implicit_tactic : tactic -> unit
-
-(* Declare the xml printer *)
+(** Declare the xml printer *)
 val declare_xml_printer :
   (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
 
-(* printing *)
+(** printing *)
 val print_ltac : Libnames.qualid -> std_ppcmds
 
-(* Internals that can be useful for syntax extensions. *)
+(** Internals that can be useful for syntax extensions. *)
 
 exception CannotCoerceTo of string
 
@@ -175,4 +167,3 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> iden
 val interp_int : interp_sign -> identifier located -> int
 
 val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a
-
diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml
index df5a3283..57b8c540 100644
--- a/tactics/tactic_option.ml
+++ b/tactics/tactic_option.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
-
 open Libobject
 open Proof_type
 open Pp
@@ -27,7 +25,7 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name =
   let subst (s, (local, tac)) =
     (local, Tacinterp.subst_tactic s tac)
   in
-  let input, _output = 
+  let input : bool * Tacexpr.glob_tactic_expr -> obj =
     declare_object
       { (default_object name) with
 	cache_function = cache;
diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli
index 890ba98e..8388738a 100644
--- a/tactics/tactic_option.mli
+++ b/tactics/tactic_option.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
-
 open Proof_type
 open Tacexpr
 open Vernacexpr
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index f0d4dc51..11625cbd 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacticals.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -23,7 +21,7 @@ open Refiner
 open Tacmach
 open Clenv
 open Clenvtac
-open Rawterm
+open Glob_term
 open Pattern
 open Matching
 open Genarg
@@ -61,8 +59,9 @@ 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 tclTIMEOUT       = Refiner.tclTIMEOUT
 let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
+let tclPROGRESS      = Refiner.tclPROGRESS
 let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
 let tclTHENTRY       = Refiner.tclTHENTRY
 let tclIFTHENELSE    = Refiner.tclIFTHENELSE
@@ -173,12 +172,9 @@ let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl)
 
 let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl
 let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl
-let 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
@@ -292,7 +288,7 @@ let compute_construtor_signatures isrec (_,k as ity) =
     | Prod (_,_,c), recarg::rest ->
 	let b = match dest_recarg recarg with
 	  | Norec | Imbr _  -> false
-	  | Mrec j  -> isrec & j=k
+	  | Mrec (_,j)  -> isrec & j=k
 	in b :: (analrec c rest)
     | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
     | _, [] -> []
@@ -367,7 +363,8 @@ let general_elim_then_using mk_elim
     match predicate with
        | None   -> elimclause'
        | Some p ->
-           clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause'
+           clenv_unify ~flags:Unification.elim_flags
+             Reduction.CONV (mkMeta pmv) p elimclause'
   in
   elim_res_pf_THEN_i elimclause' branchtacs gl
 
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 6466ab78..db9ab0c9 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacticals.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
@@ -22,10 +19,9 @@ open Pattern
 open Genarg
 open Tacexpr
 open Termops
-open Rawterm
-(*i*)
+open Glob_term
 
-(* Tacticals i.e. functions from tactics to tactics. *)
+(** Tacticals i.e. functions from tactics to tactics. *)
 
 val tclNORMEVAR      : tactic
 val tclIDTAC         : tactic
@@ -55,8 +51,8 @@ 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 tclPROGRESS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
@@ -68,7 +64,7 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
 val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic
 
-(*s Tacticals applying to hypotheses *)
+(** {6 Tacticals applying to hypotheses } *)
 
 val onNthHypId       : int -> (identifier -> tactic) -> tactic
 val onNthHyp         : int -> (constr -> tactic) -> tactic
@@ -96,14 +92,14 @@ val ifOnHyp     : (identifier * types -> bool) ->
 val onHyps      : (goal sigma -> named_context) ->
                   (named_context -> tactic) -> tactic
 
-(*s Tacticals applying to goal components *)
+(** {6 Tacticals applying to goal components } *)
 
-(* A [simple_clause] is a set of hypotheses, possibly extended with
+(** 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
+(** 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 *)
 
@@ -121,26 +117,25 @@ 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 *)
+(** {6 An intermediate form of occurrence clause with no mention of occurrences } *)
 
-(* A [hyp_location] is an hypothesis together with a position, in
+(** 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
+(** 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 *)
+(** {6 A concrete view of occurrence clauses } *)
 
-(* [clause_atom] refers either to an hypothesis location (i.e. an
+(** [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 *)
 
@@ -148,40 +143,40 @@ type clause_atom =
   | OnHyp of identifier * occurrences_expr * hyp_location_flag
   | OnConcl of occurrences_expr
 
-(* A [concrete_clause] is an effective collection of
+(** 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 *)
+(** This interprets an [clause] in a given [goal] context *)
 val concrete_clause_of : clause -> goal sigma -> concrete_clause
 
-(*s Elimination tacticals. *)
+(** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : inductive;   (* the type we were eliminating on *)
-  largs      : constr list; (* its arguments *)
-  branchnum  : int;         (* the branch number *)
-  pred       : constr;      (* the predicate we used *)
-  nassums    : int;         (* the number of assumptions to be introduced *)
-  branchsign : bool list;   (* the signature of the branch.
+  ity        : inductive;   (** the type we were eliminating on *)
+  largs      : constr list; (** its arguments *)
+  branchnum  : int;         (** the branch number *)
+  pred       : constr;      (** the predicate we used *)
+  nassums    : int;         (** the number of assumptions to be introduced *)
+  branchsign : bool list;   (** the signature of the branch.
                                true=recursive argument, false=constant *)
   branchnames : intro_pattern_expr located list}
 
 type branch_assumptions = {
-  ba        : branch_args;     (* the branch args *)
-  assums    : named_context}   (* the list of assumptions introduced *)
+  ba        : branch_args;     (** the branch args *)
+  assums    : named_context}   (** the list of assumptions introduced *)
 
-(* [check_disjunctive_pattern_size loc pats n] returns an appropriate *)
-(* error message if |pats| <> n *)
+(** [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
 
-(* Tolerate "[]" to mean a disjunctive pattern of any length *)
+(** Tolerate "[]" to mean a disjunctive pattern of any length *)
 val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr ->
   or_and_intro_pattern_expr
 
-(* Useful for [as intro_pattern] modifier *)
+(** Useful for [as intro_pattern] modifier *)
 val compute_induction_names :
   int -> intro_pattern_expr located option ->
     intro_pattern_expr located list array
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 186b5c48..988d9f53 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactics.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Pp
 open Util
 open Names
@@ -25,9 +24,8 @@ open Libnames
 open Evd
 open Pfedit
 open Tacred
-open Rawterm
+open Glob_term
 open Tacmach
-open Proof_trees
 open Proof_type
 open Logic
 open Evar_refiner
@@ -61,6 +59,8 @@ let inj_with_occurrences e = (all_occurrences_expr,e)
 
 let dloc = dummy_loc
 
+let typ_of = Retyping.get_type_of
+
 (* Option for 8.2 compatibility *)
 open Goptions
 let dependent_propositions_elimination = ref true
@@ -72,25 +72,15 @@ let use_dependent_propositions_elimination () =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       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 finish_evar_resolution env initial_sigma c =
+  snd (Pretyping.solve_remaining_evars true true solve_by_implicit_tactic
+         env initial_sigma c)
 
 (*********************************************)
 (*                 Tactics                   *)
@@ -165,7 +155,6 @@ let internal_cut_rev_replace = internal_cut_rev_gen true
 (* Moving hypotheses *)
 let move_hyp        = Tacmach.move_hyp
 
-let order_hyps      = Tacmach.order_hyps
 
 (* Renaming hypotheses *)
 let rename_hyp      = Tacmach.rename_hyp
@@ -285,9 +274,12 @@ let reduct_in_hyp redfun (id,where) gl =
   convert_hyp_no_check
     (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl
 
+let revert_cast (redfun,kind as r) =
+  if kind = DEFAULTcast then (redfun,REVERTcast) else r
+
 let reduct_option redfun = function
   | Some id -> reduct_in_hyp (fst redfun) id
-  | None    -> reduct_in_concl redfun
+  | None    -> reduct_in_concl (revert_cast redfun)
 
 (* Now we introduce different instances of the previous tacticals *)
 let change_and_check cv_pb t env sigma c =
@@ -323,35 +315,25 @@ let change chg c cls gl =
     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 try_red_in_concl    = reduct_in_concl (try_red_product,REVERTcast)
+let red_in_concl        = reduct_in_concl (red_product,REVERTcast)
 let red_in_hyp          = reduct_in_hyp   red_product
-let red_option          = reduct_option   (red_product,DEFAULTcast)
-let hnf_in_concl        = reduct_in_concl (hnf_constr,DEFAULTcast)
+let red_option          = reduct_option   (red_product,REVERTcast)
+let hnf_in_concl        = reduct_in_concl (hnf_constr,REVERTcast)
 let hnf_in_hyp          = reduct_in_hyp   hnf_constr
-let hnf_option          = reduct_option   (hnf_constr,DEFAULTcast)
-let simpl_in_concl      = reduct_in_concl (simpl,DEFAULTcast)
+let hnf_option          = reduct_option   (hnf_constr,REVERTcast)
+let simpl_in_concl      = reduct_in_concl (simpl,REVERTcast)
 let simpl_in_hyp        = reduct_in_hyp   simpl
-let simpl_option        = reduct_option   (simpl,DEFAULTcast)
-let normalise_in_concl  = reduct_in_concl (compute,DEFAULTcast)
+let simpl_option        = reduct_option   (simpl,REVERTcast)
+let normalise_in_concl  = reduct_in_concl (compute,REVERTcast)
 let normalise_in_hyp    = reduct_in_hyp   compute
-let normalise_option    = reduct_option   (compute,DEFAULTcast)
+let normalise_option    = reduct_option   (compute,REVERTcast)
 let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast)
-let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast)
+let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast)
 let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname)
 let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast)
 let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
 
-(* A function which reduces accordingly to a reduction expression,
-   as the command Eval does. *)
-
-let checking_fun = function
-  (* Expansion is not necessarily well-typed: e.g. expansion of t into x is
-     not well-typed in [H:(P t); x:=t |- G] because x is defined after H *)
-  | Fold _ -> with_check
-  | Pattern _ -> with_check
-  | _ -> (fun x -> x)
-
 (* The main reduction function *)
 
 let reduction_clause redexp cl =
@@ -433,31 +415,34 @@ let find_intro_names ctxt gl =
     ctxt (pf_env gl , []) in
   List.rev res
 
-let build_intro_tac id = function
-  | MoveToEnd true -> introduction id
-  | dest -> tclTHEN (introduction id) (move_hyp true id dest)
+let build_intro_tac id dest tac = match dest with
+  | MoveToEnd true -> tclTHEN (introduction id) (tac id)
+  | dest -> tclTHENLIST [introduction id; move_hyp true id dest; tac id]
 
-let rec intro_gen loc name_flag move_flag force_flag dep_flag gl =
+let rec intro_then_gen loc name_flag move_flag force_flag dep_flag tac gl =
   match kind_of_term (pf_concl gl) with
     | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl
+	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag tac gl
     | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag
+	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag tac
 	  gl
     | _ ->
 	if not force_flag then raise (RefinerError IntroNeedsProduct);
 	try
 	  tclTHEN try_red_in_concl
-	    (intro_gen loc name_flag move_flag force_flag dep_flag) gl
+	    (intro_then_gen loc name_flag move_flag force_flag dep_flag tac) gl
 	with Redelimination ->
 	  user_err_loc(loc,"Intro",str "No product even after head-reduction.")
 
+let intro_gen loc n m f d = intro_then_gen loc n m f d (fun _ -> tclIDTAC)
 let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false
 let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false
+let intro_then = intro_then_gen dloc (IntroAvoid []) no_move false false
 let intro = intro_gen dloc (IntroAvoid []) no_move false false
 let introf = intro_gen dloc (IntroAvoid []) no_move true false
 let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false
-let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true false
+
+let intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false
 
 (**** Multiple introduction tactics ****)
 
@@ -469,8 +454,13 @@ 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 intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac =
+  let rec aux ids =
+    tclORELSE0
+      (intro_then_gen loc name_flag  move_flag false dep_flag
+         (fun id -> aux (id::ids)))
+      (tac ids) in
+  aux []
 
 let rec get_next_hyp_position id = function
   | [] -> error ("No such hypothesis: " ^ string_of_id id)
@@ -517,8 +507,8 @@ let intro_move idopt hto = match idopt with
   | 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_displayed env ccl id
+  | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n
+  | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id
 
 let pf_lookup_hypothesis_as_renamed_gen red h gl =
   let env = pf_env gl in
@@ -565,8 +555,13 @@ let intros_until = intros_until_gen true
 let intros_until_n = intros_until_n_gen true
 let intros_until_n_wored = intros_until_n_gen false
 
+let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl
+
+let try_intros_until_id_check id =
+  tclORELSE (intros_until_id id) (tclCHECKVAR id)
+
 let try_intros_until tac = function
-  | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id)
+  | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id)
   | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac)
 
 let rec intros_move = function
@@ -583,17 +578,32 @@ let dependent_in_decl a (_,c,t) =
 (* Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
+let onOpenInductionArg tac = function
+  | ElimOnConstr cbl ->
+      tac cbl
+  | ElimOnAnonHyp n ->
+      tclTHEN
+        (intros_until_n n)
+        (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings))))
+  | ElimOnIdent (_,id) ->
+      (* A quantified hypothesis *)
+      tclTHEN
+        (try_intros_until_id_check id)
+        (tac (Evd.empty,(mkVar id,NoBindings)))
+
 let onInductionArg tac = function
-  | ElimOnConstr (c,lbindc as cbl) ->
-      if isVar c & lbindc = NoBindings then
-	tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl)
-      else
-	tac cbl
+  | ElimOnConstr cbl ->
+      tac cbl
   | ElimOnAnonHyp n ->
       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))
+      (* A quantified hypothesis *)
+      tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings))
+
+let map_induction_arg f = function
+  | ElimOnConstr (sigma,(c,bl)) -> ElimOnConstr (f (sigma,c),bl)
+  | ElimOnAnonHyp n -> ElimOnAnonHyp n
+  | ElimOnIdent id -> ElimOnIdent id
 
 (**************************)
 (*  Refinement tactics    *)
@@ -615,9 +625,9 @@ let bring_hyps hyps =
 
 let resolve_classes gl =
   let env = pf_env gl and evd = project gl in
-    if evd = Evd.empty then tclIDTAC gl
+    if Evd.is_empty evd then tclIDTAC gl
     else
-      let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in
+      let evd' = Typeclasses.resolve_typeclasses env evd in
 	(tclTHEN (tclEVARS evd') tclNORMEVAR) gl
 
 (**************************)
@@ -723,24 +733,15 @@ let index_of_ind_arg t =
       | 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;
-  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 i elimclause indclause gl =
+let elimination_clause_scheme with_evars ?(flags=elim_flags) 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."))
   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
+  let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
+  res_pf elimclause' ~with_evars:with_evars ~flags gl
 
 (*
  * Elimination tactic with bindings and using an arbitrary
@@ -769,8 +770,8 @@ let general_elim_clause elimtac (c,lbindc) elim gl =
   let indclause  = make_clenv_binding gl (c,t) lbindc  in
     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
+let general_elim with_evars c e =
+  general_elim_clause (elimination_clause_scheme with_evars) c e
 
 (* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
@@ -786,15 +787,15 @@ let default_elim with_evars (c,_ as cx) gl =
 let elim_in_context with_evars c = function
   | 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 =
   match kind_of_term c with
     | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id))
+	tclTHEN (try_intros_until_id_check id)
 	  (elim_in_context with_evars cx elim)
-    | _ -> elim_in_context with_evars cx elim
+    | _ ->
+	elim_in_context with_evars cx elim
 
 (* The simplest elimination tactic, with no substitutions at all. *)
 
@@ -810,13 +811,13 @@ let simplest_elim c = default_elim false (c,NoBindings)
    (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
 *)
 
-let clenv_fchain_in id elim_flags mv elimclause hypclause =
-  try clenv_fchain ~allow_K:false ~flags:elim_flags mv elimclause hypclause
-  with PretypeError (env,NoOccurrenceFound (op,_)) ->
+let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause =
+  try clenv_fchain ~flags mv elimclause hypclause
+  with PretypeError (env,evd,NoOccurrenceFound (op,_)) ->
     (* Set the hypothesis name in the message *)
-    raise (PretypeError (env,NoOccurrenceFound (op,Some id)))
+    raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars id i elimclause indclause gl =
+let elimination_in_clause_scheme with_evars ?(flags=elim_flags) 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
@@ -824,12 +825,11 @@ let elimination_in_clause_scheme with_evars id i elimclause indclause gl =
       | _ -> 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 ~flags indmv elimclause indclause in
   let hyp = mkVar id in
   let hyp_typ = pf_type_of gl hyp in
   let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
-  let elimclause'' =
-    clenv_fchain_in id elim_flags hypmv elimclause' hypclause in
+  let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in
   let new_hyp_typ  = clenv_type elimclause'' in
   if eq_constr hyp_typ new_hyp_typ then
     errorlabstrm "general_rewrite_in"
@@ -855,8 +855,8 @@ let general_case_analysis_in_context with_evars (c,lbindc) gl =
 let general_case_analysis with_evars (c,lbindc as cx) =
   match kind_of_term c with
     | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id))
-	(general_case_analysis_in_context with_evars cx)
+	tclTHEN (try_intros_until_id_check id)
+	  (general_case_analysis_in_context with_evars cx)
     | _ ->
 	general_case_analysis_in_context with_evars cx
 
@@ -871,6 +871,7 @@ type conjunction_status =
 let make_projection sigma params cstr sign elim i n c =
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
+      (* bugs: goes from right to left when i increases! *)
       let (na,b,t) = List.nth cstr.cs_args i in
       let b = match b with None -> mkRel (i+1) | Some b -> b in
       let branch = it_mkLambda_or_LetIn b cstr.cs_args in
@@ -885,6 +886,7 @@ let make_projection sigma params cstr sign elim i n c =
       else
 	None
   | DefinedRecord l ->
+      (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
 	  let t = Typeops.type_of_constant (Global.env()) proj in
@@ -919,7 +921,7 @@ let descend_in_conjunctions tac exit c gl =
 	    | Some (p,pt) ->
 	    tclTHENS
 	      (internal_cut id pt)
-	      [refine_no_check p;
+	      [refine p; (* Might be ill-typed due to forbidden elimination. *)
 	       tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n)
 	  gl
     | None ->
@@ -961,9 +963,9 @@ let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
 	    with PretypeError _|RefinerError _|UserError _|Failure _|Exit ->
 	      if with_destruct then
                 descend_in_conjunctions
-                  try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl
+                  try_main_apply (fun _ -> Loc.raise loc exn) c gl
 	      else
-		Stdpp.raise_with_loc loc exn
+		Loc.raise loc exn
 	in try_red_apply thm_ty0
   in
   try_main_apply with_destruct c gl0
@@ -1023,8 +1025,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl =
 
 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 flags = if with_delta then elim_flags else elim_no_delta_flags in
   let t' = pf_get_hyp_typ gl0 id in
   let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in
   let rec aux with_destruct c gl =
@@ -1119,7 +1120,7 @@ let clear_wildcards ids =
     try with_check (Tacmach.thin_no_check [id]) gl
     with ClearDependencyError (id,err) ->
       (* Intercept standard [thin] error message *)
-      Stdpp.raise_with_loc loc
+      Loc.raise loc
         (error_clear_dependency (pf_env gl) (id_of_string "_") err))
     ids
 
@@ -1137,11 +1138,14 @@ let rec intros_clearing = function
 (* Modifying/Adding an hypothesis  *)
 
 let specialize mopt (c,lbind) g =
-  let term =
-    if lbind = NoBindings then c
+  let tac, term =
+    if lbind = NoBindings then 
+      let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in
+	tclEVARS evd, nf_evar evd c
     else
       let clause = make_clenv_binding g (c,pf_type_of g c) lbind in
-      let clause = clenv_unify_meta_types clause in
+      let flags = { default_unify_flags with resolve_evars = true } in
+      let clause = clenv_unify_meta_types ~flags clause in
       let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in
       let nargs = List.length tstack in
       let tstack = match mopt with
@@ -1158,16 +1162,18 @@ let specialize mopt (c,lbind) g =
 	errorlabstrm "" (str "Cannot infer an instance for " ++
           pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++
 	  str ".");
-      term
+       tclEVARS clause.evd, term
   in
   match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
        | Var id when List.mem id (pf_ids_of_hyps g) ->
-	     tclTHENFIRST
+	   tclTHEN tac
+	     (tclTHENFIRST
 	       (fun g -> internal_cut_replace id (pf_type_of g term) g)
-	       (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
+       | _ -> tclTHEN tac
+	   (tclTHENLAST
+              (fun g -> cut (pf_type_of g term) g)
+              (exact_no_check term)) g
 
 (* Keeping only a few hypotheses *)
 
@@ -1245,12 +1251,20 @@ let simplest_split = split NoBindings
 (* Decomposing introductions *)
 (*****************************)
 
+(* Rewriting function for rewriting one hypothesis at the time *)
 let forward_general_multi_rewrite =
   ref (fun _ -> failwith "general_multi_rewrite undefined")
 
+(* Rewriting function for substitution (x=t) everywhere at the same time *)
+let forward_subst_one =
+  ref (fun _ -> failwith "subst_one undefined")
+
 let register_general_multi_rewrite f =
   forward_general_multi_rewrite := f
 
+let register_subst_one f =
+  forward_subst_one := f
+
 let error_unexpected_extra_pattern loc nb pat =
   let s1,s2,s3 = match pat with
   | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
@@ -1284,6 +1298,8 @@ 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 (mkVar id,NoBindings) in
+  let subst_on l2r x rhs =
+    !forward_subst_one true x (id,rhs,l2r) in
   let clear_var_and_eq c =
     tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in
   let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in
@@ -1291,9 +1307,9 @@ 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 allHypsAndConcl) (clear_var_and_eq lhs) gl
+	subst_on l2r (destVar lhs) rhs gl
       else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then
-	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq rhs) gl
+	subst_on l2r (destVar rhs) lhs gl
       else
 	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
   | Some (hdcncl,[c]) ->
@@ -1315,57 +1331,65 @@ let rec explicit_intro_names = function
 | [] ->
     []
 
+let wild_id = id_of_string "_tmp"
+
+let rec list_mem_assoc_right id = function
+  | [] -> false
+  | (x,id')::l -> id = id' || list_mem_assoc_right id l
+
+let check_thin_clash_then id thin avoid tac =
+  if list_mem_assoc_right id thin then
+    let newid = next_ident_away (add_suffix id "'") avoid in
+    let thin =
+      List.map (on_snd (fun id' -> if id = id' then newid else id')) thin in
+    tclTHEN (rename_hyp [id,newid]) (tac thin)
+  else
+    tac thin
+
   (* We delay thinning until the completion of the whole intros tactic
      to ensure that dependent hypotheses are cleared in the right
      dependency order (see bug #1000); we use fresh names, not used in
      the tactic, for the hyps to clear *)
-let rec intros_patterns b avoid thin destopt = function
+let rec intros_patterns b avoid ids thin destopt tac = function
   | (loc, IntroWildcard) :: l ->
-      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)))
+      intro_then_gen loc (IntroBasedOn(wild_id,avoid@explicit_intro_names l))
+	no_move true false
+        (fun id -> intros_patterns b avoid ids ((loc,id)::thin) destopt tac l)
   | (loc, IntroIdentifier id) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroMustBe id) destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      check_thin_clash_then id thin avoid (fun thin ->
+        intro_then_gen loc (IntroMustBe id) destopt true false
+          (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l))
   | (loc, IntroAnonymous) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+	destopt true false
+        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
   | (loc, IntroFresh id) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
-	  destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      (* todo: avoid thinned names to interfere with generation of fresh name *)
+      intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
+	destopt true false
+        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
   | (loc, IntroForthcoming onlydeps) :: l ->
-      tclTHEN
-        (intro_forthcoming_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt onlydeps)
-        (intros_patterns b avoid thin destopt l)
+      intro_forthcoming_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+	  destopt onlydeps
+        (fun ids -> intros_patterns b avoid ids thin destopt tac l)
   | (loc, IntroOrAndPattern ll) :: l' ->
-      tclTHEN
-        introf
-        (onLastHypId
-	  (intro_or_and_pattern loc b ll l'
-	    (intros_patterns b avoid thin destopt)))
+      intro_then_force
+	(intro_or_and_pattern loc b ll l'
+	   (intros_patterns b avoid ids thin destopt tac))
   | (loc, IntroRewrite l2r) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l))
-	  no_move true false)
-        (onLastHypId (fun id ->
+      intro_then_gen loc (IntroAvoid(avoid@explicit_intro_names l))
+	no_move true false
+        (fun id ->
 	  tclTHENLAST (* Skip the side conditions of the rewriting step *)
 	    (rewrite_hyp l2r id)
-	    (intros_patterns b avoid thin destopt l)))
-  | [] -> clear_wildcards thin
+	    (intros_patterns b avoid ids thin destopt tac l))
+  | [] -> tac ids thin
 
-let intros_pattern = intros_patterns false [] []
+let intros_pattern destopt =
+  intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards)
 
-let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat]
+let intro_pattern destopt pat =
+  intros_pattern destopt [dloc,pat]
 
 let intro_patterns = function
   | [] -> tclREPEAT intro
@@ -1390,7 +1414,7 @@ let prepare_intros s ipat gl = match ipat with
   | IntroOrAndPattern ll -> make_id s gl,
       onLastHypId
 	(intro_or_and_pattern loc true ll []
-	  (intros_patterns true [] [] no_move))
+	  (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)))
   | IntroForthcoming _ -> user_err_loc
       (loc,"",str "Introduction pattern for one hypothesis expected")
 
@@ -1400,7 +1424,8 @@ let ipat_of_name = function
 
 let allow_replace c gl = function (* A rather arbitrary condition... *)
   | Some (_, IntroIdentifier id) ->
-      fst (decompose_app ((strip_lam_assum c))) = mkVar id
+      let c = fst (decompose_app ((strip_lam_assum c))) in
+      isVar c && destVar c = id
   | _ ->
       false
 
@@ -1422,7 +1447,8 @@ let as_tac id ipat = match ipat with
   | Some (loc,IntroRewrite l2r) ->
       !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
   | Some (loc,IntroOrAndPattern ll) ->
-      intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
+      intro_or_and_pattern loc true ll []
+        (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards))
         id
   | Some (loc,
       (IntroIdentifier _ | IntroAnonymous | IntroFresh _ |
@@ -1484,7 +1510,7 @@ let generalize_goal gl i ((occs,c,b),na) cl =
   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 cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
   let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
     mkProd_or_LetIn (na,b,t) cl'
 
@@ -1659,14 +1685,48 @@ let letin_tac with_eq name c occs gl =
 (* Implementation without generalisation: abbrev will be lost in hyps in *)
 (* in the extracted proof *)
 
-let letin_abstract id c (occs,check_occs) gl =
+let default_matching_flags sigma = {
+  modulo_conv_on_closed_terms = Some empty_transparent_state;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
+  resolve_evars = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = false;
+  frozen_evars =
+    fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars)
+      sigma ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = false;
+  allow_K_in_toplevel_higher_order_unification = false
+}
+
+let make_pattern_test env sigma0 (sigma,c) =
+  let flags = default_matching_flags sigma0 in
+  let matching_fun t =
+    try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t)
+    with _ -> raise NotUnifiable in
+  let merge_fun c1 c2 =
+    match c1, c2 with
+    | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) ->
+        raise NotUnifiable
+    | _ -> c1 in
+  { match_fun = matching_fun; merge_fun = merge_fun; 
+    testing_state = None; last_found = None },
+  (fun test -> match test.testing_state with
+   | None -> finish_evar_resolution env sigma0 (sigma,c)
+   | Some (sigma,_) -> nf_evar sigma c)
+
+let letin_abstract id c (test,out) (occs,check_occs) gl =
   let env = pf_env gl in
   let compute_dependency _ (hyp,_,_ as d) depdecls =
     match occurrences_of_hyp hyp occs with
       | None -> depdecls
       | Some occ ->
-          let newdecl = subst_term_occ_decl occ c d in
-          if occ = (all_occurrences,InHyp) & d = newdecl then
+          let newdecl = subst_closed_term_occ_decl_modulo occ test d in
+          if occ = (all_occurrences,InHyp) & eq_named_declaration d newdecl then
 	    if check_occs & not (in_every_hyp occs)
 	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
 	    else depdecls
@@ -1675,19 +1735,21 @@ let letin_abstract id c (occs,check_occs) gl =
   let depdecls = fold_named_context compute_dependency env ~init:[] in
   let ccl = match occurrences_of_goal occs with
     | None -> pf_concl gl
-    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in
+    | Some occ ->
+        subst1 (mkVar id) (subst_closed_term_occ_modulo occ test None (pf_concl gl)) in
   let lastlhyp =
     if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in
-  (depdecls,lastlhyp,ccl)
+  (depdecls,lastlhyp,ccl,out test)
 
-let letin_tac_gen with_eq name c ty occs gl =
+let letin_tac_gen with_eq name (sigmac,c) test ty occs gl =
   let id =
-    let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+    let t = match ty with Some t -> t | None -> typ_of (pf_env gl) sigmac c in
+    let x = id_of_name_using_hdchar (Global.env()) t name in
     if name = Anonymous then fresh_id [] x gl else
       if not (mem_named_context x (pf_hyps gl)) then x else
 	error ("The variable "^(string_of_id x)^" is already declared.") in
-  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in
-  let t = match ty with Some t -> t | None -> pf_type_of gl c in
+  let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in
+  let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in
   let newcl,eq_tac = match with_eq with
     | Some (lr,(loc,ido)) ->
       let heq = match ido with
@@ -1711,8 +1773,15 @@ let letin_tac_gen with_eq name c ty occs gl =
       tclMAP convert_hyp_no_check depdecls;
       eq_tac ] gl
 
-let letin_tac with_eq name c ty occs =
-  letin_tac_gen with_eq name c ty (occs,true)
+let make_eq_test c = (make_eq_test c,fun _ -> c)
+
+let letin_tac with_eq name c ty occs gl =
+  letin_tac_gen with_eq name (project gl,c) (make_eq_test c) ty (occs,true) gl
+
+let letin_pat_tac with_eq name c ty occs gl =
+  letin_tac_gen with_eq name c
+    (make_pattern_test (pf_env gl) (project gl) c)
+    ty (occs,true) gl
 
 (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
 let forward usetac ipat c gl =
@@ -1755,6 +1824,9 @@ let unfold_all x gl =
   if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl
   else tclIDTAC gl
 
+(* Either unfold and clear if defined or simply clear if not a definition *)
+let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
+
 (*****************************)
 (* High-level induction      *)
 (*****************************)
@@ -1797,16 +1869,6 @@ let check_unused_names names =
       (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) ->
-      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 _ | IntroForthcoming _ -> (* buggy *) no_move
-
 let rec consume_pattern avoid id isdep gl = function
   | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
   | (loc,IntroAnonymous)::names ->
@@ -1822,7 +1884,8 @@ let rec consume_pattern avoid id isdep gl = function
       ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
   | pat::names -> (pat,names)
 
-let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp =
+let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) =
+  let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in
   let newlstatus = (* if some IH has taken place at the top of hyps *)
     List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus
   in
@@ -1832,20 +1895,46 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp =
 
 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
+let safe_dest_intros_patterns avoid thin dest pat tac gl =
+  try intros_patterns true avoid [] thin dest tac pat gl
   with UserError ("move_hyp",_) ->
-    (* May happen if the lemma has dependent arguments that has resolved
-       only after cook_sign is called, e.g. as in 
+    (* May happen if the lemma has dependent arguments that are resolved
+       only after cook_sign is called, e.g. as in "destruct dec" in context
        "dec:forall x, {x=0}+{x<>0};  a:A  |- if dec a then True else False"
-       for argument a of dec which will be found only lately *)
-    intros_patterns true avoid [] no_move pat gl
+       where argument a of dec will be found only lately *)
+    intros_patterns true avoid [] [] no_move tac pat gl
 
 type elim_arg_kind = RecArg | IndArg | OtherArg
 
-let induct_discharge destopt avoid' tac (avoid,ra) names gl =
+type recarg_position =
+  | AfterFixedPosition of identifier option (* None = top of context *)
+
+let update_dest (recargdests,tophyp as dests) = function
+  | [] -> dests
+  | hyp::_ ->
+      (match recargdests with
+        | AfterFixedPosition None -> AfterFixedPosition (Some hyp)
+        | x -> x),
+       (match tophyp with None -> Some hyp | x -> x)
+
+let get_recarg_dest (recargdests,tophyp) =
+  match recargdests with
+  | AfterFixedPosition None -> MoveToEnd true
+  | AfterFixedPosition (Some id) -> MoveAfter id
+
+(* Current policy re-introduces recursive arguments of destructed
+   variable at the place of the original variable while induction
+   hypothesese are introduced at the top of the context. Since in the
+   general case of an inductive scheme, the induction hypotheses can
+   arrive just after the recursive arguments (e.g. as in "forall
+   t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need
+   to update the position for t2 after "P t1" is introduced if ever t2
+   had to be introduced at the top of the context).
+*)
+
+let induct_discharge dests avoid' tac (avoid,ra) names gl =
   let avoid = avoid @ avoid' in
-  let rec peel_tac ra names tophyp gl =
+  let rec peel_tac ra dests names thin gl =
     match ra with
     | (RecArg,deprec,recvarname) ::
         (IndArg,depind,hyprecname) :: ra' ->
@@ -1855,37 +1944,33 @@ let induct_discharge destopt avoid' tac (avoid,ra) names gl =
 	      (pat, [dloc, IntroIdentifier id'])
           | _ -> 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 *)
-        (* (or to have hypotheses classified by blocks...) *)
-        let newtophyp =
-	  if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp
-	in
-        tclTHENLIST
-	  [ safe_dest_intros_patterns avoid (update destopt tophyp) [recpat];
-	    safe_dest_intros_patterns avoid no_move [hyprec];
-	    peel_tac ra' names newtophyp] gl
+        let dest = get_recarg_dest dests in
+        safe_dest_intros_patterns avoid thin dest [recpat] (fun ids thin ->
+	safe_dest_intros_patterns avoid thin no_move [hyprec] (fun ids' thin ->
+	peel_tac ra' (update_dest dests ids') names thin))
+          gl
     | (IndArg,dep,hyprecname) :: ra' ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
         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
+	safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin ->
+        peel_tac ra' (update_dest dests ids) names thin) gl
     | (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
+        let dest = get_recarg_dest dests in
+	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin) gl
     | (OtherArg,_,_) :: ra' ->
         let pat,names = match names with
           | [] -> (dloc, IntroAnonymous), []
           | pat::names -> pat,names in
-	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
-          (peel_tac ra' names tophyp) gl
+        let dest = get_recarg_dest dests in
+	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin) gl
     | [] ->
         check_unused_names names;
-        tac tophyp gl
+        tclTHEN (clear_wildcards thin) (tac dests) gl
   in
-  peel_tac ra names no_move gl
+  peel_tac ra dests names [] 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
@@ -2063,8 +2148,13 @@ let cook_sign hyp0_opt indvars env =
       fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
     raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
   with Shunt lhyp0 ->
+    let lhyp0 = match lhyp0 with
+      | MoveToEnd true -> None
+      | MoveAfter hyp -> Some hyp
+      | _ -> assert false in
     let statuslists = (!lstatus,List.rev !rstatus) in
-    (statuslists, (if hyp0_opt=None then MoveToEnd true else lhyp0),
+    let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in
+    (statuslists, (recargdests,None),
      !indhyps, !decldeps)
 
 
@@ -2167,23 +2257,6 @@ let make_up_names n ind_opt cname =
       else avoid in
   id_of_string base, hyprecname, avoid
 
-let is_indhyp p n t =
-  let l, c = decompose_prod t 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 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
-  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.")
@@ -2194,8 +2267,6 @@ 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 coq_block = lazy (Coqlib.coq_constant "tactics" ["Program";"Equality"] "block")
-
 let mkEq t x y = 
   mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
     
@@ -2218,8 +2289,6 @@ let lift_togethern n l =
       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 ?(all=false) vars c =
@@ -2267,11 +2336,11 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
   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
+  let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in
     (* Abstract by the "generalized" hypothesis. *)
   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
+  let genctyp = it_mkProd_or_LetIn genarg ctx in
     (* The goal will become this product. *)
   let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in
     (* Apply the old arguments giving the proper instantiation of the hyp *)
@@ -2282,17 +2351,6 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
   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. *)
     mkApp (appeqs, abshypt)
-      
-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 [] 
@@ -2311,6 +2369,23 @@ let hyps_of_vars env sign nogen 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 is_defined_variable env id =
   pi2 (lookup_named id env) <> None
 
@@ -2337,6 +2412,7 @@ let abstract_args gl generalize_vars dep id defined f args =
     in
     let argty = pf_type_of gl arg in
     let argty = refresh_universes_strict argty in 
+    let ty = refresh_universes_strict ty in
     let lenctx = List.length ctx in
     let liftargty = lift lenctx argty in
     let leq = constr_cmp Reduction.CUMUL liftargty ty in
@@ -2364,23 +2440,19 @@ let abstract_args gl generalize_vars dep id defined f args =
 	    nongenvars, Idset.union argvars vars, env)
   in 
   let f', args' = decompose_indapp f args in
-  let parvars = ids_of_constr ~all:true Idset.empty f' in
-  let seen = ref parvars in
   let dogen, f', args' =
-    let find i x = not (isVar x) || 
-      let v = destVar x in
-	if is_defined_variable env v || Idset.mem v !seen then true
-	else (seen := Idset.add v !seen; false)
-    in
-      match array_find_i find args' with
-      | None -> false, f', args'
-      | Some nonvar ->
-	  let before, after = array_chop nonvar args' in
-	    true, mkApp (f', before), after
+    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) || is_defined_variable env (destVar 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',[],[],[],!seen,Idset.empty,env) args'
+      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = 
+	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args'
       in
       let args, refls = List.rev args, List.rev refls in
       let vars = 
@@ -2389,7 +2461,7 @@ let abstract_args gl generalize_vars dep id defined f args =
 	    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
+      let body, c' = if defined then Some c', typ_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
@@ -2429,20 +2501,20 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id 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 evars = ref (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 in_eqs && eq_constr eq (Lazy.force coq_eq) ->
+	| 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 in_eqs && eq_constr heq (Lazy.force coq_heq) ->
+	| 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
@@ -2454,10 +2526,8 @@ let specialize_eqs id gl =
 	    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)
-    | App (f, args) when eq_constr f (Lazy.force coq_block) && not in_eqs ->
-	aux true ctx acc args.(1)
     | t -> acc, in_eqs, ctx, ty
-  in
+  in 
   let acc, worked, ctx, ty = aux false [] (mkVar id) ty in
   let ctx' = nf_rel_context_evar !evars ctx in
   let ctx'' = List.map (fun (n,b,t as decl) ->
@@ -2485,33 +2555,6 @@ let occur_rel n c =
   let res = not (noccurn n c) in
   res
 
-let list_filter_firsts f l =
-  let rec list_filter_firsts_aux f acc l =
-    match l with
-      | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l'
-      | _ -> acc,l
-  in
-  list_filter_firsts_aux f [] l
-
-let count_rels_from n c =
-  let rels = free_rels c in
-  let cpt,rg = ref 0, ref n in
-  while Intset.mem !rg rels do
-    cpt:= !cpt+1; rg:= !rg+1;
-  done;
-  !cpt
-
-let count_nonfree_rels_from n c =
-  let rels = free_rels c in
-  if Intset.exists (fun x -> x >= n) rels then
-    let cpt,rg = ref 0, ref n in
-    while not (Intset.mem !rg rels) do
-      cpt:= !cpt+1; rg:= !rg+1;
-    done;
-    !cpt
-  else raise Not_found
-
-
 (* cuts a list in two parts, first of size n. Size must be greater than n *)
 let cut_list n l =
   let rec cut_list_aux acc n l =
@@ -2671,83 +2714,62 @@ let compute_elim_sig ?elimc elimt =
 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. *)
-  match scheme.indarg with
-    | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme."
-    | None -> (* Non standard scheme *)
-	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 =
-	  match kind_of_term c with
-	    | 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 =
-	  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 =
-		    make_up_names n scheme.indref names_info in
-		  let namesign =
-		    List.map (fun (b,dep) ->
-		      (b,dep,if b=IndArg then hyprecname else recvarname))
-		      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
-	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 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, 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 =
-	  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 =
-		    make_up_names n scheme.indref names_info in
-		  let namesign =
-		    List.map (fun (b,dep) ->
-		      (b,dep,if b=IndArg then hyprecname else recvarname))
-		      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"
-	    | [] ->
-		(* 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
-		  = extended_rel_list 0 scheme.args in
-		if not (ccl_arg_ok & ind_is_ok) then
-		  error_ind_scheme "the conclusion of";
-		[]
-	in
-	Array.of_list (find_branches 0 (List.rev scheme.branches))
+  let cond, check_concl =
+    match scheme.indarg with
+      | Some (_,Some _,_) ->
+	  error "Strange letin, cannot recognize an induction scheme."
+      | None -> (* Non standard scheme *)
+	  let cond hd = eq_constr hd ind_type_guess && not scheme.farg_in_concl
+	  in (cond, fun _ _ -> ())
+      | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
+	  let indhd,indargs = decompose_app ind in
+	  let cond hd = eq_constr hd indhd in
+	  let check_concl is_pred p =
+	    (* Check again conclusion *)
+	    let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
+	    let ind_is_ok =
+	      list_equal eq_constr
+		(list_lastn scheme.nargs indargs)
+		(extended_rel_list 0 scheme.args) in
+	    if not (ccl_arg_ok & ind_is_ok) then
+	      error_ind_scheme "the conclusion of"
+	  in (cond, check_concl)
+  in
+  let is_pred n c =
+    let hd = fst (decompose_app c) in
+    match kind_of_term hd with
+      | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
+      | _ when cond hd -> RecArg
+      | _ -> OtherArg
+  in
+  let rec check_branch p c =
+    match kind_of_term c with
+      | Prod (_,t,c) ->
+	(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
+      | 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 =
+    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 =
+	     make_up_names n scheme.indref names_info in
+	   let namesign =
+	     List.map (fun (b,dep) ->
+	       (b,dep,if b=IndArg then hyprecname else recvarname))
+	       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"
+      | [] -> check_concl is_pred p; []
+  in
+  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
@@ -2885,7 +2907,7 @@ let induction_tac_felim with_evars indvars nparams elim gl =
   (* elimclause' is built from elimclause by instanciating all args and params. *)
   let elimclause' = recolle_clenv nparams indvars elimclause gl in
   (* one last resolution (useless?) *)
-  let resolved = clenv_unique_resolver true elimclause' gl in
+  let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in
   clenv_refine with_evars resolved gl
 
 (* Apply induction "in place" replacing the hypothesis on which
@@ -2895,7 +2917,9 @@ let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names t
   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)))
+    (tclTHEN
+       (induct_tac elim)
+       (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))
     (array_map2 (induct_discharge destopt avoid tac) indsign names) gl
 
 (* Apply induction "in place" taking into account dependent
@@ -2979,7 +3003,7 @@ let induction_tac with_evars elim (varname,lbind) typ gl =
   let elimclause =
     make_clenv_binding gl
       (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in
-  elimination_clause_scheme with_evars true i elimclause indclause gl
+  elimination_clause_scheme with_evars i elimclause indclause gl
 
 let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names
   inhyps gl =
@@ -3017,14 +3041,6 @@ let induction_without_atomization isrec with_evars elim names lid gl =
   then error "Not the right number of induction arguments."
   else induction_from_context_l with_evars elim_info lid names gl
 
-let enforce_eq_name id gl = function
-  | (b,(loc,IntroAnonymous)) ->
-      (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl)))
-  | (b,(loc,IntroFresh heq_base)) ->
-      (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl)))
-  | x ->
-      x
-
 let has_selected_occurrences = function
   | None -> false
   | Some cls ->
@@ -3054,7 +3070,7 @@ let clear_unselected_context id inhyps cls gl =
 	  thin ids gl
       | None -> tclIDTAC gl
 
-let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
+let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl =
   let inhyps = match cls with
   | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
   | _ -> [] in
@@ -3067,14 +3083,17 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
 	  (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()) (typ_of (pf_env gl) sigma c)
 		  Anonymous in
 	let id = fresh_id [] x gl in
 	(* We need the equality name now *)
 	let with_eq = Option.map (fun eq -> (false,eq)) eqname in
 	(* TODO: if ind has predicate parameters, use JMeq instead of eq *)
 	tclTHEN
-	  (letin_tac_gen with_eq (Name id) c None (Option.default allHypsAndConcl cls,false))
+          (* Warning: letin is buggy when c is not of inductive type *)
+	  (letin_tac_gen with_eq (Name id) (sigma,c)
+             (make_pattern_test (pf_env gl) (project gl) (sigma,c))
+             None (Option.default allHypsAndConcl cls,false))
 	  (induction_with_atomization_of_ind_arg
 	     isrec with_evars elim names (id,lbind) inhyps) gl
 
@@ -3131,7 +3150,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
   assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
   if List.length lc = 1 && not (is_functional_induction elim gl) then
     (* standard induction *)
-    onInductionArg
+    onOpenInductionArg
       (fun c -> new_induct_gen isrec with_evars elim names c cls)
       (List.hd lc) gl
   else begin
@@ -3143,6 +3162,8 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
       str "Example: induction x1 x2 x3 using my_scheme.");
     if cls <> None then
       error "'in' clause not supported here.";
+    let lc = List.map
+      (map_induction_arg (pf_apply finish_evar_resolution gl)) lc in
     if List.length lc = 1 then
       (* Hook to recover standard induction on non-standard induction schemes *)
       (* will be removable when is_functional_induction will be more clever *)
@@ -3150,8 +3171,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
 	(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
+	  new_induct_gen_l isrec with_evars elim names [c]) (List.hd lc) gl
     else
       let newlc =
 	List.map (fun x ->
@@ -3179,11 +3199,8 @@ let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
 (* Induction tactics *)
 
 (* This was Induction before 6.3 (induction only in quantified premisses) *)
-let 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
+let simple_induct_id s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim)
+let simple_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim)
 
 let simple_induct = function
   | NamedHyp id -> simple_induct_id id
@@ -3213,9 +3230,9 @@ let elim_scheme_type elim t gl =
     | Meta mv ->
         let clause' =
 	  (* t is inductive, then CUMUL or CONV is irrelevant *)
-	  clenv_unify true Reduction.CUMUL t
+	  clenv_unify ~flags:elim_flags Reduction.CUMUL t
             (clenv_meta_type clause mv) clause in
-	res_pf clause' ~allow_K:true gl
+	res_pf clause' ~flags:elim_flags gl
     | _ -> anomaly "elim_scheme_type"
 
 let elim_type t gl =
@@ -3472,7 +3489,7 @@ let abstract_subproof id tac gl =
   let const = Pfedit.build_constant_by_tactic id secsign concl
     (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in
   let cd = Entries.DefinitionEntry const in
-  let lem = mkConst (Declare.declare_internal_constant id (cd,IsProof Lemma)) in
+  let lem = mkConst (Declare.declare_constant ~internal:Declare.KernelSilent id (cd,IsProof Lemma)) in
   exact_no_check
     (applist (lem,List.rev (Array.to_list (instance_from_named_context sign))))
     gl
@@ -3501,8 +3518,9 @@ let admit_as_an_axiom gl =
   let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
   if occur_existential concl then error"\"admit\" cannot handle existentials.";
   let axiom =
-    let cd = Entries.ParameterEntry (concl,false) in
-    let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in
+    let cd = 
+      Entries.ParameterEntry (Pfedit.get_used_variables(),concl,None) in
+    let con = Declare.declare_constant ~internal:Declare.KernelSilent na (cd,IsAssumption Logical) in
     constr_of_global (ConstRef con)
   in
   exact_no_check
@@ -3517,7 +3535,6 @@ let unify ?(state=full_transparent_state) x y gl =
 	modulo_delta = state;
 	modulo_conv_on_closed_terms = Some state}
     in
-    let evd = w_unify false (pf_env gl) Reduction.CONV
-      ~flags x y (Evd.create_evar_defs (project gl))
+    let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y
     in tclEVARS evd gl
   with _ -> tclFAIL 0 (str"Not unifiable") gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 5ceade1f..f8f32b79 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -26,14 +23,14 @@ open Libnames
 open Genarg
 open Tacexpr
 open Nametab
-open Rawterm
+open Glob_term
 open Pattern
 open Termops
-(*i*)
+open Unification
 
-(* Main tactics. *)
+(** Main tactics. *)
 
-(*s General functions. *)
+(** {6 General functions. } *)
 
 val string_of_inductive : constr -> string
 val head_constr       : constr -> constr * constr list
@@ -42,7 +39,7 @@ val is_quantified_hypothesis : identifier -> goal sigma -> bool
 
 exception Bound
 
-(*s Primitive tactics. *)
+(** {6 Primitive tactics. } *)
 
 val introduction    : identifier -> tactic
 val refine          : constr -> tactic
@@ -55,7 +52,7 @@ val fix             : identifier option -> int -> tactic
 val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
 val cofix           : identifier option -> tactic
 
-(*s Introduction tactics. *)
+(** {6 Introduction tactics. } *)
 
 val fresh_id_in_env : identifier list -> identifier -> env -> identifier
 val fresh_id : identifier list -> identifier -> goal sigma -> identifier
@@ -65,20 +62,21 @@ val intro                : tactic
 val introf               : tactic
 val intro_move        : identifier option -> identifier move_location -> tactic
 
-  (* [intro_avoiding idl] acts as intro but prevents the new identifier
+  (** [intro_avoiding idl] acts as intro but prevents the new identifier
      to belong to [idl] *)
 val intro_avoiding       : identifier list -> tactic
 
 val intro_replacing      : identifier -> tactic
 val intro_using          : identifier -> tactic
 val intro_mustbe_force   : identifier -> tactic
+val intro_then           : (identifier -> tactic) -> tactic
 val intros_using         : identifier list -> tactic
 val intro_erasing        : identifier -> tactic
 val intros_replacing     : identifier list -> tactic
 
 val intros               : tactic
 
-(* [depth_of_quantified_hypothesis b h g] returns the index of [h] in
+(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in
    the conclusion of goal [g], up to head-reduction if [b] is [true] *)
 val depth_of_quantified_hypothesis :
   bool -> quantified_hypothesis -> goal sigma -> int
@@ -88,7 +86,7 @@ val intros_until         : quantified_hypothesis -> tactic
 
 val intros_clearing      : bool list -> tactic
 
-(* Assuming a tactic [tac] depending on an hypothesis identifier,
+(** Assuming a tactic [tac] depending on an hypothesis identifier,
    [try_intros_until tac arg] first assumes that arg denotes a
    quantified hypothesis (denoted by name or by index) and try to
    introduce it in context before to apply [tac], otherwise assume the
@@ -97,21 +95,21 @@ val intros_clearing      : bool list -> tactic
 val try_intros_until :
   (identifier -> tactic) -> quantified_hypothesis -> tactic
 
-(* Apply a tactic on a quantified hypothesis, an hypothesis in context
+(** Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
 val onInductionArg :
   (constr with_bindings -> tactic) ->
     constr with_bindings induction_arg -> tactic
 
-(*s Introduction tactics with eliminations. *)
+(** {6 Introduction tactics with eliminations. } *)
 
 val intro_pattern  : identifier move_location -> intro_pattern_expr -> tactic
 val intro_patterns : intro_pattern_expr located list -> tactic
 val intros_pattern :
   identifier move_location -> intro_pattern_expr located list -> tactic
 
-(*s Exact tactics. *)
+(** {6 Exact tactics. } *)
 
 val assumption       : tactic
 val exact_no_check   : constr -> tactic
@@ -119,7 +117,7 @@ val vm_cast_no_check : constr -> tactic
 val exact_check      : constr -> tactic
 val exact_proof      : Topconstr.constr_expr -> tactic
 
-(*s Reduction tactics. *)
+(** {6 Reduction tactics. } *)
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
@@ -156,7 +154,7 @@ val pattern_option    :
 val reduce            : red_expr -> clause -> tactic
 val unfold_constr     : global_reference -> tactic
 
-(*s Modification of the local context. *)
+(** {6 Modification of the local context. } *)
 
 val clear         : identifier list -> tactic
 val clear_body    : identifier list -> tactic
@@ -169,7 +167,7 @@ val rename_hyp    : (identifier * identifier) list -> tactic
 
 val revert        : identifier list -> tactic
 
-(*s Resolution tactics. *)
+(** {6 Resolution tactics. } *)
 
 val apply_type : constr -> constr list -> tactic
 val apply_term : constr -> constr list -> tactic
@@ -193,7 +191,7 @@ val apply_in :
 
 val simple_apply_in : identifier -> constr -> tactic
 
-(*s Elimination tactics. *)
+(** {6 Elimination tactics. } *)
 
 
 (*
@@ -219,52 +217,52 @@ val simple_apply_in : identifier -> constr -> tactic
   Principles taken from functional induction have the final (f...).
 *)
 
-(* [rel_contexts] and [rel_declaration] actually contain triples, and
+(** [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_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 *)
-  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)
+  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 *)
+  args: rel_context;       (** (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;              (** number of arguments *)
+  indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni)
 				     if HI is in premisses, None otherwise *)
-  concl: types;            (* Qi x1...xni HI (f...), HI and (f...)
+  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 *)
+  indarg_in_concl: bool;   (** true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;     (** true if (f...) appears at the end of conclusion *)
 }
 
 
 val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme
 val rebuild_elimtype_from_scheme: elim_scheme -> types
 
-(* elim principle with the index of its inductive arg *)
+(** elim principle with the index of its inductive arg *)
 type eliminator = {
-  elimindex : int option;  (* None = find it automatically *)
+  elimindex : int option;  (** None = find it automatically *)
   elimbody : constr with_bindings
 }
 
-val elimination_clause_scheme : evars_flag ->
-  bool -> int -> clausenv -> clausenv -> tactic
+val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> 
+  int -> clausenv -> clausenv -> tactic
 
-val elimination_in_clause_scheme : evars_flag -> identifier -> int ->
-  clausenv -> clausenv -> tactic
+val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> 
+  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_bindings -> eliminator -> ?allow_K:bool -> tactic
-val general_elim_in : evars_flag ->
-  identifier -> constr with_bindings -> eliminator -> tactic
+  constr with_bindings -> eliminator -> tactic
+val general_elim_in : evars_flag -> identifier ->
+  constr with_bindings -> eliminator -> tactic
 
 val default_elim  : evars_flag -> constr with_bindings -> tactic
 val simplest_elim : constr -> tactic
@@ -273,37 +271,39 @@ val elim :
 
 val simple_induct : quantified_hypothesis -> tactic
 
-val new_induct : evars_flag -> constr with_bindings induction_arg list ->
+val new_induct : evars_flag -> 
+  (evar_map * constr with_bindings) induction_arg list ->
   constr with_bindings option ->
     intro_pattern_expr located option * intro_pattern_expr located option ->
       clause option -> tactic
 
-(*s Case analysis tactics. *)
+(** {6 Case analysis tactics. } *)
 
 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_bindings induction_arg list ->
+val new_destruct : evars_flag ->
+  (evar_map * constr with_bindings) induction_arg list ->
   constr with_bindings option ->
     intro_pattern_expr located option * intro_pattern_expr located option ->
       clause option -> tactic
 
-(*s Generic case analysis / induction tactics. *)
+(** {6 Generic case analysis / induction tactics. } *)
 
 val induction_destruct : rec_flag -> evars_flag ->
-  (constr with_bindings induction_arg list *
+  ((evar_map * 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. *)
+(** {6 Eliminations giving the type instead of the proof. } *)
 
 val case_type         : constr  -> tactic
 val elim_type         : constr  -> tactic
 
-(*s Some eliminations which are frequently used. *)
+(** {6 Some eliminations which are frequently used. } *)
 
 val impE : identifier -> tactic
 val andE : identifier -> tactic
@@ -313,7 +313,7 @@ val dAnd : clause -> tactic
 val dorE : bool -> clause ->tactic
 
 
-(*s Introduction tactics. *)
+(** {6 Introduction tactics. } *)
 
 val constructor_tac      : evars_flag -> int option -> int ->
   constr bindings -> tactic
@@ -332,7 +332,7 @@ val simplest_left        : tactic
 val simplest_right       : tactic
 val simplest_split       : tactic
 
-(*s Logical connective tactics. *)
+(** {6 Logical connective tactics. } *)
 
 val register_setoid_reflexivity : tactic -> unit
 val reflexivity_red             : bool -> tactic
@@ -362,13 +362,15 @@ val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic
 val forward   : tactic option -> intro_pattern_expr located option -> constr -> tactic
 val letin_tac : (bool * intro_pattern_expr located) option -> name ->
   constr -> types option -> clause -> tactic
+val letin_pat_tac : (bool * intro_pattern_expr located) option -> name ->
+  evar_map * constr -> types option -> clause -> tactic
 val assert_tac : name -> types -> tactic
 val assert_by  : name -> types -> tactic -> tactic
 val pose_proof : name -> constr -> tactic
 
 val generalize      : constr list -> tactic
 val generalize_gen  : ((occurrences * constr) * name) list -> tactic
-val generalize_dep  : ?with_let:bool (* Don't lose let bindings *) -> constr  -> tactic
+val generalize_dep  : ?with_let:bool (** Don't lose let bindings *) -> constr  -> tactic
 
 val unify           : ?state:Names.transparent_state -> constr -> constr -> tactic
 val resolve_classes : tactic
@@ -382,3 +384,6 @@ val specialize_eqs : identifier -> tactic
 
 val register_general_multi_rewrite :
   (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit
+
+val register_subst_one :
+  (bool -> identifier -> identifier * constr * bool -> tactic) -> unit
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index b885b152..333d6a3a 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -19,6 +19,4 @@ Leminv
 Tacinterp
 Evar_tactics
 Autorewrite
-Decl_interp
-Decl_proof_instr
 Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index a17aba76..b7a58be4 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: tauto.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Term
 open Hipattern
 open Names
@@ -55,6 +53,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "unfolding of iff and not in intuition";
       optkey   = ["Intuition";"Iff";"Unfolding"];
       optread  = (fun () -> !iff_unfolding);
@@ -154,10 +153,12 @@ let flatten_contravariant_disj ist =
 	let hyp = valueIn (VConstr ([],hyp)) in
 	iter_tac (list_map_i (fun i arg ->
 	  let typ = valueIn (VConstr ([],mkArrow arg c)) in
+	  let i = Tacexpr.Integer i in
 	  <:tactic<
             let typ := $typ in
             let hyp := $hyp in
-	    assert typ by (intro; apply hyp; constructor $i; assumption)
+	    let i := $i in
+	    assert typ by (intro; apply hyp; constructor i; assumption)
 	  >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
       else
 	<:tactic<fail>>
@@ -268,8 +269,6 @@ let t_reduction_not = tacticIn reduction_not
 let intuition_gen tac =
   interp (tacticIn (tauto_intuit t_reduction_not tac))
 
-let simplif_gen = interp (tacticIn simplif)
-
 let tauto_intuitionistic g =
   try intuition_gen <:tactic<fail>> g
   with
@@ -301,5 +300,5 @@ END
 
 TACTIC EXTEND intuition
 | [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
-| [ "intuition" tactic(t) ] -> [ intuition_gen (fst t) ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen t ]
 END
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
index 17329b6f..443acc6f 100644
--- a/tactics/termdn.ml
+++ b/tactics/termdn.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Nameops
 open Term
 open Pattern
-open Rawterm
+open Glob_term
 open Libnames
 open Nametab
 
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
index ccfa91a9..c4e747be 100644
--- a/tactics/termdn.mli
+++ b/tactics/termdn.mli
@@ -1,25 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Libnames
 open Names
-(*i*)
 
-(* Discrimination nets of terms. *)
+(** Discrimination nets of terms. *)
 
-(* This module registers actions (typically tactics) mapped to patterns *)
+(** This module registers actions (typically tactics) mapped to patterns *)
 
-(* Patterns are stocked linearly as the list of its node in prefix
+(** Patterns are stocked linearly as the list of its node in prefix
 order in such a way patterns having the same prefix have this common
 prefix shared and the seek for the action associated to the patterns
 that a term matches are found in time proportional to the maximal
@@ -38,21 +34,21 @@ sig
     
   val create : unit -> t
     
-  (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
+  (** [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] *)
+  (** [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 *)
+  (**/**)
+  (** These are for Nbtermdn *)
  
   type term_label = 
     | GRLabel of global_reference
@@ -68,5 +64,5 @@ sig
   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
index 98bab43b..cd5886f8 100644
--- a/test-suite/Makefile
+++ b/test-suite/Makefile
@@ -75,7 +75,7 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \
   interactive micromega $(COMPLEXITY) modules
 
 # All subsystems
-SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs
+SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide
 
 #######################################################################
 # Phony targets
@@ -94,12 +94,9 @@ clean:
 	rm -f trace lia.cache
 	$(SHOW) "RM        <**/*.stamp> <**/*.vo> <**/*.log>"
 	$(HIDE)find . \( \
-	  -name '*.stamp' -o -name '*.vo' -o -name '*.v.log' \
+	  -name '*.stamp' -o -name '*.vo' -o -name '*.log' \
 	\) -print0 | xargs -0 rm -f
 
-distclean: clean
-	$(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f
-
 #######################################################################
 # Per-subsystem targets
 #######################################################################
@@ -115,7 +112,7 @@ $(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S))))
 # Summary
 #######################################################################
 
-summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 tail -q -n1 | sort -g
+summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort -g
 
 .PHONY: summary summary.log
 
@@ -131,6 +128,7 @@ summary:
 	  $(call summary_dir, "Miscellaneous tests", misc); \
 	  $(call summary_dir, "Complexity tests", complexity); \
 	  $(call summary_dir, "Module tests", modules); \
+	  $(call summary_dir, "IDE tests", ide); \
 	  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`; \
@@ -271,7 +269,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v
 	    | grep -v "Welcome to Coq" \
 	    | grep -v "Skipping rcfile loading" \
 	    > $$tmpoutput; \
-	  diff $$tmpoutput $*.out 2>&1; R=$$?; times; \
+	  diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -354,7 +352,7 @@ $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.
 # Miscellaneous tests
 #######################################################################
 
-misc: misc/xml.log misc/deps-order.log
+misc: misc/xml.log misc/deps-order.log misc/universes.log
 
 # Test xml compilation
 xml: misc/xml.log
@@ -371,7 +369,7 @@ misc/xml.log:
 	  else \
 	    echo $(log_success); \
 	    echo "    misc/xml...apparently ok"; \
-	  fi; rm -r misc/xml; \
+	  fi; rm -rf misc/xml; \
 	} > "$@"
 
 # Check that both coqdep and coqtop/coqc takes the later -I/-R
@@ -386,7 +384,7 @@ misc/deps-order.log:
 	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
 	  $(coqdep) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \
 	    | head -n 1 > $$tmpoutput; \
-	  diff $$tmpoutput misc/deps/deps.out 2>&1; R=$$?; times; \
+	  diff -u misc/deps/deps.out $$tmpoutput 2>&1; R=$$?; times; \
 	  $(bincoqc) -I misc/deps/lib -as lib misc/deps/lib/foo.v 2>&1; \
 	  $(bincoqc) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \
 	  $(coqtop) -I misc/deps/lib -as lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \
@@ -400,3 +398,45 @@ misc/deps-order.log:
 	  fi; \
 	  rm $$tmpoutput; \
 	} > "$@"
+
+# Sort universes for the whole standard library
+EXPECTED_UNIVERSES := 3
+universes: misc/universes.log
+misc/universes.log: misc/universes/all_stdlib.v
+	@echo "TEST      misc/universes"
+	$(HIDE){ \
+	  $(bincoqc) -I misc/universes misc/universes/all_stdlib 2>&1; \
+	  $(bincoqc) -I misc/universes misc/universes/universes 2>&1; \
+	  mv universes.txt misc/universes; \
+	  N=`awk '{print $$3}' misc/universes/universes.txt | sort -u | wc -l`; \
+	  times; \
+	  if [ "$$N" -eq $(EXPECTED_UNIVERSES) ]; then \
+	    echo $(log_success); \
+	    echo "    misc/universes...Ok ($(EXPECTED_UNIVERSES) universes)"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    misc/universes...Error! ($$N/$(EXPECTED_UNIVERSES) universes)"; \
+	  fi; \
+	} > "$@"
+
+misc/universes/all_stdlib.v:
+	cd .. && $(MAKE) test-suite/$@
+
+
+# IDE : some tests of backtracking for coqtop -ideslave
+
+ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake))
+
+%.fake.log : %.fake
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(BIN)fake_ide "$(BIN)coqtop -boot" < $< 2>&1; \
+	  if [ $$? = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error!"; \
+	  fi; \
+	} > "$@"
diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v
index 490de2a6..3d145d96 100644
--- a/test-suite/bench/lists-100.v
+++ b/test-suite/bench/lists-100.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/bench/lists_100.v b/test-suite/bench/lists_100.v
index 490de2a6..3d145d96 100644
--- a/test-suite/bench/lists_100.v
+++ b/test-suite/bench/lists_100.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/bugs/closed/2105.v b/test-suite/bugs/closed/2105.v
new file mode 100644
index 00000000..46a416fd
--- /dev/null
+++ b/test-suite/bugs/closed/2105.v
@@ -0,0 +1,2 @@
+
+Definition id (T:Type) := Eval vm_compute in T.
diff --git a/test-suite/bugs/closed/shouldfail/2406.v b/test-suite/bugs/closed/shouldfail/2406.v
new file mode 100644
index 00000000..112ea2bb
--- /dev/null
+++ b/test-suite/bugs/closed/shouldfail/2406.v
@@ -0,0 +1,3 @@
+(* Check correct handling of unsupported notations *)
+Notation "'Â’'" := (fun x => x) (at level 20).
+Definition crash_the_rooster f := Â’.
diff --git a/test-suite/bugs/closed/shouldfail/2586.v b/test-suite/bugs/closed/shouldfail/2586.v
new file mode 100644
index 00000000..6111a641
--- /dev/null
+++ b/test-suite/bugs/closed/shouldfail/2586.v
@@ -0,0 +1,5 @@
+Require Import Setoid SetoidClass Program.
+
+Goal forall `(Setoid nat) x y, x == y -> S x == S y.
+  intros.
+  clsubst H0.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/1416.v b/test-suite/bugs/closed/shouldsucceed/1416.v
index da67d9b0..ee092005 100644
--- a/test-suite/bugs/closed/shouldsucceed/1416.v
+++ b/test-suite/bugs/closed/shouldsucceed/1416.v
@@ -1,3 +1,8 @@
+(* In 8.1 autorewrite used to raised an anomaly here *)
+(* After resolution of the bug, autorewrite succeeded *)
+(* From forthcoming 8.4, autorewrite is forbidden to instantiate *)
+(* evars, so the new test just checks it is not an anomaly *)
+
 Set Implicit Arguments.
 
 Record Place (Env A: Type) : Type := {
@@ -22,6 +27,4 @@ Lemma autorewrite_raise_anomaly: forall (Env A:Type) (e: Env) (p:Place Env A),
 Proof.
   intros Env A e p; eapply ex_intro.
   autorewrite with placeeq. (* Here is the bug *)
-  auto.
-Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v
index ea72ba89..f2ab9100 100644
--- a/test-suite/bugs/closed/shouldsucceed/1507.v
+++ b/test-suite/bugs/closed/shouldsucceed/1507.v
@@ -2,7 +2,6 @@
    Implementing reals a la Stolzenberg
 
    Danko Ilik, March 2007
-   svn revision: $Id: 1507.v 12337 2009-09-17 15:58:14Z glondu $
 
    XField.v -- (unfinished) axiomatisation of the theories of real and
                rational intervals.
diff --git a/test-suite/bugs/closed/shouldsucceed/1834.v b/test-suite/bugs/closed/shouldsucceed/1834.v
new file mode 100644
index 00000000..947d15f0
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1834.v
@@ -0,0 +1,174 @@
+(* This tests rather deep nesting of abstracted terms *)
+
+(* This used to fail before Nov 2011 because of a de Bruijn indice bug
+   in extract_predicate.
+
+   Note: use of eq_ok allows shorten notations but was not in the
+   original example
+*)
+
+Scheme eq_rec_dep := Induction for eq Sort Type.
+
+Section Teq.
+
+Variable P0:           Type.
+Variable P1: forall (y0:P0), Type.
+Variable P2: forall y0 (y1:P1 y0), Type.
+Variable P3: forall y0 y1 (y2:P2 y0 y1), Type.
+Variable P4: forall y0 y1 y2 (y3:P3 y0 y1 y2), Type.
+Variable P5: forall y0 y1 y2 y3 (y4:P4 y0 y1 y2 y3), Type.
+
+Variable x0:P0.
+
+Inductive eq0 : P0 -> Prop :=
+  refl0: eq0 x0.
+
+Definition eq_0 y0 := x0 = y0.
+
+Variable x1:P1 x0.
+
+Inductive eq1 : forall y0, P1 y0 -> Prop :=
+  refl1: eq1 x0 x1.
+
+Definition S0_0 y0 (e0:eq_0 y0) :=
+  eq_rec_dep P0 x0 (fun y0 e0 => P1 y0) x1 y0 e0.
+
+Definition eq_ok0 y0 y1 (E: eq_0 y0) := S0_0 y0 E = y1.
+
+Definition eq_1 y0 y1 :=
+  {E0:eq_0 y0 | eq_ok0 y0 y1 E0}.
+
+Variable x2:P2 x0 x1.
+
+Inductive eq2 :
+forall y0 y1, P2 y0 y1 -> Prop :=
+refl2: eq2 x0 x1 x2.
+
+Definition S1_0 y0 (e0:eq_0 y0) :=
+eq_rec_dep P0 x0 (fun y0 e0 => P2 y0 (S0_0 y0 e0)) x2 y0 e0.
+
+Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) :=
+  eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P2 y0 y1)
+   (S1_0 y0 e0)
+   y1 e1.
+
+Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) :=
+  match E with exist e0 e1 => S1_1 y0 y1 e0 e1 = y2 end.
+
+Definition eq_2 y0 y1 y2 :=
+  {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}.
+
+Variable x3:P3 x0 x1 x2.
+
+Inductive eq3 :
+forall y0 y1 y2, P3 y0 y1 y2 -> Prop :=
+refl3: eq3 x0 x1 x2 x3.
+
+Definition S2_0 y0 (e0:eq_0 y0) :=
+eq_rec_dep P0 x0 (fun y0 e0 => P3 y0 (S0_0 y0 e0) (S1_0 y0 e0)) x3 y0 e0.
+
+Definition S2_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) :=
+  eq_rec_dep (P1 y0) (S0_0 y0 e0)
+   (fun y1 e1 => P3 y0 y1 (S1_1 y0 y1 e0 e1))
+   (S2_0 y0 e0)
+   y1 e1.
+
+Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) :=
+  eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1)
+   (fun y2 e2 => P3 y0 y1 y2)
+   (S2_1 y0 y1 e0 e1)
+   y2 e2.
+
+Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop :=
+  match E with exist (exist e0 e1) e2 =>
+     S2_2 y0 y1 y2 e0 e1 e2 = y3 end.
+
+Definition eq_3 y0 y1 y2 y3 :=
+  {E2: eq_2 y0 y1 y2 | eq_ok2 y0 y1 y2 y3 E2}.
+
+Variable x4:P4 x0 x1 x2 x3.
+
+Inductive eq4 :
+forall y0 y1 y2 y3, P4 y0 y1 y2 y3 -> Prop :=
+refl4: eq4 x0 x1 x2 x3 x4.
+
+Definition S3_0 y0 (e0:eq_0 y0) :=
+eq_rec_dep P0 x0 (fun y0 e0 => P4 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0))
+  x4 y0 e0.
+
+Definition S3_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) :=
+  eq_rec_dep (P1 y0) (S0_0 y0 e0)
+   (fun y1 e1 => P4 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1))
+   (S3_0 y0 e0)
+   y1 e1.
+
+Definition S3_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) :=
+  eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1)
+   (fun y2 e2 => P4 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2))
+   (S3_1 y0 y1 e0 e1)
+   y2 e2.
+
+Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):=
+  eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2)
+   (fun y3 e3 => P4 y0 y1 y2 y3)
+   (S3_2 y0 y1 y2 e0 e1 e2)
+   y3 e3.
+
+Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop :=
+  match E with exist (exist (exist e0 e1) e2) e3 =>
+     S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end.
+
+Definition eq_4 y0 y1 y2 y3 y4 :=
+  {E3: eq_3 y0 y1 y2 y3 | eq_ok3 y0 y1 y2 y3 y4 E3}.
+
+Variable x5:P5 x0 x1 x2 x3 x4.
+
+Inductive eq5 :
+forall y0 y1 y2 y3 y4, P5 y0 y1 y2 y3 y4 -> Prop :=
+refl5: eq5 x0 x1 x2 x3 x4 x5.
+
+Definition S4_0 y0 (e0:eq_0 y0) :=
+eq_rec_dep P0 x0
+(fun y0 e0 => P5 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0) (S3_0 y0 e0))
+  x5 y0 e0.
+
+Definition S4_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) :=
+  eq_rec_dep (P1 y0) (S0_0 y0 e0)
+   (fun y1 e1 => P5 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1) (S3_1 y0 y1 e0
+e1))
+   (S4_0 y0 e0)
+   y1 e1.
+
+Definition S4_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) :=
+  eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1)
+   (fun y2 e2 => P5 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2) (S3_2 y0 y1 y2 e0 e1 e2))
+   (S4_1 y0 y1 e0 e1)
+   y2 e2.
+
+Definition S4_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):=
+  eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2)
+   (fun y3 e3 => P5 y0 y1 y2 y3 (S3_3 y0 y1 y2 y3 e0 e1 e2 e3))
+   (S4_2 y0 y1 y2 e0 e1 e2)
+   y3 e3.
+
+Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
+  (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3)
+  (e4:S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4) :=
+  eq_rec_dep (P4 y0 y1 y2 y3) (S3_3 y0 y1 y2 y3 e0 e1 e2 e3)
+   (fun y4 e4 => P5 y0 y1 y2 y3 y4)
+   (S4_3 y0 y1 y2 y3 e0 e1 e2 e3)
+   y4 e4.
+
+Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop :=
+  match E with exist (exist (exist (exist e0 e1) e2) e3) e4 =>
+     S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end.
+
+Definition eq_5 y0 y1 y2 y3 y4 y5 :=
+  {E4: eq_4 y0 y1 y2 y3 y4 | eq_ok4 y0 y1 y2 y3 y4 y5 E4 }.
+
+End Teq.
diff --git a/test-suite/bugs/closed/shouldsucceed/1912.v b/test-suite/bugs/closed/shouldsucceed/1912.v
new file mode 100644
index 00000000..987a5417
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1912.v
@@ -0,0 +1,6 @@
+Require Import ZArith.
+
+Goal forall x, Z.succ (Z.pred x) = x.
+intros x.
+omega.
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/1962.v b/test-suite/bugs/closed/shouldsucceed/1962.v
new file mode 100644
index 00000000..a6b0fee5
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1962.v
@@ -0,0 +1,55 @@
+(* Bug 1962.v
+
+Bonjour,
+
+J'ai un exemple de lemme que j'arrivais à prouver avec fsetdec avec la 8.2beta3
+avec la beta4 et la version svn 11447 branche 8.2 çà diverge.
+
+Voici l'exemple en question, l'exmple test2 marche bien dans les deux version,
+test en revanche pose probleme:
+
+*)
+
+Require Export FSets.
+
+(** This module takes a decidable type and
+build finite sets of this type, tactics and defs *)
+
+Module BuildFSets (DecPoints: UsualDecidableType).
+
+Module Export FiniteSetsOfPoints := FSetWeakList.Make DecPoints.
+Module Export FiniteSetsOfPointsProperties :=
+ WProperties FiniteSetsOfPoints.
+Module Export Dec := WDecide FiniteSetsOfPoints.
+Module Export FM := Dec.F.
+
+Definition set_of_points := t.
+Definition Point := DecPoints.t.
+
+Definition couple(x y :Point) : set_of_points :=
+add x (add y empty).
+
+Definition triple(x y t :Point): set_of_points :=
+add x (add y (add t empty)).
+
+Lemma test : forall P A B C A' B' C',
+Equal
+(union (singleton P) (union (triple A B C) (triple A' B' C')))
+(union (triple P B B') (union (couple P A) (triple C A' C'))).
+Proof.
+intros.
+unfold triple, couple.
+Time fsetdec. (* works in 8.2 beta 3, not in beta 4 and final 8.2 *)
+              (* appears to works again in 8.3 and trunk, take 4-6 seconds *)
+Qed.
+
+Lemma test2 : forall A B C,
+Equal
+ (union (singleton C) (couple A B)) (triple A B C).
+Proof.
+intros.
+unfold triple, couple.
+Time fsetdec.
+Qed.
+
+End BuildFSets.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2127.v b/test-suite/bugs/closed/shouldsucceed/2127.v
index 20ea4603..0fc854b6 100644
--- a/test-suite/bugs/closed/shouldsucceed/2127.v
+++ b/test-suite/bugs/closed/shouldsucceed/2127.v
@@ -6,6 +6,3 @@
 Module A.
 Hint Rewrite sym_equal using apply refl_equal : foo.
 End A.
-
-
-
diff --git a/test-suite/bugs/closed/shouldsucceed/2141.v b/test-suite/bugs/closed/shouldsucceed/2141.v
new file mode 100644
index 00000000..941ae530
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2141.v
@@ -0,0 +1,14 @@
+Require Import FSetList.
+Require Import OrderedTypeEx.
+
+Module NatSet := FSetList.Make (Nat_as_OT).
+Recursive Extraction NatSet.fold.
+
+Module FSetHide (X : FSetInterface.S).
+  Include X.
+End FSetHide.
+
+Module NatSet' := FSetHide NatSet.
+Recursive Extraction NatSet'.fold.
+
+(* Extraction "test2141.ml" NatSet'.fold. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2181.v b/test-suite/bugs/closed/shouldsucceed/2181.v
new file mode 100644
index 00000000..62820d86
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2181.v
@@ -0,0 +1,3 @@
+Class C.
+Parameter P: C -> Prop.
+Fail Record R: Type := { _: C; u: P _ }.
diff --git a/test-suite/bugs/closed/shouldsucceed/2304.v b/test-suite/bugs/closed/shouldsucceed/2304.v
new file mode 100644
index 00000000..1ac2702b
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2304.v
@@ -0,0 +1,4 @@
+(* This used to fail with an anomaly NotASort at some time *)
+Class A (O: Type): Type := a: O -> Type.
+Fail Goal forall (x: a tt), @a x = @a x.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2307.v b/test-suite/bugs/closed/shouldsucceed/2307.v
new file mode 100644
index 00000000..7c049495
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2307.v
@@ -0,0 +1,3 @@
+Inductive V: nat -> Type := VS n: V (S n).
+Definition f (e: V 1): nat := match e with VS 0 => 3 end.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2320.v b/test-suite/bugs/closed/shouldsucceed/2320.v
new file mode 100644
index 00000000..facb9ecf
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2320.v
@@ -0,0 +1,14 @@
+(* Managing metavariables in the return clause of a match *)
+
+(* This was working in 8.1 but is failing in 8.2 and 8.3. It works in
+   trunk thanks to the new proof engine. It could probably made to work in
+   8.2 and 8.3 if a return predicate of the form "dummy 0" instead of
+   (or in addition to) a sophisticated predicate of the form 
+   "as x in dummy y return match y with 0 => ?P | _ => ID end" *)
+
+Inductive dummy : nat -> Prop := constr : dummy 0.
+
+Lemma failure : forall (x : dummy 0), x = constr.
+Proof.
+intros x.
+refine (match x with constr => _ end).
diff --git a/test-suite/bugs/closed/shouldsucceed/2342.v b/test-suite/bugs/closed/shouldsucceed/2342.v
new file mode 100644
index 00000000..094e5466
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2342.v
@@ -0,0 +1,8 @@
+(* Checking that the type inference algoithme does not commit to an
+   equality over sorts when only a subtyping constraint is around *)
+
+Parameter A : Set.
+Parameter B : A -> Set.
+Parameter F : Set -> Prop. 
+Check (F (forall x, B x)). 
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2362.v b/test-suite/bugs/closed/shouldsucceed/2362.v
new file mode 100644
index 00000000..febb9c7b
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2362.v
@@ -0,0 +1,38 @@
+Set Implicit Arguments.
+
+Class Pointed (M:Type -> Type) := 
+{
+  creturn: forall {A: Type}, A -> M A
+}.
+
+Unset Implicit Arguments.
+Inductive FPair (A B:Type) (neutral: B) : Type:=
+ fpair : forall (a:A) (b:B), FPair A B neutral.
+Implicit Arguments fpair [[A] [B] [neutral]].
+
+Set Implicit Arguments.
+
+Notation "( x ,> y )" := (fpair x y) (at level 0).
+
+Instance Pointed_FPair B neutral:
+ Pointed (fun A => FPair A B neutral) :=
+ { creturn := fun A (a:A) => (a,> neutral) }.
+Definition blah_fail (x:bool) : FPair bool nat O :=
+  creturn x.
+Set Printing All. Print blah_fail.
+
+Definition blah_explicit (x:bool) : FPair bool nat O :=
+  @creturn _ (Pointed_FPair _ ) _ x.
+
+Print blah_explicit.
+
+
+Instance Pointed_FPair_mono:
+ Pointed (fun A => FPair A nat 0) :=
+ { creturn := fun A (a:A) => (a,> 0) }.
+
+
+Definition blah (x:bool) : FPair bool nat O :=
+  creturn x.
+
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2378.v b/test-suite/bugs/closed/shouldsucceed/2378.v
new file mode 100644
index 00000000..7deec64d
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2378.v
@@ -0,0 +1,608 @@
+(* test with Coq 8.3rc1 *)
+
+Require Import Program.
+
+Inductive Unit: Set := unit: Unit.
+
+Definition eq_dec T := forall x y:T, {x=y}+{x<>y}.
+
+Section TTS_TASM.
+
+Variable Time: Set.
+Variable Zero: Time.
+Variable tle: Time -> Time -> Prop.
+Variable tlt: Time -> Time -> Prop.
+Variable tadd: Time -> Time -> Time.
+Variable tsub: Time -> Time -> Time.
+Variable tmin: Time -> Time -> Time.
+Notation "t1 @<= t2" := (tle t1 t2) (at level 70, no associativity).
+Notation "t1 @< t2" := (tlt t1 t2) (at level 70, no associativity).
+Notation "t1 @+ t2" := (tadd t1 t2) (at level 50, left associativity).
+Notation "t1 @- t2" := (tsub t1 t2) (at level 50, left associativity).
+Notation "t1 @<= t2 @<= t3" := ((tle t1 t2) /\ (tle t2 t3)) (at level 70, t2 at next level).
+Notation "t1 @<= t2 @< t3" := ((tle t1 t2) /\ (tlt t2 t3)) (at level 70, t2 at next level).
+
+Variable tzerop: forall n, (n = Zero) + {Zero @< n}.
+Variable tlt_eq_gt_dec: forall x y, {x @< y} + {x=y} + {y @< x}.
+Variable tle_plus_l: forall n m, n @<= n @+ m.
+Variable tle_lt_eq_dec: forall n m, n @<= m -> {n @< m} + {n = m}.
+
+Variable tzerop_zero: tzerop Zero = inleft (Zero @< Zero) (@eq_refl _ Zero).
+Variable tplus_n_O: forall n, n @+ Zero = n.
+Variable tlt_le_weak: forall n m, n @< m -> n @<= m.
+Variable tlt_irrefl: forall n, ~ n @< n.
+Variable tplus_nlt: forall n m, ~n @+ m @< n.
+Variable tle_n: forall n, n @<= n.
+Variable tplus_lt_compat_l: forall n m p, n @< m -> p @+ n @< p @+ m.
+Variable tlt_trans: forall n m p, n @< m -> m @< p -> n @< p.
+Variable tle_lt_trans: forall n m p, n @<= m -> m @< p -> n @< p.
+Variable tlt_le_trans: forall n m p, n @< m -> m @<= p -> n @< p.
+Variable tle_refl: forall n, n @<= n.
+Variable tplus_le_0: forall n m, n @+ m @<= n -> m = Zero.
+Variable Time_eq_dec: eq_dec Time.
+
+(*************************************************************)
+
+Section PropLogic.
+Variable Predicate: Type.
+
+Inductive LP: Type :=
+  LPPred: Predicate -> LP
+| LPAnd: LP -> LP -> LP
+| LPNot: LP -> LP.
+
+Variable State: Type.
+Variable Sat: State -> Predicate -> Prop.
+
+Fixpoint lpSat st f: Prop :=
+  match f with
+    LPPred p => Sat st p
+  | LPAnd f1 f2 => lpSat st f1 /\ lpSat st f2
+  | LPNot f1 => ~lpSat st f1
+  end.
+End PropLogic.
+
+Implicit Arguments lpSat.
+
+Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 :=
+  match f with
+    LPPred p => p2lp p
+  | LPAnd f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2)
+  | LPNot f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1)
+  end.
+Implicit Arguments LPTransfo.
+
+Definition addIndex (Ind:Type) (Pred: Ind -> Type) (i: Ind) f := 
+  LPTransfo (fun p => LPPred _ (existT (fun i => Pred i) i p)) f.
+
+Section TTS.
+
+Variable State: Type.
+
+Record TTS: Type := mkTTS {
+  Init: State -> Prop;
+  Delay: State -> Time -> State -> Prop;
+  Next: State -> State -> Prop;
+  Predicate: Type;
+  Satisfy: State -> Predicate -> Prop
+}.
+
+Definition TTSIndexedProduct Ind (tts: Ind -> TTS): TTS := mkTTS
+  (fun st => forall i, Init (tts i) st)
+  (fun st d st' => forall i, Delay (tts i) st d st')
+  (fun st st' => forall i, Next (tts i) st st')
+  { i: Ind & Predicate (tts i) }
+  (fun st p => Satisfy (tts (projT1 p)) st (projT2 p)).
+
+End TTS.
+
+Section SIMU_F.
+
+Variables StateA StateC: Type.
+
+Record mapping: Type := mkMapping {
+  mState: Type;
+  mInit: StateC -> mState;
+  mNext: mState -> StateC -> mState;
+  mDelay: mState -> StateC -> Time -> mState;
+  mabs: mState -> StateC -> StateA
+}.
+
+Variable m: mapping.
+
+Record simu (Pred: Type) (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuPrf {
+  inv: (mState m) -> StateC -> Prop;
+  invInit: forall st, Init _ c st -> inv (mInit m st) st;
+  invDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> inv (mDelay m ex1 st1 d) st2;
+  invNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> inv (mNext m ex1 st1) st2;
+  simuInit: forall st, Init _ c st -> Init _ a (mabs m (mInit m st) st);
+  simuDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 ->
+    Delay _ a (mabs m ex1 st1) d (mabs m (mDelay m ex1 st1 d) st2);
+  simuNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 ->
+    Next _ a (mabs m ex1 st1) (mabs m (mNext m ex1 st1) st2);
+  simuPred: forall ext st, inv ext st -> 
+    (forall p, lpSat (Satisfy _ c) st (trc p) <-> lpSat (Satisfy _ a) (mabs m ext st) (tra p)) 
+}.
+
+Theorem satProd: forall State Ind Pred (Sat: forall i, State -> Pred i -> Prop) (st:State) i (f: LP (Pred i)),
+  lpSat (Sat i) st f
+  <->
+  lpSat
+    (fun (st : State) (p : {i : Ind &  Pred i}) => Sat (projT1 p) st (projT2 p)) st
+     (addIndex Ind _ i f).
+Proof.
+  induction f; simpl; intros; split; intros; intuition.
+Qed.
+
+Definition trProd (State: Type) Ind (Pred: Ind -> Type) (tts: Ind -> TTS State) (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))):
+  {i:Ind & Pred i} -> LP (Predicate _ (TTSIndexedProduct _ Ind tts)) :=
+  fun p => addIndex Ind _ (projS1 p) (tr (projS1 p) (projS2 p)).
+
+Implicit Arguments trProd.
+Require Import Setoid.
+
+Theorem satTrProd:
+  forall State Ind Pred (tts: Ind -> TTS State) 
+    (tr: forall i, (Pred  i) -> LP (Predicate _ (tts i))) (st:State) (p: {i:Ind & (Pred i)}),
+  lpSat (Satisfy _ (tts (projS1 p))) st (tr (projS1 p) (projS2 p))
+  <->
+  lpSat (Satisfy _ (TTSIndexedProduct _ _ tts)) st (trProd _ tts tr p).
+Proof.
+  unfold trProd, TTSIndexedProduct; simpl; intros.
+  rewrite (satProd State Ind (fun i => Predicate State (tts i))
+                      (fun i => Satisfy _ (tts i))); tauto.
+Qed.
+
+Theorem simuProd: 
+  forall Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) 
+    (tra: forall i, (Pred i) -> LP (Predicate _ (tta i)))
+    (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))),
+     (forall i, simu _ (tta i) (ttc i) (tra i) (trc i)) -> 
+       simu _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc)
+                  (trProd Pred tta tra) (trProd Pred ttc trc).
+Proof.
+  intros.
+  apply simuPrf with (fun ex st => forall i, inv _ _ (ttc i) (tra i) (trc i) (X i) ex st); simpl; intros; auto.
+  eapply invInit; eauto.
+  eapply invDelay; eauto.
+  eapply invNext; eauto.
+  eapply simuInit; eauto.
+  eapply simuDelay; eauto.
+  eapply simuNext; eauto.
+  split; simpl; intros.
+  generalize (proj1 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro.
+  rewrite <- (satTrProd StateA Ind Pred tta tra); apply H1.
+  rewrite (satTrProd StateC Ind Pred ttc trc); apply H0.
+
+  generalize (proj2 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro.
+  rewrite <- (satTrProd StateC Ind Pred ttc trc); apply H1.
+  rewrite (satTrProd StateA Ind Pred tta tra); apply H0.
+Qed.
+
+End SIMU_F.
+
+Section TRANSFO.
+
+Record simu_equiv StateA StateC m1 m2 Pred (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuEquivPrf {
+  simuLR: simu StateA StateC m1 Pred a c tra trc;
+  simuRL: simu StateC StateA m2 Pred c a trc tra
+}.
+
+Theorem simu_equivProd: 
+  forall StateA StateC m1 m2 Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) 
+    (tra: forall i, (Pred i) -> LP (Predicate _ (tta i)))
+    (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))),
+     (forall i, simu_equiv StateA StateC m1 m2 _ (tta i) (ttc i) (tra i) (trc i)) -> 
+       simu_equiv StateA StateC m1 m2 _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc)
+                  (trProd _ _ Pred tta tra) (trProd _ _ Pred ttc trc).
+Proof.
+  intros; split; intros.
+  apply simuProd; intro.
+  elim (X i); auto.
+  apply simuProd; intro.
+  elim (X i); auto.
+Qed.
+
+Record RTLanguage: Type := mkRTLanguage {
+   Syntax: Type;
+   DynamicState: Syntax -> Type;
+   Semantic: forall (mdl:Syntax), TTS (DynamicState mdl);
+   MdlPredicate: Syntax -> Type;
+   MdlPredicateDefinition: forall mdl, MdlPredicate mdl -> LP (Predicate _ (Semantic mdl))
+}.
+
+Record Transformation (l1 l2: RTLanguage): Type := mkTransformation {
+  Tmodel: Syntax l1 -> Syntax l2;
+  Tl1l2: forall mdl, mapping (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl));
+  Tl2l1: forall mdl, mapping (DynamicState l2 (Tmodel mdl)) (DynamicState l1 mdl);
+  Tpred: forall mdl, MdlPredicate l1 mdl -> LP (MdlPredicate l2 (Tmodel mdl));
+  Tsim: forall mdl, simu_equiv (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)) (Tl1l2 mdl) (Tl2l1 mdl)
+    (MdlPredicate l1 mdl) (Semantic l1 mdl) (Semantic l2 (Tmodel mdl))
+    (MdlPredicateDefinition l1 mdl)
+    (fun p => LPTransfo (MdlPredicateDefinition l2 (Tmodel mdl)) (Tpred mdl p))
+}.
+
+Section Product.
+
+Record PSyntax (L: RTLanguage): Type := mkPSyntax {
+  pIndex: Type;
+  pIsEmpty: pIndex + {pIndex -> False};
+  pState: Type;
+  pComponents: pIndex -> Syntax L;
+  pIsShared: forall i, DynamicState L (pComponents i) = pState
+}.
+
+Definition pPredicate (L: RTLanguage) (sys: PSyntax L) := { i : pIndex L sys & MdlPredicate L (pComponents L sys i)}.
+
+(* product with shared state *)
+
+Definition PLanguage (L: RTLanguage): RTLanguage := 
+  mkRTLanguage
+    (PSyntax L)
+    (pState L)
+    (fun mdl => TTSIndexedProduct (pState L mdl) (pIndex L mdl)
+      (fun i => match pIsShared L mdl i in (_ = y) return TTS y with
+        eq_refl => Semantic L (pComponents L mdl i)
+       end))
+    (pPredicate L)
+    (fun mdl => trProd _ _ _ _ 
+      (fun i pi => match pIsShared L mdl i as e in (_ = y) return
+                     (LP (Predicate y
+                               match e in (_ = y0) return (TTS y0) with
+                               | eq_refl => Semantic L (pComponents L mdl i)
+                               end))
+     with
+     | eq_refl => MdlPredicateDefinition L (pComponents L mdl i) pi
+     end)).
+
+Inductive Empty: Type :=.
+
+Record isSharedTransfo l1 l2 tr: Prop := isSharedTransfoPrf {
+sameState:  forall mdl i j, 
+  DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) =
+  DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j));
+sameMState: forall mdl i j, 
+  mState _ _  (Tl1l2 _ _ tr (pComponents l1 mdl i)) =
+  mState _ _  (Tl1l2 _ _ tr (pComponents l1 mdl j));
+sameM12: forall mdl i j, 
+  Tl1l2 _ _ tr (pComponents l1 mdl i) =
+  match sym_eq (sameState mdl i j) in _=y return mapping _ y with
+    eq_refl => match sym_eq (pIsShared l1 mdl i) in _=x return mapping x _ with
+      eq_refl => match pIsShared l1 mdl j in _=x return mapping x _ with
+        eq_refl => Tl1l2 _ _ tr (pComponents l1 mdl j)
+      end
+    end         
+  end;
+sameM21: forall mdl i j, 
+  Tl2l1 l1 l2 tr (pComponents l1 mdl i) =
+  match
+    sym_eq (sameState mdl i j) in (_ = y)
+    return (mapping y (DynamicState l1 (pComponents l1 mdl i)))
+  with eq_refl =>
+    match
+      sym_eq (pIsShared l1 mdl i) in (_ = y)
+      return
+        (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y)
+    with
+    | eq_refl =>
+        match
+          pIsShared l1 mdl j in (_ = y)
+          return
+            (mapping
+               (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y)
+        with
+        | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl j)
+        end
+    end
+end
+}.
+
+Definition PTransfoSyntax l1 l2 tr (h: isSharedTransfo l1 l2 tr) mdl :=
+  mkPSyntax l2 (pIndex l1 mdl)
+    (pIsEmpty l1 mdl)
+    (match pIsEmpty l1 mdl return Type with 
+         inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))
+        |inright h => pState l1 mdl
+       end)
+    (fun i => Tmodel l1 l2 tr (pComponents l1 mdl i))
+    (fun i => match pIsEmpty l1 mdl as y return
+        (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) =
+         match y with
+         | inleft i0 =>
+             DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i0))
+         | inright _ => pState l1 mdl
+         end)
+      with
+         inleft j => sameState l1 l2 tr h mdl i j 
+      | inright h => match h i with end
+        end).
+
+Definition compSemantic l mdl i :=
+    match pIsShared l mdl i in (_=y) return TTS y with
+        eq_refl => Semantic l (pComponents l mdl i)
+    end.
+
+Definition compSemanticEq l mdl i s (e: DynamicState l (pComponents l mdl i) = s) :=
+    match e in (_=y) return TTS y with
+        eq_refl => Semantic l (pComponents l mdl i)
+    end.
+
+Definition Pmap12 l1 l2 tr (h: isSharedTransfo l1 l2 tr) (mdl : PSyntax l1) :=
+match
+  pIsEmpty l1 mdl as s
+  return
+    (mapping (pState l1 mdl)
+       match s with
+       | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))
+       | inright _ => pState l1 mdl
+       end)
+with
+| inleft p =>
+    match
+      pIsShared l1 mdl p in (_ = y)
+      return
+        (mapping y (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))))
+    with
+    | eq_refl => Tl1l2 l1 l2 tr (pComponents l1 mdl p)
+    end
+| inright _ =>
+    mkMapping (pState l1 mdl) (pState l1 mdl) Unit
+      (fun _ : pState l1 mdl => unit)
+      (fun (_ : Unit) (_ : pState l1 mdl) => unit)
+      (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit)
+      (fun (_ : Unit) (X : pState l1 mdl) => X)
+end.
+
+Definition Pmap21 l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl :=
+match
+  pIsEmpty l1 mdl as s
+  return
+    (mapping
+       match s with
+       | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))
+       | inright _ => pState l1 mdl
+       end (pState l1 mdl))
+with
+| inleft p =>
+    match
+      pIsShared l1 mdl p in (_ = y)
+      return
+        (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) y)
+    with
+    | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl p)
+    end
+| inright _ =>
+    mkMapping (pState l1 mdl) (pState l1 mdl) Unit
+      (fun _ : pState l1 mdl => unit)
+      (fun (_ : Unit) (_ : pState l1 mdl) => unit)
+      (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit)
+      (fun (_ : Unit) (X : pState l1 mdl) => X)
+end.
+
+Definition PTpred l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl (pp : pPredicate l1 mdl):
+  LP (MdlPredicate (PLanguage l2) (PTransfoSyntax l1 l2 tr h mdl)) :=
+match pIsEmpty l1 mdl with
+| inleft _ =>
+      let (x, p) := pp in
+      addIndex (pIndex l1 mdl) (fun i => MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) x
+        (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl x))
+          (LPPred (MdlPredicate l1 (pComponents l1 mdl x)) p))
+| inright f => match f (projS1 pp) with end
+end.
+
+Lemma simu_eqA: 
+  forall A1 A2 C m P sa sc tta ttc (h: A2=A1),
+  simu A1 C (match h in (_=y) return mapping _ C with eq_refl => m end) 
+  P (match h in (_=y) return TTS y with eq_refl => sa end)
+  sc (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => tta p end)
+  ttc ->
+  simu A2 C m P sa sc tta ttc.
+admit.
+Qed.
+
+Lemma simu_eqC: 
+  forall A C1 C2 m P sa sc tta ttc (h: C2=C1),
+  simu A C1 (match h in (_=y) return mapping A _ with eq_refl => m end) 
+  P sa (match h in (_=y) return TTS y with eq_refl => sc end)
+  tta (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => ttc p end)
+   ->
+  simu A C2 m P sa sc tta ttc.
+admit.
+Qed.
+
+Lemma simu_eqA1: 
+  forall A1 A2 C m P sa sc tta ttc (h: A1=A2),
+  simu A1 C m 
+  P 
+  (match (sym_eq h) in (_=y) return TTS y with eq_refl => sa end) sc
+  (fun p => match (sym_eq h) as e in (_=y) return LP (Predicate y (match e in (_=z) return TTS z with eq_refl => sa end)) with eq_refl => tta p end) ttc
+   ->
+  simu A2 C (match h in (_=y) return mapping _ C with eq_refl => m end) P sa sc tta ttc.
+admit.
+Qed.
+
+Lemma simu_eqA2: 
+  forall A1 A2 C m P sa sc tta ttc (h: A1=A2),
+  simu A1 C (match (sym_eq h) in (_=y) return mapping _ C with eq_refl => m end)
+  P 
+  sa sc tta ttc
+   ->
+  simu A2 C m P
+  (match h in (_=y) return TTS y with eq_refl => sa end) sc 
+  (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sa end) with eq_refl => tta p end)
+ ttc.
+admit.
+Qed.
+
+Lemma simu_eqC2: 
+  forall A C1 C2 m P sa sc tta ttc (h: C1=C2),
+  simu A C1 (match (sym_eq h) in (_=y) return mapping A _ with eq_refl => m end)
+  P 
+  sa sc tta ttc
+   ->
+  simu A C2 m P
+  sa (match h in (_=y) return TTS y with eq_refl => sc end) 
+  tta (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sc end) with eq_refl => ttc p end).
+admit.
+Qed.
+
+Lemma simu_eqM: 
+  forall A C m1 m2 P sa sc tta ttc (h: m1=m2),
+  simu A C m1 P sa sc tta ttc
+   ->
+  simu A C m2 P sa sc tta ttc.
+admit.
+Qed.
+
+Lemma LPTransfo_trans:
+  forall Pred1 Pred2 Pred3 (tr1: Pred1 -> LP Pred2) (tr2: Pred2 -> LP Pred3) f,
+    LPTransfo tr2 (LPTransfo tr1 f) = LPTransfo (fun x => LPTransfo tr2 (tr1 x)) f.
+Proof.
+  admit.
+Qed.
+
+Lemma LPTransfo_addIndex:
+  forall Ind Pred tr1 x (tr2: forall i, Pred i -> LP (tr1 i)) (p: LP (Pred x)),
+    addIndex Ind tr1 x (LPTransfo (tr2 x) p) =
+    LPTransfo
+      (fun p0 : {i : Ind & Pred i} =>
+        addIndex Ind tr1 (projT1 p0) (tr2 (projT1 p0) (projT2 p0)))
+      (addIndex Ind Pred x p).
+Proof.
+  unfold addIndex; intros. 
+  rewrite LPTransfo_trans.
+  rewrite LPTransfo_trans.
+  simpl.
+  auto.
+Qed.
+
+Record tr_compat I0 I1 tr := compatPrf {
+  and_compat: forall p1 p2, tr (LPAnd I0 p1 p2) = LPAnd I1 (tr p1) (tr p2);
+  not_compat: forall p, tr (LPNot I0 p) = LPNot I1 (tr p)
+}.
+
+Lemma LPTransfo_addIndex_tr:
+  forall Ind Pred tr0 tr1 x (tr2: forall i, Pred i -> LP (tr0 i))  (tr3: forall i, LP (tr0 i) -> LP (tr1 i)) (p: LP (Pred x)),
+    (forall x, tr_compat (tr0 x) (tr1 x) (tr3 x)) ->
+    addIndex Ind tr1 x (tr3 x (LPTransfo (tr2 x) p)) =
+    LPTransfo
+      (fun p0 : {i : Ind & Pred i} =>
+        addIndex Ind tr1 (projT1 p0) (tr3 (projT1 p0) (tr2 (projT1 p0) (projT2 p0))))
+      (addIndex Ind Pred x p).
+Proof.
+  unfold addIndex; simpl; intros. 
+  rewrite LPTransfo_trans; simpl.
+  rewrite <- LPTransfo_trans.
+  f_equal.
+  induction p; simpl; intros; auto.
+  rewrite (and_compat _ _ _ (H x)).
+  rewrite <- IHp1, <- IHp2; auto.
+  rewrite <- IHp.
+  rewrite (not_compat _ _ _ (H x)); auto.
+Qed.
+
+Require Export Coq.Logic.FunctionalExtensionality.
+Print PLanguage.
+Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): 
+Transformation (PLanguage l1) (PLanguage l2) :=
+  mkTransformation (PLanguage l1) (PLanguage l2)
+    (PTransfoSyntax l1 l2 tr h)
+    (Pmap12 l1 l2 tr h)
+    (Pmap21 l1 l2 tr h)
+    (PTpred l1 l2 tr h)
+    (fun mdl => simu_equivProd 
+      (pState l1 mdl) 
+      (pState l2 (PTransfoSyntax l1 l2 tr h mdl)) 
+      (Pmap12 l1 l2 tr h mdl)
+      (Pmap21 l1 l2 tr h mdl)
+      (pIndex l1 mdl) 
+      (fun i => MdlPredicate l1 (pComponents l1 mdl i))
+      (compSemantic l1 mdl)
+      (compSemantic l2 (PTransfoSyntax l1 l2 tr h mdl))
+      _
+      _
+      _
+        ).
+
+Next Obligation.
+  unfold compSemantic, PTransfoSyntax; simpl.
+  case (pIsEmpty l1 mdl); simpl; intros.
+  unfold pPredicate; simpl.
+  unfold pPredicate in X; simpl in X.
+  case (sameState l1 l2 tr h mdl i p).
+  apply (LPTransfo (MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))).
+  apply (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl i))).
+  apply (LPPred _ X).
+
+  apply False_rect; apply (f i).
+Defined.
+
+Next Obligation.
+  split; intros.
+  unfold Pmap12; simpl.
+  unfold PTransfo_obligation_1; simpl.
+  unfold compSemantic; simpl.
+  unfold eq_ind, eq_rect, f_equal; simpl.
+  case (pIsEmpty l1 mdl); intros.
+  apply simu_eqA2.
+  apply simu_eqC2.
+  apply simu_eqM with (Tl1l2 l1 l2 tr (pComponents l1 mdl i)).
+  apply sameM12.
+  apply (simuLR _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro.
+
+  apply False_rect; apply (f i).
+
+  unfold Pmap21; simpl.
+  unfold PTransfo_obligation_1; simpl.
+  unfold compSemantic; simpl.
+  unfold eq_ind, eq_rect, f_equal; simpl.
+  case (pIsEmpty l1 mdl); intros.
+  apply simu_eqC2.
+  apply simu_eqA2.
+  apply simu_eqM with (Tl2l1 l1 l2 tr (pComponents l1 mdl i)).
+  apply sameM21.
+  apply (simuRL _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro.
+
+  apply False_rect; apply (f i).
+Qed.
+
+Next Obligation.
+  unfold trProd; simpl.
+  unfold PTransfo_obligation_1; simpl.
+  unfold compSemantic; simpl.
+  unfold eq_ind, eq_rect, f_equal; simpl.
+  apply functional_extensionality; intro.
+  case x; clear x; intros.
+  unfold PTpred; simpl.
+  case (pIsEmpty l1 mdl); simpl; intros.
+  set (tr0 i :=
+   Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))
+     (Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))).
+  set (tr1 i :=
+   Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p)))
+     match sameState l1 l2 tr h mdl i p in (_ = y) return (TTS y) with
+     | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))
+     end).
+  set (tr2 x := MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))).
+  set (Pred x := MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))).
+  set (tr3 x f := match
+    sameState l1 l2 tr h mdl x p as e in (_ = y)
+    return
+      (LP
+         (Predicate y
+            match e in (_ = y0) return (TTS y0) with
+            | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))
+            end))
+  with
+  | eq_refl => f
+  end).
+  apply (LPTransfo_addIndex_tr _ Pred tr0 tr1 x tr2 tr3
+    (Tpred l1 l2 tr (pComponents l1 mdl x) m)).
+  unfold tr0, tr1, tr3; intros; split; simpl; intros; auto.
+  case (sameState l1 l2 tr h mdl x0 p); auto.
+  case (sameState l1 l2 tr h mdl x0 p); auto.
+
+  apply False_rect; apply (f x).
+Qed.
+
+End Product.
diff --git a/test-suite/bugs/closed/shouldsucceed/2388.v b/test-suite/bugs/closed/shouldsucceed/2388.v
index 8cc43ee6..c7926711 100644
--- a/test-suite/bugs/closed/shouldsucceed/2388.v
+++ b/test-suite/bugs/closed/shouldsucceed/2388.v
@@ -2,3 +2,9 @@
 
 Fail Parameters (A:Prop) (a:A A).
 
+(* This is a variant (reported as part of bug #2347) *)
+
+Require Import EquivDec.                                              
+Fail Program Instance bool_eq_eqdec : EqDec bool eq := 
+   {equiv_dec x y := (fix aux (x y : bool) {struct x}:= aux _ y) x y}.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2393.v b/test-suite/bugs/closed/shouldsucceed/2393.v
new file mode 100644
index 00000000..fb4f9261
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2393.v
@@ -0,0 +1,13 @@
+Require Import Program.
+
+Inductive T := MkT.
+
+Definition sizeOf (t : T) : nat
+    := match t with
+       | MkT => 1
+       end.
+Variable vect : nat -> Type.
+Program Fixpoint idType (t : T) (n := sizeOf t) (b : vect n) {measure n} : T
+    := match t with
+       | MkT => MkT
+       end.
diff --git a/test-suite/bugs/closed/shouldsucceed/2404.v b/test-suite/bugs/closed/shouldsucceed/2404.v
new file mode 100644
index 00000000..fe8eba54
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2404.v
@@ -0,0 +1,46 @@
+(* Check that dependencies in the indices of the type of the terms to
+   match are taken into account and correctly generalized *)
+
+Require Import Relations.Relation_Definitions.
+Require Import Basics.
+
+Record Base := mkBase
+ {(* Primitives *)
+    World : Set
+  (* Names are real, links are theoretical *)
+  ; Name : World -> Set
+
+  ; wweak : World -> World -> Prop
+
+  ; exportw : forall a b : World, (wweak a b) -> (Name b) -> option (Name a)
+}.
+
+Section Derived.
+  Variable base : Base.
+  Definition bWorld := World base.
+  Definition bName  := Name base.
+  Definition bexportw := exportw base.
+  Definition bwweak := wweak base.
+
+  Implicit Arguments bexportw [a b].
+
+Inductive RstarSetProof {I : Type} (T : I -> I -> Type) : I -> I -> Type :=
+  starReflS : forall a, RstarSetProof T a a
+| starTransS : forall i j k, T i j -> (RstarSetProof T j k) -> RstarSetProof T i k.
+
+Implicit Arguments starTransS [I T i j k].
+
+Definition RstarInv {A : Set} (rel : relation A) : A -> A -> Type :=  (flip (RstarSetProof (flip rel))).
+
+Definition bwweakFlip (b a : bWorld) : Prop := (bwweak a b).
+Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak.
+
+Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) :=
+  match aRWb,y with
+  | starReflS a, y' => Some y'
+  | starTransS i j k jWk jRWi, y' =>
+    match (bexportw jWk y) with
+    | Some x => exportRweak jRWi x
+    | None   => None
+    end
+  end.
diff --git a/test-suite/bugs/closed/shouldsucceed/2456.v b/test-suite/bugs/closed/shouldsucceed/2456.v
new file mode 100644
index 00000000..56f046c4
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2456.v
@@ -0,0 +1,53 @@
+
+Require Import Equality.
+
+Parameter Patch : nat -> nat -> Set.
+
+Inductive Catch (from to : nat) : Type
+    := MkCatch : forall (p : Patch from to),
+                 Catch from to.
+Implicit Arguments MkCatch [from to].
+
+Inductive CatchCommute5
+        : forall {from mid1 mid2 to : nat},
+          Catch from mid1
+       -> Catch mid1 to
+       -> Catch from mid2
+       -> Catch mid2 to
+       -> Prop
+     := MkCatchCommute5 :
+           forall {from mid1 mid2 to : nat}
+                  (p : Patch from mid1)
+                  (q : Patch mid1 to)
+                  (q' : Patch from mid2)
+                  (p' : Patch mid2 to),
+           CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p').
+
+Inductive CatchCommute {from mid1 mid2 to : nat}
+                       (p : Catch from mid1)
+                       (q : Catch mid1 to)
+                       (q' : Catch from mid2)
+                       (p' : Catch mid2 to)
+                     : Prop
+    := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'),
+                         CatchCommute p q q' p'.
+Notation "<< p , q >> <~> << q' , p' >>"
+    := (CatchCommute p q q' p')
+    (at level 60, no associativity).
+
+Lemma CatchCommuteUnique2 :
+      forall {from mid mid' to : nat}
+             {p   : Catch from mid}  {q   : Catch mid  to}
+             {q'  : Catch from mid'} {p'  : Catch mid' to}
+             {q'' : Catch from mid'} {p'' : Catch mid' to}
+             (commute1 : <<p, q>> <~> <<q', p'>>)
+             (commute2 : <<p, q>> <~> <<q'', p''>>),
+      (p' = p'') /\ (q' = q'').
+Proof with auto.
+intros.
+set (X := commute2).
+dependent destruction commute1;
+dependent destruction catchCommuteDetails;
+dependent destruction commute2;
+dependent destruction catchCommuteDetails generalizing X.
+Admitted.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2473.v b/test-suite/bugs/closed/shouldsucceed/2473.v
new file mode 100644
index 00000000..4c302512
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2473.v
@@ -0,0 +1,39 @@
+
+Require Import Relations Program Setoid Morphisms.
+
+Section S1.
+  Variable R: nat -> relation bool.
+  Instance HR1: forall n, Transitive (R n). Admitted.
+  Instance HR2: forall n, Symmetric (R n).  Admitted.
+  Hypothesis H: forall n a, R n (andb a a) a.
+  Goal forall n a b, R n b a.
+   intros. 
+   (* rewrite <- H. *) (* Anomaly: Evar ?.. was not declared. Please report. *)
+   (* idem with setoid_rewrite *)
+(*    assert (HR2' := HR2 n). *)
+   rewrite <- H.                (* ok *)
+   admit.
+  Qed.
+End S1.
+
+Section S2.
+  Variable R: nat -> relation bool.
+  Instance HR: forall n, Equivalence (R n). Admitted.
+  Hypothesis H: forall n a, R n (andb a a) a.
+  Goal forall n a b, R n a b.
+   intros. rewrite <- H. admit.
+  Qed.
+End S2.
+
+(* the parametrised relation is required to get the problem *)
+Section S3.
+  Variable R: relation bool.
+  Instance HR1': Transitive R. Admitted.
+  Instance HR2': Symmetric R.  Admitted.
+  Hypothesis H: forall a, R (andb a a) a.
+  Goal forall a b, R b a.
+   intros. 
+   rewrite <- H.                (* ok *)
+   admit.
+  Qed.
+End S3.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2603.v b/test-suite/bugs/closed/shouldsucceed/2603.v
new file mode 100644
index 00000000..a556b9bf
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2603.v
@@ -0,0 +1,18 @@
+Module Type T.
+End T.
+
+Declare Module K : T.
+
+Module Type L.
+Declare Module E : T.
+End L.
+
+Module M1 : L with Module E:=K.
+Module E := K.
+Fail Inductive t := E. (* Used to be accepted, but End M1 below was failing *)
+End M1.
+
+Module M2 : L with Module E:=K.
+Inductive t := E.
+Fail Module E := K. (* Used to be accepted *)
+Fail End M2. (* Used to be accepted *)
diff --git a/test-suite/bugs/closed/shouldsucceed/2613.v b/test-suite/bugs/closed/shouldsucceed/2613.v
new file mode 100644
index 00000000..4f0470b1
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2613.v
@@ -0,0 +1,17 @@
+(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *)
+
+Require Import ZArith.
+Require Recdef.
+
+Axiom nat_eq_dec: forall x y : nat, {x=y}+{x<>y}.
+
+Locate eq_sym.  (* Constant Coq.Init.Logic.eq_sym  *)
+
+Function loop (n: nat) {measure (fun x => x) n} : bool :=
+  if nat_eq_dec n 0 then false else loop (pred n).
+Proof.
+   admit.
+Defined.
+
+Check eq_sym eq_refl : 0=0.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2615.v b/test-suite/bugs/closed/shouldsucceed/2615.v
new file mode 100644
index 00000000..54e1a07c
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2615.v
@@ -0,0 +1,14 @@
+(* This failed with an anomaly in pre-8.4 because of let-in not
+   properly taken into account in the test for unification pattern *)
+
+Inductive foo : forall A, A -> Prop :=
+| foo_intro : forall A x, foo A x.
+Lemma bar A B f : foo (A -> B) f -> forall x : A, foo B (f x).
+Fail induction 1.
+
+(* Whether these examples should succeed with a non-dependent return predicate 
+   or fail because there is well-typed return predicate dependent in f 
+   is questionable. As of 25 oct 2011, they succeed *)
+refine (fun p => match p with _ => _ end).
+Undo.
+refine (fun p => match p with foo_intro _ _ => _ end).
diff --git a/test-suite/bugs/closed/shouldsucceed/2616.v b/test-suite/bugs/closed/shouldsucceed/2616.v
new file mode 100644
index 00000000..8758e32d
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2616.v
@@ -0,0 +1,7 @@
+(* Testing ill-typed rewrite which used to succeed in 8.3 *)
+Goal 
+  forall (N : nat -> Prop) (g : nat -> sig N) (IN : forall a : sig N, a = g 0), 
+    N 0 -> False.
+Proof.
+intros.
+Fail rewrite IN in H.
diff --git a/test-suite/bugs/closed/shouldsucceed/2640.v b/test-suite/bugs/closed/shouldsucceed/2640.v
new file mode 100644
index 00000000..da0cc68a
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2640.v
@@ -0,0 +1,17 @@
+(* Testing consistency of globalization and interpretation in some
+   extreme cases *)
+
+Section sect.
+
+  (* Simplification of the initial example *)
+  Hypothesis Other: True.
+
+  Lemma C2 : True.
+  proof.
+  Fail have True using Other.
+  Abort.
+
+  (* Variant of the same problem *)
+  Lemma C2 : True.
+  Fail clear; Other.
+  Abort.
diff --git a/test-suite/bugs/opened/shouldnotfail/2310.v b/test-suite/bugs/opened/shouldnotfail/2310.v
new file mode 100644
index 00000000..8d1a5149
--- /dev/null
+++ b/test-suite/bugs/opened/shouldnotfail/2310.v
@@ -0,0 +1,17 @@
+(* Dependent higher-order hole in "refine" (simplified version) *)
+
+Set Implicit Arguments.
+
+Inductive Nest t := Cons : Nest (prod t t) -> Nest t.
+
+Definition cast A x y Heq P H := @eq_rect A x P H y Heq.
+
+Definition replace a (y:Nest (prod a a)) : a = a -> Nest a.
+
+(* This used to raise an anomaly Unknown Meta in 8.2 and 8.3beta.
+   It raises a regular error in 8.3 and almost succeeds with the new
+   proof engine: there are two solutions to a unification problem
+   (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either
+   leave P as subgoal or choose itself one solution *)
+
+intros. refine (Cons (cast H _ y)).
diff --git a/test-suite/complexity/Notations.v b/test-suite/complexity/Notations.v
new file mode 100644
index 00000000..02a3c252
--- /dev/null
+++ b/test-suite/complexity/Notations.v
@@ -0,0 +1,10 @@
+(* Last line should not loop, even in the presence of eta-expansion in the *)
+(* printing mechanism *)
+(* Expected time < 1.00s *)
+
+Notation "'bind' x <- y ; z" :=(y (fun x => z)) (at level 99, x at
+  level 0, y at level 0,format "'[hv' 'bind'  x  <-  y ;  '/' z ']'").
+
+Definition f (g : (nat -> nat) -> nat) := g (fun x => 0).
+
+Time Check (fun g => f g).
diff --git a/test-suite/complexity/evar_instance.v b/test-suite/complexity/evar_instance.v
new file mode 100644
index 00000000..97a66c95
--- /dev/null
+++ b/test-suite/complexity/evar_instance.v
@@ -0,0 +1,78 @@
+(* Checks behavior of unification with respect to the size of evar instances *)
+(* Expected time < 2.00s *)
+
+(* Note that the exact example chosen is not important as soon as it
+   involves a few of each part of the unification algorithme (and especially
+   evar-evar unification and evar-term instantiation) *)
+
+(* In 8.2, the example was in O(n^3) in the number of section variables; 
+   From current commit it is in O(n^2) *)
+
+(* For the record: with coqtop.byte on a Dual Core 2:
+
+   Nb of extra           T  i  m  e
+    variables     8.1    8.2    8.3beta   current
+       800       1.6s   188s    185s      1.6s
+       400       0.5s    24s     24s      0.43s
+       200       0.17s    3s      3.2s    0.12s
+       100       0.06s    0.5s    0.48s   0.04s
+        50       0.02s    0.08s   0.08s   0.016s
+         n      12*a*n^2  a*n^3   a*n^3   8*a*n^2
+*)
+
+Set Implicit Arguments.
+Parameter t:Set->Set.
+Parameter map:forall elt elt' : Set, (elt -> elt') -> t elt -> t elt'.
+Parameter avl: forall elt : Set, t elt -> Prop.
+Parameter bst: forall elt : Set, t elt -> Prop.
+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 :=
+  Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}.
+Definition t' := bbst.
+Section B.
+
+Variables
+ a b c d e f g h i j k m n o p q r s u v w x y z
+ a0 b0 c0 d0 e0 f0 g0 h0 i0 j0 k0 m0 n0 o0 p0 q0 r0 s0 u0 v0 w0 x0 y0 z0
+ a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 m1 n1 o1 p1 q1 r1 s1 u1 v1 w1 x1 y1 z1
+ a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 m2 n2 o2 p2 q2 r2 s2 u2 v2 w2 x2 y2 z2
+ a3 b3 c3 d3 e3 f3 g3 h3 i3 j3 k3 m3 n3 o3 p3 q3 r3 s3 u3 v3 w3 x3 y3 z3
+ a4 b4 c4 d4 e4 f4 g4 h4 i4 j4 k4 m4 n4 o4 p4 q4 r4 s4 u4 v4 w4 x4 y4 z4
+ a5 b5 c5 d5 e5 f5 g5 h5 i5 j5 k5 m5 n5 o5 p5 q5 r5 s5 u5 v5 w5 x5 y5 z5
+ a6 b6 c6 d6 e6 f6 g6 h6 i6 j6 k6 m6 n6 o6 p6 q6 r6 s6 u6 v6 w6 x6 y6 z6
+
+ a7 b7 c7 d7 e7 f7 g7 h7 i7 j7 k7 m7 n7 o7 p7 q7 r7 s7 u7 v7 w7 x7 y7 z7
+ a8 b8 c8 d8 e8 f8 g8 h8 i8 j8 k8 m8 n8 o8 p8 q8 r8 s8 u8 v8 w8 x8 y8 z8
+ a9 b9 c9 d9 e9 f9 g9 h9 i9 j9 k9 m9 n9 o9 p9 q9 r9 s9 u9 v9 w9 x9 y9 z9
+ aA bA cA dA eA fA gA hA iA jA kA mA nA oA pA qA rA sA uA vA wA xA yA zA
+ aB bB cB dB eB fB gB hB iB jB kB mB nB oB pB qB rB sB uB vB wB xB yB zB
+ aC bC cC dC eC fC gC hC iC jC kC mC nC oC pC qC rC sC uC vC wC xC yC zC
+ aD bD cD dD eD fD gD hD iD jD kD mD nD oD pD qD rD sD uD vD wD xD yD zD
+ aE bE cE dE eE fE gE hE iE jE kE mE nE oE pE qE rE sE uE vE wE xE yE zE
+
+ aF bF cF dF eF fF gF hF iF jF kF mF nF oF pF qF rF sF uF vF wF xF yF zF
+ aG bG cG dG eG fG gG hG iG jG kG mG nG oG pG qG rG sG uG vG wG xG yG zG
+ aH bH cH dH eH fH gH hH iH jH kH mH nH oH pH qH rH sH uH vH wH xH yH zH
+ aI bI cI dI eI fI gI hI iI jI kI mI nI oI pI qI rI sI uI vI wI xI yI zI
+ aJ bJ cJ dJ eJ fJ gJ hJ iJ jJ kJ mJ nJ oJ pJ qJ rJ sJ uJ vJ wJ xJ yJ zJ
+ aK bK cK dK eK fK gK hK iK jK kK mK nK oK pK qK rK sK uK vK wK xK yK zK
+ aL bL cL dL eL fL gL hL iL jL kL mL nL oL pL qL rL sL uL vL wL xL yL zL
+ aM bM cM dM eM fM gM hM iM jM kM mM nM oM pM qM rM sM uM vM wM xM yM zM
+
+ aN bN cN dN eN fN gN hN iN jN kN mN nN oN pN qN rN sN uN vN wN xN yN zN
+ aO bO cO dO eO fO gO hO iO jO kO mO nO oO pO qO rO sO uO vO wO xO yO zO
+ aP bP cP dP eP fP gP hP iP jP kP mP nP oP pP qP rP sP uP vP wP xP yP zP
+ aQ bQ cQ dQ eQ fQ gQ hQ iQ jQ kQ mQ nQ oQ pQ qQ rQ sQ uQ vQ wQ xQ yQ zQ
+ aR bR cR dR eR fR gR hR iR jR kR mR nR oR pR qR rR sR uR vR wR xR yR zR
+ aS bS cS dS eS fS gS hS iS jS kS mS nS oS pS qS rS sS uS vS wS xS yS zS
+ aT bT cT dT eT fT gT hT iT jT kT mT nT oT pT qT rT sT uT vT wT xT yT zT
+ aU bU cU dU eU fU gU hU iU jU kU mU nU oU pU qU rU sU uU vU wU xU yU zU
+
+ : nat .
+
+Variables elt elt': Set.
+Timeout 5 Time Definition map' f (m:t' elt) : t' elt' :=
+  Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
diff --git a/test-suite/complexity/guard.v b/test-suite/complexity/guard.v
new file mode 100644
index 00000000..ceb7835a
--- /dev/null
+++ b/test-suite/complexity/guard.v
@@ -0,0 +1,30 @@
+(* Examples to check that the guard condition does not evaluate
+   irrelevant subterms *)
+(* Expected time < 1.00s *)
+Require Import Bool.
+
+Fixpoint slow n :=
+ match n with
+ | 0 => true
+ | S k => andb (slow k) (slow k)
+ end.
+
+Timeout 5 Time Fixpoint F n :=
+  match n with
+  | 0 => 0
+  | S k =>
+    if slow 100 then F k else 0
+  end.
+
+Fixpoint slow2 n :=
+ match n with
+ | 0 => 0
+ | S k => slow2 k + slow2 k
+ end.
+
+Timeout 5 Time Fixpoint F' n :=
+  match n with
+  | 0 => 0
+  | S k =>
+    if slow2 100 then F' k else 0
+  end.
diff --git a/test-suite/complexity/patternmatching.v b/test-suite/complexity/patternmatching.v
new file mode 100644
index 00000000..7b628136
--- /dev/null
+++ b/test-suite/complexity/patternmatching.v
@@ -0,0 +1,8 @@
+(* This example checks the efficiency of pattern-matching compilation on simple cases *)
+(* Expected time < 1.00s *)
+
+Time Definition a400 n := match n with
+  S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S x))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) => x
+| _ => 0
+end.
+
diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v
index ab57afdb..6945edc8 100644
--- a/test-suite/complexity/ring2.v
+++ b/test-suite/complexity/ring2.v
@@ -11,7 +11,7 @@ match x with
     | 0%Z => x
     | Zpos y' => Zpos (x' + y')
     | Zneg y' =>
-        match (x' ?= y')%positive Eq with
+        match (x' ?= y')%positive with
         | Eq => 0%Z
         | Lt => Zneg (y' - x')
         | Gt => Zpos (x' - y')
@@ -21,7 +21,7 @@ match x with
     match y with
     | 0%Z => x
     | Zpos y' =>
-        match (x' ?= y')%positive Eq with
+        match (x' ?= y')%positive with
         | Eq => 0%Z
         | Lt => Zpos (y' - x')
         | Gt => Zneg (x' - y')
diff --git a/test-suite/csdp.cache b/test-suite/csdp.cache
index 645de69c..297ac255 100644
--- a/test-suite/csdp.cache
+++ b/test-suite/csdp.cache
diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v
index 96e66a0d..a08c5154 100644
--- a/test-suite/failure/Tauto.v
+++ b/test-suite/failure/Tauto.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v
index 3f8d8784..d000f965 100644
--- a/test-suite/failure/clash_cons.v
+++ b/test-suite/failure/clash_cons.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v
index e4ef6c95..e38fa6e0 100644
--- a/test-suite/failure/fixpoint1.v
+++ b/test-suite/failure/fixpoint1.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v
index e5915ab1..079ad33f 100644
--- a/test-suite/failure/guard.v
+++ b/test-suite/failure/guard.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v
index ed48c6c2..64537877 100644
--- a/test-suite/failure/illtype1.v
+++ b/test-suite/failure/illtype1.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/inductive4.v b/test-suite/failure/inductive4.v
new file mode 100644
index 00000000..6ba36fd2
--- /dev/null
+++ b/test-suite/failure/inductive4.v
@@ -0,0 +1,15 @@
+(* This used to succeed in versions 8.1 to 8.3 *)
+
+Require Import Logic.
+Require Hurkens.
+Definition Ti := Type.
+Inductive prod (X Y:Ti) := pair : X -> Y -> prod X Y.
+Definition B : Prop := let F := prod True in F Prop. (* Aie! *)
+Definition p2b (P:Prop) : B := pair True Prop I P.
+Definition b2p (b:B) : Prop := match b with pair _ P => P end.
+Lemma L1 : forall A : Prop, b2p (p2b A) -> A.
+Proof (fun A x => x).
+Lemma L2 : forall A : Prop, A -> b2p (p2b A).
+Proof (fun A x => x).
+Check Hurkens.paradox B p2b b2p L1 L2.
+
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index c02661e0..e9fbe969 100644
--- a/test-suite/failure/positivity.v
+++ b/test-suite/failure/positivity.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v
index 71d49b58..2b648c13 100644
--- a/test-suite/failure/redef.v
+++ b/test-suite/failure/redef.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v
index ebbd5ca0..0ff554d9 100644
--- a/test-suite/failure/search.v
+++ b/test-suite/failure/search.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/universes2.v b/test-suite/failure/universes2.v
deleted file mode 100644
index e74de70f..00000000
--- a/test-suite/failure/universes2.v
+++ /dev/null
@@ -1,4 +0,0 @@
-(* Example submitted by Randy Pollack *)
-
-Parameter K : forall T : Type, T -> T.
-Check (K (forall T : Type, T -> T) K).
diff --git a/test-suite/ide/undo.v b/test-suite/ide/undo.v
index d5e9ee5e..ea392055 100644
--- a/test-suite/ide/undo.v
+++ b/test-suite/ide/undo.v
@@ -3,8 +3,8 @@
 
 (* Undoing arbitrary commands, as first step *)
 
-Theorem a : O=O.
-Ltac f x := x.
+Theorem a : O=O. (* 2 *)
+Ltac f x := x. (* 1 * 3 *)
 assert True by trivial.
 trivial.
 Qed.
@@ -79,6 +79,7 @@ Definition q := O.
 Definition r := O.
 
 (* Bug 2082 : Follow the numbers *)
+(* Broken due to proof engine rewriting *)
 
 Variable A : Prop.
 Variable B : Prop.
diff --git a/test-suite/ide/undo001.fake b/test-suite/ide/undo001.fake
new file mode 100644
index 00000000..bbaea7e7
--- /dev/null
+++ b/test-suite/ide/undo001.fake
@@ -0,0 +1,10 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Simple backtrack by 1 between two global definitions
+#
+INTERP Definition foo := 0.
+INTERP Definition bar := 1.
+REWIND 1
+INTERPRAW Check foo.
+INTERPRAW Fail Check bar.
diff --git a/test-suite/ide/undo002.fake b/test-suite/ide/undo002.fake
new file mode 100644
index 00000000..b855b6ea
--- /dev/null
+++ b/test-suite/ide/undo002.fake
@@ -0,0 +1,10 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Simple backtrack by 2 before two global definitions
+#
+INTERP Definition foo := 0.
+INTERP Definition bar := 1.
+REWIND 2
+INTERPRAW Fail Check foo.
+INTERPRAW Fail Check bar.
diff --git a/test-suite/ide/undo003.fake b/test-suite/ide/undo003.fake
new file mode 100644
index 00000000..4c72e8dc
--- /dev/null
+++ b/test-suite/ide/undo003.fake
@@ -0,0 +1,8 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Simple backtrack by 0 should be a no-op
+#
+INTERP Definition foo := 0.
+REWIND 0
+INTERPRAW Check foo.
diff --git a/test-suite/ide/undo004.fake b/test-suite/ide/undo004.fake
new file mode 100644
index 00000000..c2ddfb8c
--- /dev/null
+++ b/test-suite/ide/undo004.fake
@@ -0,0 +1,14 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing arbitrary commands, as first step
+#
+INTERP Theorem a : O=O.
+INTERP Ltac f x := x.
+REWIND 1
+# <replay>
+INTERP Ltac f x := x.
+# <\replay>
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
diff --git a/test-suite/ide/undo005.fake b/test-suite/ide/undo005.fake
new file mode 100644
index 00000000..525b9f2a
--- /dev/null
+++ b/test-suite/ide/undo005.fake
@@ -0,0 +1,15 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing arbitrary commands, as non-first step
+#
+INTERP Theorem b : O=O.
+INTERP assert True by trivial.
+INTERP Ltac g x := x.
+# <replay>
+REWIND 1
+# <\replay>
+INTERP Ltac g x := x.
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
diff --git a/test-suite/ide/undo006.fake b/test-suite/ide/undo006.fake
new file mode 100644
index 00000000..ed88bef5
--- /dev/null
+++ b/test-suite/ide/undo006.fake
@@ -0,0 +1,14 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing declarations, as first step
+# Was bugged in 8.1
+#
+INTERP Theorem c : O=O.
+INTERP Inductive T : Type := I.
+REWIND 1
+# <replay>
+INTERP Inductive T : Type := I.
+# <\replay>
+INTERP trivial.
+INTERP Qed.
diff --git a/test-suite/ide/undo007.fake b/test-suite/ide/undo007.fake
new file mode 100644
index 00000000..87c06dbb
--- /dev/null
+++ b/test-suite/ide/undo007.fake
@@ -0,0 +1,17 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing declarations, as first step
+# new in 8.2
+#
+INTERP Theorem d : O=O.
+INTERP Definition e := O.
+INTERP Definition f := O.
+REWIND 1
+# <replay>
+INTERP Definition f := O.
+# <\replay>
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
+INTERPRAW Check e.
diff --git a/test-suite/ide/undo008.fake b/test-suite/ide/undo008.fake
new file mode 100644
index 00000000..1c46c1e8
--- /dev/null
+++ b/test-suite/ide/undo008.fake
@@ -0,0 +1,18 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing declarations, as non-first step
+# new in 8.2
+#
+INTERP Theorem h : O=O.
+INTERP assert True by trivial.
+INTERP Definition i := O.
+INTERP Definition j := O.
+REWIND 1
+# <replay>
+INTERP Definition j := O.
+# <\replay>
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
+INTERPRAW Check i.
diff --git a/test-suite/ide/undo009.fake b/test-suite/ide/undo009.fake
new file mode 100644
index 00000000..47c77d23
--- /dev/null
+++ b/test-suite/ide/undo009.fake
@@ -0,0 +1,20 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing declarations, interleaved with proof steps
+# new in 8.2 *)
+#
+INTERP Theorem k : O=O.
+INTERP assert True by trivial.
+INTERP Definition l := O.
+INTERP assert True by trivial.
+INTERP Definition m := O.
+REWIND 3
+# <replay>
+INTERP Definition l := O.
+INTERP assert True by trivial.
+INTERP Definition m := O.
+# <\replay>
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
diff --git a/test-suite/ide/undo010.fake b/test-suite/ide/undo010.fake
new file mode 100644
index 00000000..4fe9df98
--- /dev/null
+++ b/test-suite/ide/undo010.fake
@@ -0,0 +1,28 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Undoing declarations, interleaved with proof steps and commands *)
+# new in 8.2 *)
+#
+INTERP Theorem n : O=O.
+INTERP assert True by trivial.
+INTERP Definition o := O.
+INTERP Ltac h x := x.
+INTERP assert True by trivial.
+INTERP Focus.
+INTERP Definition p := O.
+REWIND 1
+REWIND 1
+REWIND 1
+REWIND 1
+REWIND 1
+# <replay>
+INTERP Definition o := O.
+INTERP Ltac h x := x.
+INTERP assert True by trivial.
+INTERP Focus.
+INTERP Definition p := O.
+# </replay>
+INTERP assert True by trivial.
+INTERP trivial.
+INTERP Qed.
diff --git a/test-suite/ide/undo011.fake b/test-suite/ide/undo011.fake
new file mode 100644
index 00000000..cc85a764
--- /dev/null
+++ b/test-suite/ide/undo011.fake
@@ -0,0 +1,32 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Bug 2082
+# Broken due to proof engine rewriting
+#
+INTERP Variable A : Prop.
+INTERP Variable B : Prop.
+INTERP Axiom OR : A \/ B.
+INTERP Lemma MyLemma2 : True.
+INTERP proof.
+INTERP per cases of (A \/ B) by OR.
+INTERP suppose A.
+INTERP     then (1 = 1).
+INTERP     then H1 : thesis.
+INTERP     thus thesis by H1.
+INTERP suppose B.
+REWIND 1
+# <replay>
+INTERP suppose B.
+# </replay>
+REWIND 2
+# <replay>
+INTERP     thus thesis by H1.
+INTERP suppose B.
+# </replay>
+INTERP    then (1 = 1).
+INTERP    then H2 : thesis.
+INTERP    thus thesis by H2.
+INTERP end cases.
+INTERP end proof.
+INTERP Qed.
diff --git a/test-suite/ide/undo012.fake b/test-suite/ide/undo012.fake
new file mode 100644
index 00000000..f9b29ca1
--- /dev/null
+++ b/test-suite/ide/undo012.fake
@@ -0,0 +1,26 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Test backtracking in presence of nested proofs
+# First, undoing the whole
+#
+INTERP Lemma aa : True -> True /\ True.
+INTERP intro H.
+INTERP split.
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+INTERP Qed.
+INTERP apply H.
+INTERP Qed.
+REWIND 1
+# We should now be just before aa, without opened proofs
+INTERPRAW Fail idtac.
+INTERPRAW Fail Check aa.
+INTERPRAW Fail Check bb.
+INTERPRAW Fail Check cc.
diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake
new file mode 100644
index 00000000..3b1c61e6
--- /dev/null
+++ b/test-suite/ide/undo013.fake
@@ -0,0 +1,31 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Test backtracking in presence of nested proofs
+# Second, trigger the full undo of an inner proof
+#
+INTERP Lemma aa : True -> True /\ True.
+INTERP intro H.
+INTERP split.
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+INTERP Qed.
+INTERP apply H.
+REWIND 2
+# We should now be just before "Lemma cc"
+# <replay>
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+INTERP Qed.
+INTERP apply H.
+# </replay>
+INTERP Qed.
+INTERPRAW Fail idtac.
+INTERPRAW Check (aa,bb,cc).
diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake
new file mode 100644
index 00000000..5224b504
--- /dev/null
+++ b/test-suite/ide/undo014.fake
@@ -0,0 +1,26 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Test backtracking in presence of nested proofs
+# Third, undo inside an inner proof
+#
+INTERP Lemma aa : True -> True /\ True.
+INTERP intro H.
+INTERP split.
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+REWIND 1
+# <replay>
+INTERP destruct H.
+# </replay>
+INTERP Qed.
+INTERP apply H.
+INTERP Qed.
+INTERPRAW Fail idtac.
+INTERPRAW Check (aa,bb,cc).
diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake
new file mode 100644
index 00000000..32e46ec9
--- /dev/null
+++ b/test-suite/ide/undo015.fake
@@ -0,0 +1,29 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Test backtracking in presence of nested proofs
+# Fourth, undo from an inner proof to a above proof
+#
+INTERP Lemma aa : True -> True /\ True.
+INTERP intro H.
+INTERP split.
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+REWIND 4
+# <replay>
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+# </replay>
+INTERP Qed.
+INTERP apply H.
+INTERP Qed.
+INTERPRAW Fail idtac.
+INTERPRAW Check (aa,bb,cc).
diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake
new file mode 100644
index 00000000..2a6e512c
--- /dev/null
+++ b/test-suite/ide/undo016.fake
@@ -0,0 +1,34 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Test backtracking in presence of nested proofs
+# Fifth, undo from an inner proof to a previous inner proof
+#
+INTERP Lemma aa : True -> True /\ True.
+INTERP intro H.
+INTERP split.
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+REWIND 6
+# We should be just before "Lemma bb"
+# <replay>
+INTERP Lemma bb : False -> False.
+INTERP intro H.
+INTERP apply H.
+INTERP Qed.
+INTERP apply H.
+INTERP Lemma cc : False -> True.
+INTERP intro H.
+INTERP destruct H.
+# </replay>
+INTERP Qed.
+INTERP apply H.
+INTERP Qed.
+INTERPRAW Fail idtac.
+INTERPRAW Check (aa,bb,cc).
diff --git a/test-suite/ide/undo017.fake b/test-suite/ide/undo017.fake
new file mode 100644
index 00000000..232360e9
--- /dev/null
+++ b/test-suite/ide/undo017.fake
@@ -0,0 +1,13 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# bug #2569 : Undoing inside modules
+#
+INTERP Module M.
+INTERP Definition x := 0.
+INTERP End M.
+REWIND 1
+# <replay>
+INTERP End M.
+# </replay>
+INTERPRAW Check M.x.
diff --git a/test-suite/ide/undo018.fake b/test-suite/ide/undo018.fake
new file mode 100644
index 00000000..ef0945ab
--- /dev/null
+++ b/test-suite/ide/undo018.fake
@@ -0,0 +1,13 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# bug #2569 : Undoing inside section
+#
+INTERP Section M.
+INTERP Definition x := 0.
+INTERP End M.
+REWIND 1
+# <replay>
+INTERP End M.
+# </replay>
+INTERPRAW Check x.
diff --git a/test-suite/ide/undo019.fake b/test-suite/ide/undo019.fake
new file mode 100644
index 00000000..70e70d7e
--- /dev/null
+++ b/test-suite/ide/undo019.fake
@@ -0,0 +1,14 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# bug #2569 : Undoing a focused subproof
+#
+INTERP Goal True.
+INTERP {
+INTERP exact I.
+INTERP }
+REWIND 1
+# <replay>
+INTERP }
+# </replay>
+INTERP Qed.
diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v
index db52af2f..8b36f44b 100644
--- a/test-suite/ideal-features/Apply.v
+++ b/test-suite/ideal-features/Apply.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/ideal-features/Case8.v b/test-suite/ideal-features/Case8.v
deleted file mode 100644
index 2ac5bd8c..00000000
--- a/test-suite/ideal-features/Case8.v
+++ /dev/null
@@ -1,36 +0,0 @@
-Inductive listn : nat -> Set :=
-  | niln : listn 0
-  | consn : forall n : nat, nat -> listn n -> listn (S n).
-
-Inductive empty : forall n : nat, listn n -> Prop :=
-    intro_empty : empty 0 niln.
-
-Parameter
-  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).
-
-Type
-  (fun (n : nat) (l : listn n) =>
-   match l in (listn n) return (empty n l \/ ~ empty n l) with
-   | niln => or_introl (~ empty 0 niln) intro_empty
-   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
-   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
-   end).
-
-
-Type
-  (fun (n : nat) (l : listn n) =>
-   match l in (listn n) return (empty n l \/ ~ empty n l) with
-   | niln => or_introl (~ empty 0 niln) intro_empty
-   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
-   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
-   end).
-
-
-
-Type
-  (fun (n : nat) (l : listn n) =>
-   match l in (listn n) return (empty n l \/ ~ empty n l) with
-   | niln => or_introl (~ empty 0 niln) intro_empty
-   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
-   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
-   end).
diff --git a/test-suite/micromega/csdp.cache b/test-suite/micromega/csdp.cache
deleted file mode 100644
index 645de69c..00000000
--- a/test-suite/micromega/csdp.cache
+++ /dev/null
diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v
index da54166a..2b388687 100644
--- a/test-suite/misc/berardi_test.v
+++ b/test-suite/misc/berardi_test.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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).
diff --git a/test-suite/misc/deps/deps.out b/test-suite/misc/deps/deps.out
index 68b48d60..5b79349f 100644
--- a/test-suite/misc/deps/deps.out
+++ b/test-suite/misc/deps/deps.out
@@ -1 +1 @@
-misc/deps/client/bar.vo misc/deps/client/bar.glob: misc/deps/client/bar.v misc/deps/client/foo.vo misc/deps/lib/foo.vo
+misc/deps/client/bar.vo misc/deps/client/bar.glob misc/deps/client/bar.v.beautified: misc/deps/client/bar.v misc/deps/client/foo.vo misc/deps/lib/foo.vo
diff --git a/test-suite/misc/universes/universes.v b/test-suite/misc/universes/universes.v
new file mode 100644
index 00000000..b7c7ed81
--- /dev/null
+++ b/test-suite/misc/universes/universes.v
@@ -0,0 +1,2 @@
+Require all_stdlib.
+Print Sorted Universes "universes.txt".
diff --git a/test-suite/modules/errors.v b/test-suite/modules/errors.v
new file mode 100644
index 00000000..d1658786
--- /dev/null
+++ b/test-suite/modules/errors.v
@@ -0,0 +1,70 @@
+(* Inductive mismatches *)
+
+Module Type SA. Inductive TA : nat -> Prop := CA : nat -> TA 0. End SA.
+Module MA : SA. Inductive TA : Prop := CA : bool -> TA. Fail End MA.
+
+Module Type SA. Inductive TA := CA : nat -> TA. End SA.
+Module MA : SA. Inductive TA := CA : bool -> TA. Fail End MA.
+
+Module Type SA. Inductive TA := CA : nat -> TA. End SA.
+Module MA : SA. Inductive TA := CA : bool -> nat -> TA. Fail End MA.
+
+Module Type SA2. Inductive TA2 := CA2 : nat -> TA2. End SA2.
+Module MA2 : SA2. Inductive TA2 := CA2 : nat -> TA2 | DA2 : TA2. Fail End MA2.
+
+Module Type SA3. Inductive TA3 := CA3 : nat -> TA3. End SA3.
+Module MA3 : SA3. Inductive TA3 := CA3 : nat -> TA3 with UA3 := DA3. Fail End MA3.
+
+Module Type SA4. Inductive TA4 := CA4 : nat -> TA4 with UA4 := DA4. End SA4.
+Module MA4 : SA4. Inductive TA4 := CA4 : nat -> TA4 with VA4 := DA4. Fail End MA4.
+
+Module Type SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := DA5. End SA5.
+Module MA5 : SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := EA5. Fail End MA5.
+
+Module Type SA6. Inductive TA6 (A:Type) := CA6 : A -> TA6 A. End SA6.
+Module MA6 : SA6. Inductive TA6 (A B:Type):= CA6 : A -> TA6 A B. Fail End MA6.
+
+Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7.
+Module MA7 : SA7. CoInductive TA7 (A:Type):= CA7 : A -> TA7 A. Fail End MA7.
+
+Module Type SA8. CoInductive TA8 (A:Type) := CA8 : A -> TA8 A. End SA8.
+Module MA8 : SA8. Inductive TA8 (A:Type):= CA8 : A -> TA8 A. Fail End MA8.
+
+Module Type SA9. Record TA9 (A:Type) := { CA9 : A }. End SA9.
+Module MA9 : SA9. Inductive TA9 (A:Type):= CA9 : A -> TA9 A. Fail End MA9.
+
+Module Type SA10. Inductive TA10 (A:Type) := CA10 : A -> TA10 A. End SA10.
+Module MA10 : SA10. Record TA10 (A:Type):= { CA10 : A }. Fail End MA10.
+
+Module Type SA11. Record TA11 (A:Type):= { CA11 : A }. End SA11.
+Module MA11 : SA11. Record TA11 (A:Type):= { DA11 : A }. Fail End MA11.
+
+(* Basic mismatches *)
+Module Type SB. Inductive TB := CB : nat -> TB. End SB.
+Module MB : SB. Module Type TB. End TB. Fail End MB.
+
+Module Type SC. Module Type TC. End TC. End SC.
+Module MC : SC. Inductive TC := CC : nat -> TC. Fail End MC.
+
+Module Type SD. Module TD. End TD. End SD.
+Module MD : SD. Inductive TD := DD : nat -> TD. Fail End MD.
+
+Module Type SE. Definition DE := nat. End SE.
+Module ME : SE. Definition DE := bool. Fail End ME.
+
+Module Type SF. Parameter DF : nat. End SF.
+Module MF : SF. Definition DF := bool. Fail End MF.
+
+(* Needs a type constraint in module type *)
+Module Type SG. Definition DG := Type. End SG.
+Module MG : SG. Definition DG := Type : Type. Fail End MG.
+
+(* Should work *)
+Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7.
+Module MA7 : SA7. Inductive TA7 (B:Type):= CA7 : B -> TA7 B. End MA7.
+
+Module Type SA11. Record TA11 (B:Type):= { CA11 : B }. End SA11.
+Module MA11 : SA11. Record TA11 (A:Type):= { CA11 : A }. End MA11.
+
+Module Type SE. Parameter DE : Type. End SE.
+Module ME : SE. Definition DE := Type : Type. End ME.
diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out
new file mode 100644
index 00000000..139f9e99
--- /dev/null
+++ b/test-suite/output/Arguments.out
@@ -0,0 +1,93 @@
+minus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+The simpl tactic unfolds minus avoiding to expose match constructs
+minus is transparent
+Expands to: Constant Coq.Init.Peano.minus
+minus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+The simpl tactic unfolds minus when applied to 1 argument
+  avoiding to expose match constructs
+minus is transparent
+Expands to: Constant Coq.Init.Peano.minus
+minus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+The simpl tactic unfolds minus
+  when the 1st argument evaluates to a constructor and
+  when applied to 1 argument avoiding to expose match constructs
+minus is transparent
+Expands to: Constant Coq.Init.Peano.minus
+minus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+The simpl tactic unfolds minus
+  when the 1st and 2nd arguments evaluate to a constructor and
+  when applied to 2 arguments 
+minus is transparent
+Expands to: Constant Coq.Init.Peano.minus
+minus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+The simpl tactic unfolds minus
+  when the 1st and 2nd arguments evaluate to a constructor 
+minus is transparent
+Expands to: Constant Coq.Init.Peano.minus
+pf :
+forall D1 C1 : Type,
+(D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2
+
+Arguments D2, C2 are implicit
+Arguments D1, C1 are implicit and maximally inserted
+Argument scopes are [foo_scope type_scope _ _ _ _ _]
+The simpl tactic never unfolds pf
+pf is transparent
+Expands to: Constant Top.pf
+fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C
+
+Arguments A, B, C are implicit and maximally inserted
+Argument scopes are [type_scope type_scope type_scope _ _ _]
+The simpl tactic unfolds fcomp when applied to 6 arguments 
+fcomp is transparent
+Expands to: Constant Top.fcomp
+volatile : nat -> nat
+
+Argument scope is [nat_scope]
+The simpl tactic always unfolds volatile
+volatile is transparent
+Expands to: Constant Top.volatile
+f : T1 -> T2 -> nat -> unit -> nat -> nat
+
+Argument scopes are [_ _ nat_scope _ nat_scope]
+f is transparent
+Expands to: Constant Top.S1.S2.f
+f : T1 -> T2 -> nat -> unit -> nat -> nat
+
+Argument scopes are [_ _ nat_scope _ nat_scope]
+The simpl tactic unfolds f
+  when the 3rd, 4th and 5th arguments evaluate to a constructor 
+f is transparent
+Expands to: Constant Top.S1.S2.f
+f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
+
+Argument T2 is implicit
+Argument scopes are [type_scope _ _ nat_scope _ nat_scope]
+The simpl tactic unfolds f
+  when the 4th, 5th and 6th arguments evaluate to a constructor 
+f is transparent
+Expands to: Constant Top.S1.f
+f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
+
+Arguments T1, T2 are implicit
+Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope]
+The simpl tactic unfolds f
+  when the 5th, 6th and 7th arguments evaluate to a constructor 
+f is transparent
+Expands to: Constant Top.f
+f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
+
+The simpl tactic unfolds f
+  when the 5th, 6th and 7th arguments evaluate to a constructor 
+f is transparent
+Expands to: Constant Top.f
diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v
new file mode 100644
index 00000000..3a94f19a
--- /dev/null
+++ b/test-suite/output/Arguments.v
@@ -0,0 +1,40 @@
+Arguments minus n m : simpl nomatch. 
+About minus.
+Arguments minus n / m : simpl nomatch. 
+About minus.
+Arguments minus !n / m : simpl nomatch. 
+About minus.
+Arguments minus !n !m /.
+About minus.
+Arguments minus !n !m.
+About minus.
+Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := 
+  fun x => (f (fst x), g (snd x)).
+Delimit Scope foo_scope with F.
+Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never.
+About pf.
+Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x).
+Arguments fcomp {_ _ _}%type_scope f g x /.
+About fcomp.
+Definition volatile := fun x : nat => x.
+Arguments volatile /.
+About volatile.
+Set Implicit Arguments.
+Section S1.
+Variable T1 : Type.
+Section S2.
+Variable T2 : Type.
+Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat :=
+  match n, m with
+  | 0,_ => 0
+  | S _, 0 => n
+  | S n', S m' => f x y n' v m' end.
+About f.
+Global Arguments f x y !n !v !m.
+About f.
+End S2.
+About f.
+End S1.
+About f.
+Arguments f : clear implicits and scopes.
+About f.
diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out
index 6643c142..756e8ede 100644
--- a/test-suite/output/ArgumentsScope.out
+++ b/test-suite/output/ArgumentsScope.out
@@ -21,6 +21,11 @@ negb : bool -> bool
 Argument scope is [bool_scope]
 negb is transparent
 Expands to: Constant Coq.Init.Datatypes.negb
+Warning: Arguments Scope is deprecated; use Arguments instead
+Warning: Arguments Scope is deprecated; use Arguments instead
+Warning: Arguments Scope is deprecated; use Arguments instead
+Warning: Arguments Scope is deprecated; use Arguments instead
+Warning: Arguments Scope is deprecated; use Arguments instead
 a : bool -> bool
 
 Expands to: Variable a
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
new file mode 100644
index 00000000..e443115c
--- /dev/null
+++ b/test-suite/output/Arguments_renaming.out
@@ -0,0 +1,108 @@
+The command has indeed failed with message:
+=> Error: To rename arguments the "rename" flag must be specified.
+The command has indeed failed with message:
+=> Error: To rename arguments the "rename" flag must be specified.
+@eq_refl
+     : forall (B : Type) (y : B), y = y
+eq_refl
+     : forall x : nat, x = x
+Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
+
+For eq_refl: Arguments are renamed to B, y
+For eq: Argument A is implicit and maximally inserted
+For eq_refl, when applied to no arguments:
+  Arguments B, y are implicit and maximally inserted
+For eq_refl, when applied to 1 argument:
+  Argument B is implicit
+For eq: Argument scopes are [type_scope _ _]
+For eq_refl: Argument scopes are [type_scope _]
+eq_refl : forall (A : Type) (x : A), x = x
+
+Arguments are renamed to B, y
+When applied to no arguments:
+  Arguments B, y are implicit and maximally inserted
+When applied to 1 argument:
+  Argument B is implicit
+Argument scopes are [type_scope _]
+Expands to: Constructor Coq.Init.Logic.eq_refl
+Inductive myEq (B : Type) (x : A) : A -> Prop :=  myrefl : B -> myEq B x x
+
+For myrefl: Arguments are renamed to C, x, _
+For myrefl: Argument C is implicit and maximally inserted
+For myEq: Argument scopes are [type_scope _ _]
+For myrefl: Argument scopes are [type_scope _ _]
+myrefl : forall (B : Type) (x : A), B -> myEq B x x
+
+Arguments are renamed to C, x, _
+Argument C is implicit and maximally inserted
+Argument scopes are [type_scope _ _]
+Expands to: Constructor Top.Test1.myrefl
+myplus = 
+fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
+  match n with
+  | 0 => m
+  | S n' => S (myplus T t n' m)
+  end
+     : forall T : Type, T -> nat -> nat -> nat
+
+Arguments are renamed to Z, t, n, m
+Argument Z is implicit and maximally inserted
+Argument scopes are [type_scope _ nat_scope nat_scope]
+myplus : forall T : Type, T -> nat -> nat -> nat
+
+Arguments are renamed to Z, t, n, m
+Argument Z is implicit and maximally inserted
+Argument scopes are [type_scope _ nat_scope nat_scope]
+The simpl tactic unfolds myplus
+  when the 2nd and 3rd arguments evaluate to a constructor 
+myplus is transparent
+Expands to: Constant Top.Test1.myplus
+myplus
+     : forall Z : Type, Z -> nat -> nat -> nat
+Inductive myEq (A B : Type) (x : A) : A -> Prop :=
+    myrefl : B -> myEq A B x x
+
+For myrefl: Arguments are renamed to A, C, x, _
+For myrefl: Argument C is implicit and maximally inserted
+For myEq: Argument scopes are [type_scope type_scope _ _]
+For myrefl: Argument scopes are [type_scope type_scope _ _]
+myrefl : forall (A B : Type) (x : A), B -> myEq A B x x
+
+Arguments are renamed to A, C, x, _
+Argument C is implicit and maximally inserted
+Argument scopes are [type_scope type_scope _ _]
+Expands to: Constructor Top.myrefl
+myrefl
+     : forall (A C : Type) (x : A), C -> myEq A C x x
+myplus = 
+fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
+  match n with
+  | 0 => m
+  | S n' => S (myplus T t n' m)
+  end
+     : forall T : Type, T -> nat -> nat -> nat
+
+Arguments are renamed to Z, t, n, m
+Argument Z is implicit and maximally inserted
+Argument scopes are [type_scope _ nat_scope nat_scope]
+myplus : forall T : Type, T -> nat -> nat -> nat
+
+Arguments are renamed to Z, t, n, m
+Argument Z is implicit and maximally inserted
+Argument scopes are [type_scope _ nat_scope nat_scope]
+The simpl tactic unfolds myplus
+  when the 2nd and 3rd arguments evaluate to a constructor 
+myplus is transparent
+Expands to: Constant Top.myplus
+myplus
+     : forall Z : Type, Z -> nat -> nat -> nat
+The command has indeed failed with message:
+=> Error: All arguments lists must declare the same names.
+The command has indeed failed with message:
+=> Error: The following arguments are not declared: x.
+The command has indeed failed with message:
+=> Error: Arguments names must be distinct.
+The command has indeed failed with message:
+=> Error: Argument z cannot be declared implicit.
+The command has indeed failed with message:
+=> Error: Extra argument y.
diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v
new file mode 100644
index 00000000..b133e733
--- /dev/null
+++ b/test-suite/output/Arguments_renaming.v
@@ -0,0 +1,54 @@
+Fail Arguments eq_refl {B y}, [B] y.
+Fail Arguments identity T _ _.
+Arguments eq_refl A x.
+Arguments eq_refl {B y}, [B] y : rename.
+
+Check @eq_refl.
+Check (eq_refl (B := nat)).
+Print eq_refl.
+About eq_refl.
+
+Goal 3 = 3.
+apply @eq_refl with (B := nat).
+Undo.
+apply @eq_refl with (y := 3).
+Undo.
+pose (y := nat).
+apply (@eq_refl y) with (y0 := 3).
+Qed.
+
+Section Test1.
+
+Variable A : Type.
+
+Inductive myEq B (x : A) : A -> Prop := myrefl : B -> myEq B x x.
+
+Global Arguments myrefl {C} x _ : rename.
+Print myrefl.
+About myrefl.
+
+Fixpoint myplus T (t : T) (n m : nat) {struct n} :=
+  match n with O => m | S n' => S (myplus T t n' m) end.
+
+Global Arguments myplus {Z} !t !n m : rename.
+
+Print myplus.
+About myplus.
+Check @myplus.
+
+End Test1.
+Print myrefl.
+About myrefl.
+Check myrefl.
+
+Print myplus.
+About myplus.
+Check @myplus.
+
+Fail Arguments eq_refl {F g}, [H] k.
+Fail Arguments eq_refl {F}, [F].
+Fail Arguments eq_refl {F F}, [F] F.
+Fail Arguments eq {F} x [z].
+Fail Arguments eq {F} x z y.
+
+
diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out
new file mode 100644
index 00000000..f61b7ecf
--- /dev/null
+++ b/test-suite/output/Errors.out
@@ -0,0 +1,2 @@
+The command has indeed failed with message:
+=> Error: The field t is missing in Top.M.
diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v
new file mode 100644
index 00000000..75763f3b
--- /dev/null
+++ b/test-suite/output/Errors.v
@@ -0,0 +1,9 @@
+(* Test error messages *)
+
+(* Test non-regression of bug fixed in r13486 (bad printer for module names) *)
+
+Module Type S.
+Parameter t:Type.
+End S.
+Module M : S.
+Fail End M.
diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out
index ca79ba69..2f756cbb 100644
--- a/test-suite/output/Existentials.out
+++ b/test-suite/output/Existentials.out
@@ -1 +1,3 @@
-Existential 1 = ?9 : [n : nat  m : nat |- nat] 
+Existential 1 = ?10 : [q : nat  n : nat  m : nat |- n = ?9] 
+Existential 2 = ?9 : [n : nat  m : nat |- nat] 
+Existential 3 = ?7 : [p : nat  q := S p : nat  n : nat  m : nat |- ?9 = m] 
diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out
index c69d31f4..a13ae462 100644
--- a/test-suite/output/Fixpoint.out
+++ b/test-suite/output/Fixpoint.out
@@ -9,17 +9,4 @@ let fix f (m : nat) : nat := match m with
                              | S m' => f m'
                              end in f 0
      : nat
-fix even_pos_odd_pos 2
- with (odd_pos_even_pos (n:_) (H:odd n) {struct H} : n >= 1).
- intros.
- destruct H.
-  omega.
-  
-  apply odd_pos_even_pos in H.
-  omega.
-  
- intros.
- destruct H.
- apply even_pos_odd_pos in H.
- omega.
- 
+Ltac f id1 id2 := fix id1 2 with (id2 (n:_) (H:odd n) {struct H} : n >= 1)
diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v
index af5f05f6..8afa50ba 100644
--- a/test-suite/output/Fixpoint.v
+++ b/test-suite/output/Fixpoint.v
@@ -25,6 +25,11 @@ Inductive even: Z -> Prop :=
 with odd: Z -> Prop :=
 | odd_succ: forall n, even (n - 1) -> odd n.
 
+(* Check printing of fix *)
+Ltac f id1 id2 := fix id1 2 with (id2 n (H:odd n) {struct H} : n >= 1).
+Print Ltac f.
+
+(* Incidentally check use of fix in proofs *)
 Lemma even_pos_odd_pos: forall n, even n -> n >= 0.
 Proof.
 fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1).
@@ -37,5 +42,6 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1).
  destruct H.
   apply even_pos_odd_pos in H.
   omega.
-Show Script.
 Qed.
+
+
diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out
index ecfe8505..3b65003c 100644
--- a/test-suite/output/Implicit.out
+++ b/test-suite/output/Implicit.out
@@ -11,3 +11,5 @@ map id (1 :: nil)
      : list nat
 map id' (1 :: nil)
      : list nat
+map (id'' (A:=nat)) (1 :: nil)
+     : list nat
diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v
index 4c6f2b5d..7c9b89f9 100644
--- a/test-suite/output/Implicit.v
+++ b/test-suite/output/Implicit.v
@@ -18,6 +18,9 @@ Definition d2 x := d1 (y:=x).
 
 Print d2.
 
+Set Strict Implicit.
+Unset Implicit Arguments.
+
 (* Check maximal insertion of implicit *)
 
 Require Import List.
@@ -33,6 +36,18 @@ Check map id (1::nil).
 
 Definition id' (A:Type) (x:A) := x.
 
-Implicit Arguments id' [[A]].
+Arguments id' {A} x.
 
 Check map id' (1::nil).
+
+Unset Maximal Implicit Insertion.
+Unset Implicit Arguments.
+
+(* Check explicit insertion of last non-maximal trailing implicit to ensure *)
+(* correct arity of partiol applications *)
+
+Set Implicit Arguments.
+Definition id'' (A:Type) (x:A) := x.
+
+Check map (@id'' nat) (1::nil).
+
diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out
index 9299e010..55017469 100644
--- a/test-suite/output/InitSyntax.out
+++ b/test-suite/output/InitSyntax.out
@@ -1,5 +1,5 @@
 Inductive sig2 (A : Type) (P Q : A -> Prop) : Type :=
-    exist2 : forall x : A, P x -> Q x -> sig2 P Q
+    exist2 : forall x : A, P x -> Q x -> {x | P x & Q x}
 
 For sig2: Argument A is implicit
 For exist2: Argument A is implicit
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 215d9b68..ada524f1 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -2,10 +2,10 @@ true ? 0; 1
      : nat
 if true as x return (x ? nat; bool) then 0 else true
      : nat
-Defining 'proj1' as keyword
+Identifier 'proj1' now a keyword
 fun e : nat * nat => proj1 e
      : nat * nat -> nat
-Defining 'decomp' as keyword
+Identifier 'decomp' now a keyword
 decomp (true, true) as t, u in (t, u)
      : bool * bool
 !(0 = 0)
@@ -28,18 +28,18 @@ forall n n0 : nat, ###(n = n0)
      : list nat
 (1; 2, 4)
      : nat * nat * nat
-Defining 'ifzero' as keyword
+Identifier 'ifzero' now a keyword
 ifzero 3
      : bool
-Defining 'pred' as keyword
+Identifier 'pred' now a keyword
 pred 3
      : nat
 fun n : nat => pred n
      : nat -> nat
 fun n : nat => pred n
      : nat -> nat
-Defining 'ifn' as keyword
-Defining 'is' as keyword
+Identifier 'ifn' now a keyword
+Identifier 'is' now a keyword
 fun x : nat => ifn x is succ n then n else 0
      : nat -> nat
 1-
@@ -80,7 +80,7 @@ Nil
      : forall A : Type, list A
 NIL:list nat
      : list nat
-Defining 'I' as keyword
+Identifier 'I' now a keyword
 (false && I 3)%bool /\ I 6
      : Prop
 [|1, 2, 3; 4, 5, 6|]
@@ -120,3 +120,5 @@ fun x : option Z => match x with
                     | NONE3 => 0
                     end
      : option Z -> Z
+s
+     : s
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index b8f8f48f..4a2c411e 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -245,3 +245,11 @@ Check (fun x => match x with SOME2 x => x | NONE2 => 0 end).
 Notation NONE3 := @None.
 Notation SOME3 := @Some.     
 Check (fun x => match x with SOME3 x => x | NONE3 => 0 end).
+
+(* Check correct matching of "Type" in notations. Of course the
+   notation denotes a term that will be reinterpreted with a different
+   universe than the actual one; but it would be the same anyway
+   without a notation *)
+
+Notation s := Type.
+Check s.
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index 6731d505..47741e43 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -10,10 +10,19 @@ end
      : nat
 let '(a, _, _) := (2, 3, 4) in a
      : nat
+fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0
+     : (nat -> nat -> Prop) -> nat -> Prop
 ∃ n p : nat, n + p = 0
      : Prop
+let a := 0 in
+∃ x y : nat,
+let b := 1 in
+let c := b in
+let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d
+     : Prop
 ∀ n p : nat, n + p = 0
      : Prop
+Identifier 'λ' now a keyword
 λ n p : nat, n + p = 0
      : nat -> nat -> Prop
 λ (A : Type) (n p : A), n = p
@@ -22,6 +31,18 @@ let '(a, _, _) := (2, 3, 4) in a
      : Type -> Prop
 λ A : Type, ∀ n p : A, n = p
      : Type -> Prop
-Defining 'let'' as keyword
-let' f (x y z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2
+Identifier 'let'' now a keyword
+let' f (x y : nat) (a:=0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2
      : bool -> nat
+λ (f : nat -> nat) (x : nat), f(x) + S(x)
+     : (nat -> nat) -> nat -> nat
+Notation plus2 n := (S (S n))
+λ n : list(nat),
+match n with
+| nil => 2
+| 0 :: _ => 2
+| list1 => 0
+| 1 :: _ :: _ => 2
+| plus2 _ :: _ => 2
+end
+     : list(nat) -> nat
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
index 57d8ebbc..e902a3c2 100644
--- a/test-suite/output/Notations2.v
+++ b/test-suite/output/Notations2.v
@@ -25,19 +25,25 @@ 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.
 
+(* Test notation for anonymous functions up to eta-expansion *)
+
+Check fun P:nat->nat->Prop => fun x:nat => ex (P x). 
+
 (* Test notations with binders *)
 
-Notation "∃  x .. y , P":=
-  (ex (fun x => .. (ex (fun y => P)) ..)) (x binder, y binder, at level 200).
+Notation "∃  x .. y , P":= (ex (fun x => .. (ex (fun y => P)) ..))
+  (x binder, y binder, at level 200, right associativity).
 
 Check (∃ n p, n+p=0).
 
+Check ∃ (a:=0) (x:nat) y (b:=1) (c:=b) (d:=2) z (e:=3) (f:=4), x+y = z+d.
+
 Notation "∀  x .. y , P":= (forall x, .. (forall y, P) ..)
   (x binder, at level 200, right associativity).
 
 Check (∀ n p, n+p=0).
 
-Notation "'λ'  x .. y , P":= (fun x, .. (fun y, P) ..)
+Notation "'λ'  x .. y , P":= (fun x => .. (fun y => P) ..)
   (y binder, at level 200, right associativity).
 
 Check (λ n p, n+p=0).
@@ -53,7 +59,19 @@ Notation "'let'' f x .. y  :=  t 'in' u":=
   (f ident, x closed binder, y closed binder, at level 200,
    right associativity).
 
-Check let' f x y z (a:bool) := x+y+z+1 in f 0 1 2.
+Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2.
+
+(* In practice, only the printing rule is used here *)
+(* Note: does not work for pattern *)
+Notation "f ( x )" := (f x) (at level 10, format "f ( x )").
+Check fun f x => f x + S x.
+
+Open Scope list_scope.
+Notation list1 := (1::nil)%list.
+Notation plus2 n := (S (S n)).
+(* plus2 was not correctly printed in the two following tests in 8.3pl1 *)
+Print plus2.
+Check fun n => match n with list1 => 0 | _ => 2 end.
 
 (* This one is not fully satisfactory because binders in the same type
    are re-factorized and parentheses are needed even for atomic binder
diff --git a/test-suite/output/NumbersSyntax.out b/test-suite/output/NumbersSyntax.out
index b2a44fb7..b2677b6a 100644
--- a/test-suite/output/NumbersSyntax.out
+++ b/test-suite/output/NumbersSyntax.out
@@ -13,19 +13,19 @@ I31
      = 710436486
      : int31
 2
-     : BigN.t_
+     : BigN.t'
 1000000000000000000
-     : BigN.t_
+     : BigN.t'
 2 + 2
-     : BigN.t_
+     : bigN
 2 + 2
-     : BigN.t_
+     : bigN
      = 4
-     : BigN.t_
+     : bigN
      = 37151199385380486
-     : BigN.t_
+     : bigN
      = 1267650600228229401496703205376
-     : BigN.t_
+     : bigN
 2
      : BigZ.t_
 -1000000000000000000
diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out
new file mode 100644
index 00000000..40c786ab
--- /dev/null
+++ b/test-suite/output/PrintInfos.out
@@ -0,0 +1,129 @@
+existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P
+
+Argument A is implicit
+Argument scopes are [type_scope _ _ _]
+Expands to: Constructor Coq.Init.Specif.existT
+Inductive sigT (A : Type) (P : A -> Type) : Type :=
+    existT : forall x : A, P x -> sigT P
+
+For sigT: Argument A is implicit
+For existT: Argument A is implicit
+For sigT: Argument scopes are [type_scope type_scope]
+For existT: Argument scopes are [type_scope _ _ _]
+existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P
+
+Argument A is implicit
+Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
+
+For eq: Argument A is implicit and maximally inserted
+For eq_refl, when applied to no arguments:
+  Arguments A, x are implicit and maximally inserted
+For eq_refl, when applied to 1 argument:
+  Argument A is implicit
+For eq: Argument scopes are [type_scope _ _]
+For eq_refl: Argument scopes are [type_scope _]
+eq_refl : forall (A : Type) (x : A), x = x
+
+When applied to no arguments:
+  Arguments A, x are implicit and maximally inserted
+When applied to 1 argument:
+  Argument A is implicit
+Argument scopes are [type_scope _]
+Expands to: Constructor Coq.Init.Logic.eq_refl
+eq_refl : forall (A : Type) (x : A), x = x
+
+When applied to no arguments:
+  Arguments A, x are implicit and maximally inserted
+When applied to 1 argument:
+  Argument A is implicit
+plus = 
+fix plus (n m : nat) : nat := match n with
+                              | 0 => m
+                              | S p => S (plus p m)
+                              end
+     : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+plus : nat -> nat -> nat
+
+Argument scopes are [nat_scope nat_scope]
+plus is transparent
+Expands to: Constant Coq.Init.Peano.plus
+plus : nat -> nat -> nat
+
+plus_n_O : forall n : nat, n = n + 0
+
+Argument scope is [nat_scope]
+plus_n_O is opaque
+Expands to: Constant Coq.Init.Peano.plus_n_O
+Warning: Implicit Arguments is deprecated; use Arguments instead
+Inductive le (n : nat) : nat -> Prop :=
+    le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m
+
+For le_S: Argument m is implicit
+For le_S: Argument n is implicit and maximally inserted
+For le: Argument scopes are [nat_scope nat_scope]
+For le_n: Argument scope is [nat_scope]
+For le_S: Argument scopes are [nat_scope nat_scope _]
+Inductive le (n : nat) : nat -> Prop :=
+    le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m
+
+For le_S: Argument m is implicit
+For le_S: Argument n is implicit and maximally inserted
+For le: Argument scopes are [nat_scope nat_scope]
+For le_n: Argument scope is [nat_scope]
+For le_S: Argument scopes are [nat_scope nat_scope _]
+comparison : Set
+
+Expands to: Inductive Coq.Init.Datatypes.comparison
+Inductive comparison : Set :=
+    Eq : comparison | Lt : comparison | Gt : comparison
+Warning: Implicit Arguments is deprecated; use Arguments instead
+bar : foo
+
+Expanded type for implicit arguments
+bar : forall x : nat, x = 0
+
+Argument x is implicit and maximally inserted
+Expands to: Constant Top.bar
+*** [ bar : foo ]
+
+Expanded type for implicit arguments
+bar : forall x : nat, x = 0
+
+Argument x is implicit and maximally inserted
+bar : foo
+
+Expanded type for implicit arguments
+bar : forall x : nat, x = 0
+
+Argument x is implicit and maximally inserted
+Expands to: Constant Top.bar
+*** [ bar : foo ]
+
+Expanded type for implicit arguments
+bar : forall x : nat, x = 0
+
+Argument x is implicit and maximally inserted
+Module Coq.Init.Peano
+Notation existS2 := existT2
+Expands to: Notation Coq.Init.Specif.existS2
+Warning: Implicit Arguments is deprecated; use Arguments instead
+Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
+
+For eq: Argument A is implicit and maximally inserted
+For eq_refl, when applied to no arguments:
+  Arguments A, x are implicit and maximally inserted
+For eq_refl, when applied to 1 argument:
+  Argument A is implicit and maximally inserted
+For eq: Argument scopes are [type_scope _ _]
+For eq_refl: Argument scopes are [type_scope _]
+Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
+
+For eq: Argument A is implicit and maximally inserted
+For eq_refl, when applied to no arguments:
+  Arguments A, x are implicit and maximally inserted
+For eq_refl, when applied to 1 argument:
+  Argument A is implicit and maximally inserted
+For eq: Argument scopes are [type_scope _ _]
+For eq_refl: Argument scopes are [type_scope _]
diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v
new file mode 100644
index 00000000..deeb1f65
--- /dev/null
+++ b/test-suite/output/PrintInfos.v
@@ -0,0 +1,41 @@
+About existT.
+Print existT.
+Print Implicit existT.
+
+Print eq_refl.
+About eq_refl.
+Print Implicit eq_refl.
+
+Print plus.
+About plus.
+Print Implicit plus.
+
+About plus_n_O.
+
+Implicit Arguments le_S [[n] m].
+Print le_S.
+
+Arguments le_S {n} [m] _. (* Test new syntax *)
+Print le_S.
+
+About comparison.
+Print comparison.
+
+Definition foo := forall x, x = 0.
+Parameter bar : foo.
+Implicit Arguments bar [x].
+About bar.
+Print bar.
+
+Arguments bar [x]. (* Test new syntax *)
+About bar.
+Print bar.
+
+About Peano. (* Module *)
+About existS2. (* Notation *)
+
+Implicit Arguments eq_refl [[A] [x]] [[A]].
+Print eq_refl.
+
+Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *)
+Print eq_refl.
diff --git a/test-suite/output/Record.out b/test-suite/output/Record.out
new file mode 100644
index 00000000..36d643a4
--- /dev/null
+++ b/test-suite/output/Record.out
@@ -0,0 +1,16 @@
+{| field := 5 |}
+     : test
+{| field := 5 |}
+     : test
+{| field_r := 5 |}
+     : test_r
+build_c 5
+     : test_c
+build 5
+     : test
+build 5
+     : test
+{| field_r := 5 |}
+     : test_r
+build_c 5
+     : test_c
diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v
new file mode 100644
index 00000000..6aa3df98
--- /dev/null
+++ b/test-suite/output/Record.v
@@ -0,0 +1,21 @@
+Record test := build { field : nat }.
+Record test_r := build_r { field_r : nat }.
+Record test_c := build_c { field_c : nat }.
+
+Add Printing Constructor test_c.
+Add Printing Record test_r.
+
+Set Printing Records.
+
+Check build 5.
+Check {| field := 5 |}.
+
+Check build_r 5.
+Check build_c 5.
+
+Unset Printing Records.
+
+Check build 5.
+Check {| field := 5 |}.
+Check build_r 5.
+Check build_c 5.
diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out
index 154d9cdd..5d8f98ed 100644
--- a/test-suite/output/Search.out
+++ b/test-suite/output/Search.out
@@ -1,5 +1,7 @@
 le_S: forall n m : nat, n <= m -> n <= S m
 le_n: forall n : nat, n <= n
+le_pred: forall n m : nat, n <= m -> pred n <= pred m
+le_S_n: forall n m : nat, S n <= S m -> n <= m
 false: bool
 true: bool
 xorb: bool -> bool -> bool
@@ -14,5 +16,9 @@ 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
+min_r: forall n m : nat, m <= n -> min n m = m
+min_l: forall n m : nat, n <= m -> min n m = n
+max_r: forall n m : nat, n <= m -> max n m = m
+max_l: forall n m : nat, m <= n -> max n m = n
 eq_add_S: forall n m : nat, S n = S m -> n = m
 eq_S: forall x y : nat, x = y -> S x = S y
diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out
index c87eaadc..9106a4e3 100644
--- a/test-suite/output/SearchPattern.out
+++ b/test-suite/output/SearchPattern.out
@@ -11,16 +11,20 @@ pred: nat -> nat
 plus: nat -> nat -> nat
 mult: nat -> nat -> nat
 minus: nat -> nat -> nat
+min: nat -> nat -> nat
+max: 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
+min: nat -> nat -> nat
+max: 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
+eq_refl: forall (A : Type) (x : A), x = x
 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
+conj: forall A B : Prop, A -> B -> A /\ B
diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out
index ac5eedc1..9949658c 100644
--- a/test-suite/output/Tactics.out
+++ b/test-suite/output/Tactics.out
@@ -1,6 +1,4 @@
-intro H; split; [ a H | e H ].
-
-intros; match goal with
-        | |- context [if ?X then _ else _] => case X
-        end; trivial.
-
+Ltac f H := split; [ a H | e H ]
+Ltac g := match goal with
+          | |- context [if ?X then _ else _] => case X
+          end
diff --git a/test-suite/output/Tactics.v b/test-suite/output/Tactics.v
index 8fa91994..a7c497cf 100644
--- a/test-suite/output/Tactics.v
+++ b/test-suite/output/Tactics.v
@@ -3,16 +3,11 @@
 Tactic Notation "a" constr(x) := apply x.
 Tactic Notation "e" constr(x) := exact x.
 
-Lemma test : True -> True /\ True.
-intro H; split; [a H|e H].
-Show Script.
-Qed.
+Ltac f H := split; [a H|e H].
+Print Ltac f.
 
 (* Test printing of match context *)
 (* Used to fail after translator removal (see bug #1070) *)
 
-Lemma test2 : forall n:nat, forall f: nat -> bool, O = if (f n) then O else O.
-Proof.
-intros;match goal with |- context [if ?X then _ else _ ] => case X end;trivial.
-Show Script.
-Qed.
+Ltac g := match goal with |- context [if ?X then _ else _ ] => case X end.
+Print Ltac g.
diff --git a/test-suite/output/ZSyntax.out b/test-suite/output/ZSyntax.out
index f23198b0..1b7a2903 100644
--- a/test-suite/output/ZSyntax.out
+++ b/test-suite/output/ZSyntax.out
@@ -16,11 +16,11 @@ fun x : positive => (- Zpos x~0)%Z
      : positive -> Z
 fun x : positive => (- Zpos x~0 + 0)%Z
      : positive -> Z
-(Z_of_nat 0 + 1)%Z
+(Z.of_nat 0 + 1)%Z
      : Z
-(0 + Z_of_nat (0 + 0))%Z
+(0 + Z.of_nat (0 + 0))%Z
      : Z
-Z_of_nat 0 = 0%Z
+Z.of_nat 0 = 0%Z
      : Prop
-(0 + Z_of_nat 11)%Z
+(0 + Z.of_nat 11)%Z
      : Z
diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v
index 289a1e3f..d3640cae 100644
--- a/test-suite/output/ZSyntax.v
+++ b/test-suite/output/ZSyntax.v
@@ -8,10 +8,10 @@ Check (fun x : positive => Zneg (xO x)).
 Check (fun x : positive => (Zpos (xO x) + 0)%Z).
 Check (fun x : positive => (- Zpos (xO x))%Z).
 Check (fun x : positive => (- Zpos (xO x) + 0)%Z).
-Check (Z_of_nat 0 + 1)%Z.
-Check (0 + Z_of_nat (0 + 0))%Z.
-Check (Z_of_nat 0 = 0%Z).
+Check (Z.of_nat 0 + 1)%Z.
+Check (0 + Z.of_nat (0 + 0))%Z.
+Check (Z.of_nat 0 = 0%Z).
 
 (* Submitted by Pierre Casteran *)
 Require Import Arith.
-Check (0 + Z_of_nat 11)%Z.
+Check (0 + Z.of_nat 11)%Z.
diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out
new file mode 100644
index 00000000..bca3b361
--- /dev/null
+++ b/test-suite/output/inference.out
@@ -0,0 +1,6 @@
+P = 
+fun e : option L => match e with
+                    | Some cl => Some cl
+                    | None => None
+                    end
+     : option L -> option L
diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v
new file mode 100644
index 00000000..968ea71a
--- /dev/null
+++ b/test-suite/output/inference.v
@@ -0,0 +1,14 @@
+(* Check that types are not uselessly unfolded *)
+
+(* Check here that P returns something of type "option L" and not
+   "option (list nat)" *)
+
+Definition L := list nat.
+
+Definition P (e:option L) :=
+  match e with
+  | None => None
+  | Some cl => Some cl
+  end.
+
+Print P.
diff --git a/test-suite/output/rewrite-2172.out b/test-suite/output/rewrite-2172.out
new file mode 100644
index 00000000..30385072
--- /dev/null
+++ b/test-suite/output/rewrite-2172.out
@@ -0,0 +1,2 @@
+The command has indeed failed with message:
+=> Error: Unable to find an instance for the variable E.
diff --git a/test-suite/output/rewrite-2172.v b/test-suite/output/rewrite-2172.v
new file mode 100644
index 00000000..212b1c12
--- /dev/null
+++ b/test-suite/output/rewrite-2172.v
@@ -0,0 +1,21 @@
+(* This checks an error message as reported in bug #2172 *)
+
+Axiom axiom : forall (E F : nat), E = F.
+Lemma test : forall (E F : nat), E = F.
+Proof.
+  intros.
+(* This used to raise the following non understandable error message:
+
+   Error: Unable to find an instance for the variable x
+
+   The reason this error was that rewrite generated the proof
+
+   "eq_ind ?A ?x ?P ? ?y (axiom ?E ?F)"
+
+   and the equation ?x=?E was solved in the way ?E:=?x leaving ?x
+   unresolved. A stupid hack for solve this consisted in ordering
+   meta=meta equations the other way round (with most recent evars
+   instantiated first - since they are assumed to come first from the
+   user in rewrite/induction/destruct calls).
+*)
+  Fail rewrite <- axiom.
diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v
index b533db6e..97cf316c 100644
--- a/test-suite/success/AdvancedCanonicalStructure.v
+++ b/test-suite/success/AdvancedCanonicalStructure.v
@@ -79,19 +79,17 @@ Record interp_pair :Type :=
     link: abs = interp repr }.
 
 Lemma prod_interp :forall (a b:interp_pair),a * b = interp (Prod a b) .
-proof.
-let a:interp_pair,b:interp_pair.
-reconsider thesis as (a * b = interp a * interp b).
-thus thesis by (link a),(link b).
-end proof.
+Proof.
+intros a b.
+change (a * b = interp a * interp b).
+rewrite (link a), (link b); reflexivity.
 Qed.
 
 Lemma fun_interp :forall (a b:interp_pair), (a -> b) = interp (Fun a b).
-proof.
-let a:interp_pair,b:interp_pair.
-reconsider thesis as ((a -> b) = (interp a -> interp b)).
-thus thesis using rewrite (link a);rewrite (link b);reflexivity.
-end proof.
+Proof.
+intros a b.
+change ((a -> b) = (interp a -> interp b)).
+rewrite (link a), (link b); reflexivity.
 Qed.
 
 Canonical Structure ProdCan (a b:interp_pair) :=
diff --git a/test-suite/success/CaseAlias.v b/test-suite/success/CaseAlias.v
index 32d85779..a9249086 100644
--- a/test-suite/success/CaseAlias.v
+++ b/test-suite/success/CaseAlias.v
@@ -1,3 +1,4 @@
+(*********************************************)
 (* This has been a bug reported by Y. Bertot *)
 Inductive expr : Set :=
   | b : expr -> expr -> expr
@@ -19,3 +20,72 @@ Fixpoint f2 (t : expr) : expr :=
   | x => b x a
   end.
 
+(*********************************************)
+(* Test expansion of aliases                 *)
+(* Originally taken from NMake_gen.v         *)
+
+ Local Notation SizePlus n := (S (S (S (S (S (S n)))))).
+ Local Notation Size := (SizePlus O).
+
+ Parameter zn2z : Type -> Type.
+ Parameter w0 : Type.
+ Fixpoint word (w : Type) (n : nat) {struct n} : Type :=
+  match n with
+  | 0 => w
+  | S n0 => zn2z (word w n0)
+  end.
+
+ Definition w1 := zn2z w0.
+ Definition w2 := zn2z w1.
+ Definition w3 := zn2z w2.
+ Definition w4 := zn2z w3.
+ Definition w5 := zn2z w4.
+ Definition w6 := zn2z w5.
+
+ Definition dom_t n := match n with
+  | 0 => w0
+  | 1 => w1
+  | 2 => w2
+  | 3 => w3
+  | 4 => w4
+  | 5 => w5
+  | 6 => w6
+  | SizePlus n => word w6 n
+ end.
+Parameter plus_t : forall n m : nat, word (dom_t n) m -> dom_t (m + n).
+
+(* This used to fail because of a bug in expansion of SizePlus wrongly
+   reusing n as an alias for the subpattern *)
+Definition plus_t1 n : forall m, word (dom_t n) m -> dom_t (m+n) :=
+   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
+     | SizePlus (S n') as n => plus_t n
+     | _ as n =>
+         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
+                    | SizePlus (S (S m')) as m => plus_t n m
+                    | _ => fun x => x
+                  end
+   end.
+
+(* Test (useless) intermediate alias *)
+Definition plus_t2 n : forall m, word (dom_t n) m -> dom_t (m+n) :=
+   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
+     | S (S (S (S (S (S (S n'))))) as n) as n'' => plus_t n''
+     | _ as n =>
+         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
+                    | SizePlus (S (S m')) as m => plus_t n m
+                    | _ => fun x => x
+                  end
+   end.
+
+(*****************************************************************************)
+(* Check that alias expansion behaves consistently from versions to versions *)
+
+Definition g m :=
+  match pred m with
+  | 0 => 0
+  | n => n (* For compatibility, right-hand side should be (S n), not (pred m) *)
+  end.
+
+Goal forall m, g m = match pred m with 0 => 0 | S n => S n end.
+intro; reflexivity.
+Abort.
diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v
index e63972ce..745529bf 100644
--- a/test-suite/success/Cases.v
+++ b/test-suite/success/Cases.v
@@ -543,7 +543,7 @@ Type
    end).
 
 (* Nested Cases: the SYNTH of the Cases on n used to make Multcase believe
- * it has to synthtize the predicate on O (which he can't)
+ * it has to synthesize the predicate on O (which he can't)
  *)
 Type
   match 0 as n return match n with
@@ -611,31 +611,52 @@ Type
    | Consn n a (Consn m b l) => n + m
    end).
 
-(*
-Type [A:Set][n:nat][l:(Listn A n)]
-                   <[_: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
-                         (Niln  as b) => b
-                      | (Consn  n a (Niln  as b))=> (Niln A)
-                      | (Consn  n a (Consn m b l)) => (Niln A)
-                      end.
+(* This example was deactivated in Cristina's code
+
+Type
+  (fun (A:Set) (n:nat) (l:Listn A n) =>
+    match l return Listn A O with
+      | Niln  as b => b
+      | Consn  n a (Niln  as b) => (Niln A)
+      | Consn  n a (Consn m b l) => (Niln A)
+    end).
+*)
+
+(* This one is (still) failing: too weak unification
+
+Type
+  (fun (A:Set) (n:nat) (l:Listn A n) =>
+    match l with
+      | Niln  as b => b
+      | Consn  n a (Niln  as b) => (Niln A)
+      | Consn  n a (Consn m b l) => (Niln A)
+    end).
+*)
+
+(* This one is failing: alias L not chosen of the right type
+
+Type
+  (fun (A:Set) (n:nat) (l:Listn A n) =>
+    match l return Listn A (S 0) with
+      | Niln  as b => Consn A O O b
+      | Consn n a Niln as L => L
+      | Consn n a _ => Consn A O O (Niln A)
+    end).
 *)
-(******** This example rises an error unconstrained_variables!
-Type [A:Set][n:nat][l:(Listn A n)]
-                    Cases l of
-                         (Niln  as b) => (Consn A O O b)
-                      | ((Consn  n a Niln) as L) =>  L
-                      | (Consn  n a _)  =>  (Consn A O O (Niln A))
-                      end.
+
+(******** This example (still) failed
+
+Type
+  (fun (A:Set) (n:nat) (l:Listn A n) =>
+    match l return Listn A (S 0) with
+      | Niln  as b => Consn A O O b
+      | Consn n a Niln as L => L
+      | Consn n a _ => Consn A O O (Niln A)
+    end).
+
 **********)
 
-(* To test tratement of as-patterns in depth *)
+(* To test treatment of as-patterns in depth *)
 Type
   (fun (A : Set) (l : List A) =>
    match l with
@@ -1064,7 +1085,7 @@ Type
    | Consn n a (Consn m b l) => fun _ : nat => n + m
    end).
 
-(* Alsos tests for multiple _ patterns *)
+(* Also tests for multiple _ patterns *)
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l in (Listn _ n) return (Listn A n) with
@@ -1072,14 +1093,14 @@ Type
    | Consn _ _ _ as b => b
    end).
 
-(** Horrible error message!
+(** This one was said to raised once an "Horrible error message!" *)
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                        Cases l of
-                        (Niln as b) => b
-                      | ((Consn _ _ _ ) as b)=>  b
-                      end.
-******)
+Type
+  (fun (A:Set) (n:nat) (l:Listn A n) =>
+   match l with
+   | Niln as b => b
+   | Consn _ _ _  as b =>  b
+   end).
 
 Type
   match niln in (listn n) return (listn n) with
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
index 29721843..d3b7cf3f 100644
--- a/test-suite/success/CasesDep.v
+++ b/test-suite/success/CasesDep.v
@@ -26,6 +26,40 @@ Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C :=
   end.
 End Folding.
 
+(** Testing post-processing of nested dependencies *)
+
+Check fun x:{x|x=0}*nat+nat => match x with
+      | inl ((exist 0 eq_refl),0) => None
+      | _ => Some 0
+      end.
+
+Check fun x:{_:{x|x=0}|True}+nat => match x with
+      | inl (exist (exist 0 eq_refl) I) => None
+      | _ => Some 0
+      end.
+
+Check fun x:{_:{x|x=0}|True}+nat => match x with
+      | inl (exist (exist 0 eq_refl) I) => None
+      | _ => Some 0
+      end.
+
+Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with
+      | inl (exist (exist 0 eq_refl) I) => None
+      | _ => Some 0
+      end.
+
+  (* the next two examples were failing from r14703 (Nov 22 2011) to r14732 *)
+  (* due to a bug in dependencies postprocessing (revealed by CoLoR) *)
+
+Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with
+      | exist2 (x,y) eq_refl I => None
+      end.
+
+Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with
+      | inl (exist (exist2 (x,y) eq_refl I) I) => None
+      | _ => Some 0
+      end.
+
 (* -------------------------------------------------------------------- *)
 (*   Example to test patterns matching on dependent families            *)
 (* This exemple extracted from the developement done by Nacira Chabane  *)
@@ -506,3 +540,23 @@ Definition test (s:step E E) :=
     | Step nil _ (cons E nil) _ Plus l l' => true
     | _ => false
   end.
+
+(* Testing regression of bug 2454 ("get" used not be type-checkable when
+   defined with its type constraint) *)
+
+Inductive K : nat -> Type := KC : forall (p q:nat), K p.
+
+Definition get : K O -> nat := fun x => match x with KC p q => q end.
+
+(* Checking correct order of substitution of realargs *)
+(* (was broken from revision 14664 to 14669) *)
+(* Example extracted from contrib CoLoR *)
+
+Inductive EQ : nat -> nat -> Prop := R x y : EQ x y.
+
+Check fun e t (d1 d2:EQ e t) =>
+      match d1 in EQ e1 t1, d2 in EQ e2 t2 return
+        (e1,t1) = (e2,t2) -> (e1,t1) = (e,t) -> 0=0
+      with
+      | R _ _, R _ _ => fun _ _ => eq_refl
+      end.
diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v
index d5b94ab4..47180ef6 100644
--- a/test-suite/success/Check.v
+++ b/test-suite/success/Check.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v
index dffad323..a7596741 100644
--- a/test-suite/success/Discriminate.v
+++ b/test-suite/success/Discriminate.v
@@ -32,3 +32,9 @@ intros.
 ediscriminate (H O).
 instantiate (1:=O).
 Abort.
+
+(* Check discriminate on identity *)
+
+Goal ~ identity 0 1.
+discriminate.
+Qed.
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
index 08e8aed2..0efd90a1 100644
--- a/test-suite/success/Field.v
+++ b/test-suite/success/Field.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (**** Tests of Field with real numbers ****)
 
 Require Import Reals RealField.
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index 4aa00e68..a93f8900 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -24,7 +24,7 @@ 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. exact refl_equal. Defined.
+  Proof. exact @refl_equal. Defined.
   Definition Sym := sym_equal.
   Let Trans := trans_equal.
 
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 203fbbb7..da5dd5e4 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -54,6 +54,15 @@ Check
    | Build_B x0 x1 => f x0 x1
    end).
 
+(* Check inductive types with local definitions (constructors) *)
+
+Inductive I1 : Set := C1 (_:I1) (_:=0).
+
+Check (fun x:I1 =>
+  match x with
+  | C1 i n => (i,n)
+  end).
+
 (* Check implicit parameters of inductive types (submitted by Pierre
   Casteran and also implicit in #338) *)
 
@@ -78,3 +87,23 @@ Record P:Type := {PA:Set; PB:Set}.
 Definition F (p:P) := (PA p) -> (PB p).
 
 Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F.
+
+(* Check that test for binders capturing implicit arguments is not stronger
+   than needed (problem raised by Cedric Auger) *)
+
+Set Implicit Arguments.
+Inductive bool_comp2 (b: bool): bool -> Prop :=
+| Opp2: forall q, (match b return Prop with
+                  | true => match q return Prop with 
+                              true => False |
+                              false => True end
+                  | false => match q return Prop with
+                              true => True |
+                              false => False end end) -> bool_comp2 b q.
+
+(* This one is still to be made acceptable...
+
+Set Implicit Arguments.
+Inductive I A : A->Prop := C a : (forall A, A) -> I a.
+
+ *)
diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v
index 5091b44c..b068f729 100644
--- a/test-suite/success/Inversion.v
+++ b/test-suite/success/Inversion.v
@@ -73,15 +73,15 @@ Require Import Bvector.
 
 Inductive I : nat -> Set :=
   | C1 : I 1
-  | C2 : forall k i : nat, vector (I i) k -> I i.
+  | C2 : forall k i : nat, Vector.t (I i) k -> I i.
 
-Inductive SI : forall k : nat, I k -> vector nat k -> nat -> Prop :=
+Inductive SI : forall k : nat, I k -> Vector.t nat k -> nat -> Prop :=
     SC2 :
-      forall (k i vf : nat) (v : vector (I i) k) (xi : vector nat i),
+      forall (k i vf : nat) (v : Vector.t (I i) k) (xi : Vector.t nat i),
       SI (C2 v) xi vf.
 
 Theorem SUnique :
- forall (k : nat) (f : I k) (c : vector nat k) v v',
+ forall (k : nat) (f : I k) (c : Vector.t nat k) v v',
  SI f c v -> SI f c v' -> v = v'.
 Proof.
 induction 1.
@@ -129,3 +129,10 @@ Proof.
    an inconsistent state that disturbed "inversion" *)
 intros. inversion H.
 Abort.
+
+(* Bug #2314 (simplified): check that errors do not show as anomalies *)
+
+Goal True -> True.
+intro.
+Fail inversion H using False.
+Fail inversion foo using True_ind.
diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v
index 53bcc63a..df4da431 100644
--- a/test-suite/success/LegacyField.v
+++ b/test-suite/success/LegacyField.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v 7693 2005-12-21 23:50:17Z herbelin $ *)
-
 (**** Tests of Field with real numbers ****)
 
 Require Import Reals LegacyRfield.
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index 661a8757..f5f5a9d1 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -59,3 +59,30 @@ Check (fun x:nat*nat => match x with R x y => (x,y) end).
 Local Notation "[ a  # ; ..  # ; b ]" := (a + .. (b + 0) ..).   
 Check [ 0 ].
 Check [ 0 # ; 1 ].
+
+(* Check well-scoping of alpha-renaming of private binders *)
+(* see bug #2248 (thanks to Marc Lasson) *)
+
+Notation "{ q , r | P }" := (fun (p:nat*nat) => let (q, r) := p in P).
+Check (fun p => {q,r| q + r = p}).
+
+(* Check that declarations of empty levels are correctly backtracked *)
+
+Section B.
+Notation "*" := 5 (at level 0) : nat_scope.
+Notation "[ h ] p" := (h + p) (at level 8, p at level 9, h at level 7) : nat_scope.
+End B.
+
+(* Should succeed *)
+Definition n := 5 * 5.
+
+(* Check that lonely notations (here FOO) do not modify the visibility
+   of scoped interpretations (bug #2634 fixed in r14819) *)
+
+Notation "x ++++ y" := (mult x y) (at level 40).
+Notation "x ++++ y" := (plus x y) : A_scope.
+Open Scope A_scope.
+Notation "'FOO' x" := (S x) (at level 40).
+Goal (2 ++++ 3) = 5.
+reflexivity.
+Abort.
diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v
index 518d22e9..d316e4a0 100644
--- a/test-suite/success/Nsatz.v
+++ b/test-suite/success/Nsatz.v
@@ -1,51 +1,27 @@
-Require Import Nsatz ZArith Reals List Ring_polynom.
+(* compile en user    3m39.915s sur cachalot *)
+Require Import Nsatz.
 
 (* Example with a generic domain *)
 
-Variable A: Type.
-Variable Ad: Domain A.
+Section test.
 
-Definition Ari : Ring A:= (@domain_ring A Ad).
-Existing Instance Ari.
-
-Existing Instance ring_setoid.
-Existing Instance ring_plus_comp.
-Existing Instance ring_mult_comp.
-Existing Instance ring_sub_comp.
-Existing Instance ring_opp_comp.
-
-Add Ring Ar: (@ring_ring A (@domain_ring 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}.
-
-Infix "==" := ring_eq (at level 70, no associativity).
-
-Ltac nsatzA := simpl; unfold Ari; nsatz_domain.
-
-Goal forall x y:A,  x == y -> x+0 == y*1+0.
-nsatzA.
-Qed.
+Context {A:Type}`{Aid:Integral_domain A}.
 
 Lemma example3 : forall x y z,
   x+y+z==0 ->
   x*y+x*z+y*z==0->
-  x*y*z==0 -> x*x*x==0.
+  x*y*z==0 -> x^3%Z==0.
 Proof.
-Time nsatzA. 
-Admitted.
+Time nsatz. 
+Qed.
 
 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*x*x*x==0.
+  x*y*z*u==0 -> x^4%Z==0.
 Proof.
-Time nsatzA.
+Time nsatz.
 Qed.
 
 Lemma example5 : forall x y z u v,
@@ -53,15 +29,17 @@ Lemma example5 : forall x y z u v,
   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*x*x*x*x ==0.
+  x*y*z*u*v==0 -> x^5%Z==0.
 Proof.
-Time nsatzA.
+Time nsatz.
 Qed.
 
 Goal forall x y:Z,  x = y -> (x+0)%Z = (y*1+0)%Z.
 nsatz.
 Qed.
 
+Require Import Reals.
+
 Goal forall x y:R,  x = y -> (x+0)%R = (y*1+0)%R.
 nsatz.
 Qed.
@@ -70,85 +48,17 @@ Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R.
 nsatz.
 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.
-Qed.
-
-Lemma example2 : forall x, x^2=0 -> x=0.
-Proof.
- nsatz.
-Qed.
-
-(*
-Notation X  := (PEX Z 3).
-Notation Y  := (PEX Z 2).
-Notation Z_ := (PEX Z 1).
-*)
-Lemma example3b : 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. 
-Qed.
-
-(*
-Notation X  := (PEX Z 4).
-Notation Y  := (PEX Z 3).
-Notation Z_ := (PEX Z 2).
-Notation U  := (PEX Z 1).
-*)
-Lemma example4b : 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.
-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 example5b : 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.
-Qed.
-
-End Examples.
+End test.
 
 Section Geometry.
+(* See the interactive pictures of Laurent Théry 
+   on http://www-sop.inria.fr/marelle/CertiGeo/ 
+   and research paper on 
+   https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr
+*)
 
-Open Scope R_scope.
+Require Import List.
+Require Import Reals.
 
 Record point:Type:={
  X:R;
@@ -170,60 +80,122 @@ 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.
+  ((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 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).
+  not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0).
 
 Definition middle(A B I:point):=
-  2*(X I)=(X A)+(X B) /\ 2*(Y I)=(Y A)+(Y B).
+  2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B).
 
 Definition distance2(A B:point):=
-  (X B - X A)^2 + (Y B - Y A)^2.
+  (X B - X A)^2%Z + (Y B - Y A)^2%Z.
 
 (* 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.
+  (X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z.
 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.
+  ((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z).
+
+Definition equaldistance(A B C D:point):=
+  ((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z =
+  ((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z.
+
+Definition equaltangente(A B C D E F:point):=
+  let s1:= determinant A B C in
+  let c1:= scalarproduct A B C in
+  let s2:= determinant D E F in
+  let c2:= scalarproduct D E F in
+  s1 * c2 = s2 * c1.
+
+Ltac cnf2 f :=
+  match f with
+   | ?A \/ (?B /\ ?C) =>
+     let c1 := cnf2 (A\/B) in
+     let c2 := cnf2 (A\/C) in constr:(c1/\c2)
+   | (?B /\ ?C) \/ ?A =>
+     let c1 := cnf2 (B\/A) in
+     let c2 := cnf2 (C\/A) in constr:(c1/\c2)
+   | (?A \/ ?B) \/ ?C =>
+     let c1 := cnf2 (B\/C) in cnf2 (A \/ c1)
+   | _ => f
+  end
+with cnf f :=
+  match f with
+   | ?A \/ ?B =>
+     let c1 := cnf A in
+       let c2 := cnf B in
+         cnf2 (c1 \/ c2)
+   | ?A /\ ?B =>
+     let c1 := cnf A in
+       let c2 := cnf B in
+         constr:(c1 /\ c2)
+   | _ => f
+  end.
+      
+Ltac scnf :=
+  match goal with
+    | |- ?f => let c := cnf f in
+      assert c;[repeat split| tauto]
+  end.
+
+Ltac disj_to_pol f :=
+  match f with
+   | ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p)
+   | ?a = ?b => constr:(a - b)
+  end.
+
+Lemma fastnsatz1:forall x y:R, x - y = 0 -> x = y.
+nsatz.
 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 fastnsatz:=
+  try trivial; try apply fastnsatz1; try trivial; nsatz.
+  
+Ltac proof_pol_disj :=
+  match goal with
+   | |- ?g => let p := disj_to_pol g in
+     let h := fresh "hp" in
+     assert (h:p = 0);
+     [idtac|
+      prod_disj h p]
+   | _ => idtac
+  end
+with prod_disj h p :=
+  match goal with
+   | |- ?a = ?b \/ ?g => 
+        match p with
+          | ?q * ?p1 => 
+        let h0 := fresh "hp" in
+        let h1 := fresh "hp" in
+        let h2 := fresh "hp" in
+        assert (h0:a - b = 0 \/ p1 = 0);
+        [apply Rmult_integral; exact h|
+         destruct h0 as [h1|h2];
+         [left; fastnsatz|
+          right; prod_disj h2 p1]]
+        end
+   | _ => fastnsatz
+  end.
 
-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.
+(*
+Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a.
+intros. scnf; proof_pol_disj .
+admit.*)
 
-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_unfold :=
+  unfold collinear, parallel, notparallel, orthogonal,
+    equal2, equal3, nequal2, nequal3,
+    middle, samedistance2,
+    determinant, scalarproduct, norm2, distance2,
+      equaltangente, determinant, scalarproduct, equaldistance.
 
 Ltac geo_rewrite_hyps:=
   repeat (match goal with
@@ -231,14 +203,41 @@ Ltac geo_rewrite_hyps:=
            | h:Y _ = _ |- _ => rewrite h in *; clear h
           end).
 
+Ltac geo_split_hyps:=
+  repeat (match goal with
+           | h:_ /\ _ |- _ => destruct h
+          end).
+
 Ltac geo_begin:=
   geo_unfold;
   intros;
   geo_rewrite_hyps;
-  geo_end.
+  geo_split_hyps;
+  scnf; proof_pol_disj.
 
 (* Examples *)
 
+Lemma medians: forall A B C A1 B1 C1 H:point,
+  middle B C A1 ->  
+  middle A C B1 -> 
+  middle A B C1 -> 
+  collinear A A1 H -> collinear B B1 H -> 
+  collinear C C1 H
+  \/ collinear A B C.
+Proof. geo_begin.
+idtac "Medians".
+ Time nsatz.
+(*Finished transaction in 2. secs (2.69359u,0.s)
+*) Qed.
+
+Lemma Pythagore: forall A B C:point,
+  orthogonal A B A C ->
+  distance2 A C + distance2 A B = distance2 B C.
+Proof. geo_begin.
+idtac "Pythagore". 
+Time nsatz.
+(*Finished transaction in 0. secs (0.354946u,0.s)
+*) Qed.
 
 Lemma Thales: forall O A B C D:point,
   collinear O A C -> collinear O B D ->
@@ -246,9 +245,268 @@ Lemma Thales: forall O A B C D:point,
   (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.
+geo_begin.
+idtac "Thales".
+Time nsatz. (*Finished transaction in 2. secs (1.598757u,0.s)*)
+Time nsatz.
+Qed.
+
+Lemma segments_of_chords: forall A B C D M O:point,
+  equaldistance O A O B ->
+  equaldistance O A O C ->
+  equaldistance O A O D ->
+  collinear A B M ->
+  collinear C D M ->
+  (distance2 M A) * (distance2 M B) = (distance2 M C) * (distance2 M D)
+  \/ parallel A B C D.
+Proof. 
+geo_begin. 
+idtac "segments_of_chords".
+Time nsatz.
+(*Finished transaction in 3. secs (2.704589u,0.s)
+*) Qed.
+
+
+Lemma isoceles: forall A B C:point,
+  equaltangente A B C B C A ->
+  distance2 A B = distance2 A C
+  \/ collinear A B C.
+Proof. geo_begin.  Time nsatz. 
+(*Finished transaction in 1. secs (1.140827u,0.s)*) Qed.
+
+Lemma minh: forall A B C D O E H I:point,
+  X A = 0 -> Y A = 0 -> Y O = 0 ->
+  equaldistance O A O B -> 
+  equaldistance O A O C ->
+  equaldistance O A O D ->
+  orthogonal A C B D ->
+  collinear A C E ->
+  collinear B D E ->
+  collinear A B H ->
+  orthogonal E H A B ->
+  collinear C D I ->
+  middle C D I ->
+  collinear H E I
+  \/ (X C)^2%Z * (X B)^5%Z * (X O)^2%Z
+     * (X C - 2%Z * X O)^3%Z * (-2%Z * X O + X B)=0
+  \/  parallel A C B D.
+Proof. geo_begin.
+idtac "minh". 
+Time nsatz with radicalmax :=1%N strategy:=1%Z
+  parameters:=(X O::X B::X C::nil)
+  variables:= (@nil R).
+(*Finished transaction in 13. secs (10.102464u,0.s)
+*)
+Qed.
+
+Lemma Pappus: forall A B C A1 B1 C1 P Q S:point,
+  X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 -> 
+  collinear A1 B1 C1 ->
+  collinear A B1 P -> collinear A1 B P ->
+  collinear A C1 Q -> collinear A1 C Q ->
+  collinear B C1 S -> collinear B1 C S ->
+  collinear P Q S 
+  \/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1)
+  \/ (X A1 = X C) \/ (X C = X B1)
+  \/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C.
+Proof.
+geo_begin.
+idtac "Pappus".
+Time nsatz with radicalmax :=1%N strategy:=0%Z
+  parameters:=(X B::X A1::Y A1::X B1::Y B1::X C::Y C1::nil)
+  variables:= (X B
+ :: X A1
+    :: Y A1
+       :: X B1
+          :: Y B1
+             :: X C
+                :: Y C1
+                   :: X C1 :: Y P :: X P :: Y Q :: X Q :: Y S :: X S :: nil).
+(*Finished transaction in 8. secs (7.795815u,0.000999999999999s)
+*)
+Qed.
+
+Lemma Simson: forall A B C O D E F G:point,
+  X A = 0 -> Y A = 0 -> 
+  equaldistance O A O B ->
+  equaldistance O A O C ->
+  equaldistance O A O D ->
+  orthogonal  E D B C ->
+  collinear B C E ->
+  orthogonal F D A C ->
+  collinear A C F ->
+  orthogonal G D A B ->
+  collinear A B G ->
+  collinear E F G
+  \/ (X C)^2%Z = 0 \/ (Y C)^2%Z = 0 \/ (X B)^2%Z = 0 \/ (Y B)^2%Z = 0 \/ (Y C - Y B)^2%Z = 0
+  \/ equal3 B A 
+  \/ equal3 A C \/ (X C - X B)^2%Z = 0
+  \/ equal3 B C.
+Proof.
+geo_begin.
+idtac "Simson".
+Time nsatz with radicalmax :=1%N strategy:=0%Z
+  parameters:=(X B::Y B::X C::Y C::Y D::nil)
+  variables:= (@nil R). (* compute -[X Y]. *)
+(*Finished transaction in 8. secs (7.550852u,0.s)
+*)
+Qed.
+
+Lemma threepoints: forall A B C A1 B1 A2 B2 H1 H2 H3:point,
+  (* H1 intersection of bisections *)
+  middle B C A1 ->  orthogonal H1 A1 B C ->
+  middle A C B1 -> orthogonal H1 B1 A C -> 
+  (* H2 intersection of medians *)
+  collinear A A1 H2 -> collinear B B1 H2 -> 
+  (* H3 intersection of altitudes *)
+  collinear B C A2 ->  orthogonal A A2 B C ->
+  collinear A C B2 -> orthogonal B B2 A C ->
+  collinear A A1 H3 -> collinear B B1 H3 -> 
+  collinear H1 H2 H3
+  \/ collinear A B C.
+Proof. geo_begin. 
+idtac "threepoints".
+Time nsatz. 
+(*Finished transaction in 7. secs (6.282045u,0.s)
+*) Qed.
+
+Lemma Feuerbach:  forall A B C A1 B1 C1 O A2 B2 C2 O2:point, 
+  forall r r2:R,
+  X A = 0 -> Y A =  0 -> X B = 1 -> Y B =  0->
+  middle A B C1 -> middle B C A1 -> middle C A B1 ->
+  distance2 O A1 = distance2 O B1 ->
+  distance2 O A1 = distance2 O C1 ->
+  collinear A B C2 -> orthogonal A B O2 C2 -> 
+  collinear B C A2 -> orthogonal B C O2 A2 ->
+  collinear A C B2 -> orthogonal A C O2 B2 ->
+  distance2 O2 A2 = distance2 O2 B2 ->
+  distance2 O2 A2 = distance2 O2 C2 ->
+  r^2%Z = distance2 O A1 ->
+  r2^2%Z = distance2 O2 A2 ->
+  distance2 O O2 = (r + r2)^2%Z
+  \/ distance2 O O2 = (r - r2)^2%Z
+  \/ collinear A B C.
+Proof. geo_begin. 
+idtac "Feuerbach".
+Time nsatz. 
+(*Finished transaction in 21. secs (19.021109u,0.s)*)
+Qed.
+
+
+
+
+Lemma Euler_circle: forall A B C A1 B1 C1 A2 B2 C2 O:point,
+  middle A B C1 -> middle B C A1 -> middle C A B1 ->
+  orthogonal A B C C2 -> collinear A B C2 ->
+  orthogonal B C A A2 -> collinear B C A2 ->
+  orthogonal A C B B2 -> collinear A C B2 ->
+  distance2 O A1 = distance2 O B1 ->
+  distance2 O A1 = distance2 O C1 ->
+  (distance2 O A2 = distance2 O A1
+   /\distance2 O B2 = distance2 O A1
+   /\distance2 O C2 = distance2 O A1)
+  \/ collinear A B C.
+Proof. geo_begin. 
+idtac "Euler_circle 3 goals".
+Time nsatz. 
+(*Finished transaction in 13. secs (11.208296u,0.124981s)*)
+Time nsatz.  
+(*Finished transaction in 10. secs (8.846655u,0.s)*) 
+Time nsatz. 
+(*Finished transaction in 11. secs (9.186603u,0.s)*)
+Qed.
+
+
+
+Lemma Desargues: forall A B C A1 B1 C1 P Q R S:point,
+  X S = 0 -> Y S = 0 -> Y A = 0 ->
+  collinear A S A1 -> collinear B S B1 -> collinear C S C1 ->
+  collinear B1 C1 P -> collinear B C P ->
+  collinear A1 C1 Q -> collinear A C Q -> 
+  collinear A1 B1 R -> collinear A B R ->
+  collinear P Q R
+  \/ X A = X B \/ X A = X C \/ X B = X C  \/ X A = 0 \/ Y B = 0 \/ Y C = 0
+  \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1.
+Proof.
+geo_begin.
+idtac "Desargues".
+Time 
+let lv := rev (X A
+ :: X B
+    :: Y B
+       :: X C
+          :: Y C
+             :: Y A1 :: X A1
+                :: Y B1
+                   :: Y C1
+                      :: X R
+                         :: Y R
+                            :: X Q
+                               :: Y Q :: X P :: Y P :: X C1 :: X B1 :: nil) in
+nsatz with radicalmax :=1%N strategy:=0%Z
+  parameters:=(X A::X B::Y B::X C::Y C::X A1::Y B1::Y C1::nil)
+  variables:= lv. (*Finished transaction in 8. secs (8.02578u,0.001s)*)
+Qed.
+
+Lemma chords: forall O A B C D M:point,
+  equaldistance O A O B ->
+  equaldistance O A O C ->
+  equaldistance O A O D ->
+  collinear A B M -> collinear C D M ->
+  scalarproduct A M B = scalarproduct C M D
+  \/ parallel A B C D.
+Proof. geo_begin. 
+idtac "chords".
+ Time nsatz. 
+(*Finished transaction in 4. secs (3.959398u,0.s)*)
+Qed.
+
+Lemma Ceva: forall A B C D E F M:point,
+  collinear M A D -> collinear M B E -> collinear M C F ->
+  collinear B C D -> collinear E A C -> collinear F A B ->
+  (distance2 D B) * (distance2 E C) * (distance2 F A) =
+  (distance2 D C) * (distance2 E A) * (distance2 F B)
+  \/ collinear A B C.
+Proof. geo_begin. 
+idtac "Ceva".
 Time nsatz.
+(*Finished transaction in 105. secs (104.121171u,0.474928s)*)
+Qed.
+
+Lemma bissectrices: forall A B C M:point,
+  equaltangente C A M M A B ->
+  equaltangente A B M M B C ->
+  equaltangente B C M M C A
+  \/ equal3 A B.
+Proof. geo_begin. 
+idtac "bissectrices".
 Time nsatz.
+(*Finished transaction in 2. secs (1.937705u,0.s)*)
+Qed.
+
+Lemma bisections: forall A B C A1 B1 C1 H:point,
+  middle B C A1 ->  orthogonal H A1 B C ->
+  middle A C B1 -> orthogonal H B1 A C -> 
+  middle A B C1 -> 
+  orthogonal H C1 A B 
+  \/ collinear A B C.
+Proof. geo_begin.
+idtac "bisections". 
+Time nsatz. (*Finished transaction in 2. secs (2.024692u,0.002s)*)
+Qed.
+
+Lemma altitudes: 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
+  \/ equal2 A B
+  \/ collinear A B C.
+Proof. geo_begin.
+idtac "altitudes".
+Time nsatz. (*Finished transaction in 3. secs (3.001544u,0.s)*)
+Time nsatz. (*Finished transaction in 4. secs (3.113527u,0.s)*)
 Qed.
 
 Lemma hauteurs:forall A B C A1 B1 C1 H:point,
@@ -261,26 +519,16 @@ Lemma hauteurs:forall A B C A1 B1 C1 H:point,
   \/ 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! *)
+idtac "hauteurs".
 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 :: (@Datatypes.nil R)) in
- nsatz_domainpv ltac:pretacR 2%N 1%Z (@Datatypes.nil R) lv ltac:simplR Rdi;
-  discrR.
-(* Finished transaction in 6. secs (5.579152u,0.001s) *)
+ :: X A1 :: Y B1 :: X B1 :: Y A :: Y B :: X B :: X A :: X H :: Y C
+ :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in
+nsatz with radicalmax := 2%N strategy := 1%Z parameters := (@Datatypes.nil R)
+ variables := lv.
+(*Finished transaction in 5. secs (4.360337u,0.008999s)*)
 Qed.
 
+
 End Geometry.
 
diff --git a/test-suite/success/PCase.v b/test-suite/success/PCase.v
new file mode 100644
index 00000000..67d680ba
--- /dev/null
+++ b/test-suite/success/PCase.v
@@ -0,0 +1,66 @@
+
+(** Some tests of patterns containing matchs ending with joker branches.
+    Cf. the new form of the [constr_pattern] constructor [PCase]
+    in [pretyping/pattern.ml] *)
+
+(* A universal match matcher *)
+
+Ltac kill_match :=
+ match goal with
+   |- context [ match ?x with _ => _ end ] => destruct x
+ end.
+
+(* A match matcher restricted to a given type : nat *)
+
+Ltac kill_match_nat :=
+ match goal with
+   |- context [ match ?x in nat with _ => _ end ] => destruct x
+ end.
+
+(* Another way to restrict to a given type : give a branch *)
+
+Ltac kill_match_nat2 :=
+ match goal with
+   |- context [ match ?x with S _ => _ | _ => _ end ] => destruct x
+ end.
+
+(* This should act only on empty match *)
+
+Ltac kill_match_empty :=
+ match goal with
+   |- context [ match ?x with end ] => destruct x
+ end.
+
+Lemma test1 (b:bool) : if b then True else O=O.
+Proof.
+ Fail kill_match_nat.
+ Fail kill_match_nat2.
+ Fail kill_match_empty.
+ kill_match. exact I. exact eq_refl.
+Qed.
+
+Lemma test2a (n:nat) : match n with O => True | S n => (n = n) end.
+Proof.
+ Fail kill_match_empty.
+ kill_match_nat. exact I. exact eq_refl.
+Qed.
+
+Lemma test2b (n:nat) : match n with O => True | S n => (n = n) end.
+Proof.
+ kill_match_nat2. exact I. exact eq_refl.
+Qed.
+
+Lemma test2c (n:nat) : match n with O => True | S n => (n = n) end.
+Proof.
+ kill_match. exact I. exact eq_refl.
+Qed.
+
+Lemma test3a (f:False) : match f return Prop with end.
+Proof.
+ kill_match_empty.
+Qed.
+
+Lemma test3b (f:False) : match f return Prop with end.
+Proof.
+ kill_match.
+Qed.
diff --git a/test-suite/success/PrintSortedUniverses.v b/test-suite/success/PrintSortedUniverses.v
new file mode 100644
index 00000000..81326580
--- /dev/null
+++ b/test-suite/success/PrintSortedUniverses.v
@@ -0,0 +1,2 @@
+Require Reals.
+Print Sorted Universes.
diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v
index 81bdbc29..00a13aed 100644
--- a/test-suite/success/ProgramWf.v
+++ b/test-suite/success/ProgramWf.v
@@ -1,3 +1,9 @@
+(* Before loading Program, check non-anomaly on missing library Program *)
+
+Fail Program Definition f n (e:n=n): {n|n=0} := match n,e with 0, refl => 0 | _, _ => 0 end.
+
+(* Then we test Program properly speaking *)
+
 Require Import Arith Program.
 Require Import ZArith Zwf.
 
diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v
index d4e6a82e..2602c7e3 100644
--- a/test-suite/success/RecTutorial.v
+++ b/test-suite/success/RecTutorial.v
@@ -55,13 +55,13 @@ Check (cons 3 (cons 2 nil)).
 
 Require Import Bvector.
 
-Print vector.
+Print Vector.t.
 
-Check (Vnil nat).
+Check (Vector.nil nat).
 
-Check (fun (A:Set)(a:A)=> Vcons _ a _ (Vnil _)).
+Check (fun (A:Set)(a:A)=> Vector.cons _ a _ (Vector.nil _)).
 
-Check (Vcons _ 5 _ (Vcons _ 3 _ (Vnil _))).
+Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))).
 
 
 
@@ -315,16 +315,16 @@ Proof.
 Qed.
 
 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
-| Vcons _ n0 v0 => v0
+   (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):=
+match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with
+| Vector.nil => Vector.nil A
+| Vector.cons _ n0 v0 => v0
 end.
 
-Definition Vtail' (A:Set)(n:nat)(v:vector A n) : vector A (pred n).
+Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n).
  case v.
  simpl.
- exact (Vnil A).
+ exact (Vector.nil A).
  simpl.
  auto.
 Defined.
@@ -543,7 +543,7 @@ Inductive ex_Set  (P : Set -> Prop) : Type :=
 Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop :=
   c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p).
 
-Goal (comes_from_the_left _ _ (or_introl  True I)).
+Goal (comes_from_the_left _ _ (or_introl True I)).
 split.
 Qed.
 
@@ -966,37 +966,37 @@ let rec div_aux x y =
            | Right -> div_aux (minus x y) y)
 *)
 
-Lemma vector0_is_vnil : forall (A:Set)(v:vector A 0), v = Vnil A.
+Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A.
 Proof.
  intros A v;inversion v.
 Abort.
 
 (*
- Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n),
+ Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),
                                   n= 0 -> v = Vnil A.
 
 Toplevel input, characters 40281-40287
-> Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n),                                    n= 0 -> v = Vnil A.
+> Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),                                    n= 0 -> v = Vnil A.
 >                                                                                                                 ^^^^^^
 Error: In environment
 A : Set
 n : nat
-v : vector A n
+v : Vector.t A n
 e : n = 0
-The term "Vnil A" has type "vector A 0" while it is expected to have type
- "vector A n"
+The term "Vnil A" has type "Vector.t A 0" while it is expected to have type
+ "Vector.t A n"
 *)
  Require Import JMeq.
 
-Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n),
-                                  n= 0 -> JMeq v (Vnil A).
+Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),
+                                  n= 0 -> JMeq v (Vector.nil A).
 Proof.
  destruct v.
  auto.
  intro; discriminate.
 Qed.
 
-Lemma vector0_is_vnil : forall (A:Set)(v:vector A 0), v = Vnil A.
+Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A.
 Proof.
  intros a v;apply JMeq_eq.
  apply vector0_is_vnil_aux.
@@ -1004,56 +1004,56 @@ Proof.
 Qed.
 
 
-Implicit Arguments Vcons [A n].
-Implicit Arguments Vnil [A].
-Implicit Arguments Vhead [A n].
-Implicit Arguments Vtail [A n].
+Implicit Arguments Vector.cons [A n].
+Implicit Arguments Vector.nil [A].
+Implicit Arguments Vector.hd [A n].
+Implicit Arguments Vector.tl [A n].
 
-Definition Vid : forall (A : Type)(n:nat), vector A n -> vector A n.
+Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n.
 Proof.
  destruct n; intro v.
- exact Vnil.
- exact (Vcons  (Vhead v) (Vtail v)).
+ exact Vector.nil.
+ exact (Vector.cons  (Vector.hd v) (Vector.tl v)).
 Defined.
 
-Eval simpl in (fun (A:Set)(v:vector A 0) => (Vid _ _ v)).
+Eval simpl in (fun (A:Set)(v:Vector.t A 0) => (Vid _ _ v)).
 
-Eval simpl in (fun (A:Set)(v:vector A 0) => v).
+Eval simpl in (fun (A:Set)(v:Vector.t A 0) => v).
 
 
 
-Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v).
+Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v).
 Proof.
  destruct v.
  reflexivity.
  reflexivity.
 Defined.
 
-Theorem zero_nil : forall A (v:vector A 0), v = Vnil.
+Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil.
 Proof.
  intros.
- change (Vnil (A:=A)) with (Vid _ 0 v).
+ change (Vector.nil (A:=A)) with (Vid _ 0 v).
  apply Vid_eq.
 Defined.
 
 
 Theorem decomp :
-  forall (A : Set) (n : nat) (v : vector A (S n)),
-  v = Vcons (Vhead v) (Vtail v).
+  forall (A : Set) (n : nat) (v : Vector.t A (S n)),
+  v = Vector.cons (Vector.hd v) (Vector.tl v).
 Proof.
  intros.
- change (Vcons (Vhead v) (Vtail v)) with (Vid _  (S n) v).
+ change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _  (S n) v).
  apply Vid_eq.
 Defined.
 
 
 
 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 ->
-             P (S n) (Vcons a v1) (Vcons  b v2)) ->
-        forall n (v1 v2 : vector A n), P n v1 v2.
+    forall (A:Set) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type),
+        P 0 Vector.nil Vector.nil ->
+        (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 ->
+             P (S n) (Vector.cons a v1) (Vector.cons  b v2)) ->
+        forall n (v1 v2 : Vector.t A n), P n v1 v2.
  induction n.
  intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2).
  auto.
@@ -1063,24 +1063,24 @@ Defined.
 
 Require Import Bool.
 
-Definition bitwise_or n v1 v2 : vector bool n :=
-   vector_double_rect bool  (fun n v1 v2 => vector bool n)
-                        Vnil
-                        (fun n v1 v2 a b r => Vcons (orb a b) r) n v1 v2.
+Definition bitwise_or n v1 v2 : Vector.t bool n :=
+   vector_double_rect bool  (fun n v1 v2 => Vector.t bool n)
+                        Vector.nil
+                        (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2.
 
 
-Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:vector A p){struct v}
+Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v}
                   : option A :=
   match n,v  with
-    _   , Vnil => None
-  | 0   , Vcons b  _ _ => Some b
-  | S n', Vcons _  p' v' => vector_nth A n'  p' v'
+    _   , Vector.nil => None
+  | 0   , Vector.cons b  _ _ => Some b
+  | S n', Vector.cons _  p' v' => vector_nth A n'  p' v'
   end.
 
 Implicit Arguments vector_nth [A p].
 
 
-Lemma nth_bitwise : forall (n:nat) (v1 v2: vector bool n) i  a b,
+Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i  a b,
       vector_nth i v1 = Some a ->
       vector_nth i v2 = Some b ->
       vector_nth i (bitwise_or _ v1 v2) = Some (orb a b).
diff --git a/test-suite/success/Scheme.v b/test-suite/success/Scheme.v
new file mode 100644
index 00000000..dd5aa81d
--- /dev/null
+++ b/test-suite/success/Scheme.v
@@ -0,0 +1,4 @@
+(* This failed in 8.3pl2 *)
+
+Scheme Induction for eq Sort Prop.
+Check eq_ind_dep.
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index 324d340a..c4e67677 100644
--- a/test-suite/success/Tauto.v
+++ b/test-suite/success/Tauto.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Tauto.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (**** Tactics Tauto and Intuition ****)
 
 (**** Tauto:
diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v
index 6cc443bb..705bdc45 100644
--- a/test-suite/success/TestRefine.v
+++ b/test-suite/success/TestRefine.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
index a6f9fa23..e3183ef2 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -202,6 +202,13 @@ try apply H.
 unfold ID; apply H0.
 Qed.
 
+(* Test hyp in "apply -> ... in hyp" is correctly instantiated by Ltac *)
+
+Goal (True <-> False) -> True -> False.
+intros Heq H.
+match goal with [ H : True |- _ ] => apply -> Heq in H end.
+Abort.
+
 (* Test coercion below product and on non meta-free terms in with bindings *)
 (* Cf wishes #1408 from E. Makarov *)
 
@@ -326,13 +333,12 @@ 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) *)
+(* The following, which was failing badly in bug 1980, is now
+   properly rejected, as descend in conjunctions builds an
+   ill-formed elimination from Prop to Type. *)
 
 Goal True.
-eapply ex_intro.
-instantiate (2:=fun _ :True => True).
-instantiate (1:=I).
+Fail eapply ex_intro.
 exact I.
 Qed.
 
@@ -391,3 +397,21 @@ intro x;
 apply x.
 
 *)
+
+Section A.
+
+Variable map : forall (T1 T2 : Type) (f : T1 -> T2) (t11 t12 : T1),
+  identity (f t11) (f t12).
+
+Variable mapfuncomp : forall (X Y Z : Type) (f : X -> Y) (g : Y -> Z) (x x' : X),
+  identity (map Y Z g (f x) (f x')) (map X Z (fun x0 : X => g (f x0)) x x').
+
+Goal forall X:Type, forall Y:Type, forall f:X->Y, forall x : X, forall x' : X, 
+  forall g : Y -> X,
+  let gf := (fun x : X => g (f x)) : X -> X in
+   identity (map Y X g (f x) (f x')) (map X X gf x x').
+intros.
+apply mapfuncomp.
+Abort.
+
+End A.
diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v
new file mode 100644
index 00000000..9b691e25
--- /dev/null
+++ b/test-suite/success/auto.v
@@ -0,0 +1,26 @@
+(* Wish #2154 by E. van der Weegen *)
+
+(* auto was not using f_equal-style lemmas with metavariables occuring
+   only in the type of an evar of the concl, but not directly in the
+   concl itself *)
+
+Parameters
+  (F: Prop -> Prop)
+  (G: forall T, (T -> Prop) -> Type)
+  (L: forall A (P: A -> Prop), G A P -> forall x, F (P x))
+  (Q: unit -> Prop).
+
+Hint Resolve L.
+
+Goal G unit Q -> F (Q tt).
+  intro.
+  auto.
+Qed.
+
+(* Test implicit arguments in "using" clause *)
+
+Goal forall n:nat, nat * nat.
+auto using (pair O).
+Undo.
+eauto using (pair O).
+Qed.
diff --git a/test-suite/success/autorewritein.v b/test-suite/success/autorewrite.v
index 68f2f7ce..5e9064f8 100644
--- a/test-suite/success/autorewritein.v
+++ b/test-suite/success/autorewrite.v
@@ -19,5 +19,11 @@ Proof.
     apply H;reflexivity.
 Qed.
 
+(* Check autorewrite does not solve existing evars *)
+(* See discussion started by A. Chargueraud in Oct 2010 on coqdev *)
 
+Hint Rewrite <- plus_n_O : base1.
+Goal forall y, exists x, y+x = y.
+eexists. autorewrite with base1.
+Fail reflexivity.
 
diff --git a/test-suite/success/bullet.v b/test-suite/success/bullet.v
new file mode 100644
index 00000000..1099f3e1
--- /dev/null
+++ b/test-suite/success/bullet.v
@@ -0,0 +1,5 @@
+Goal True /\ True.
+split.
+- exact I.
+- exact I.
+Qed.
diff --git a/test-suite/success/change.v b/test-suite/success/change.v
index 5ac6ce82..c65cf303 100644
--- a/test-suite/success/change.v
+++ b/test-suite/success/change.v
@@ -30,3 +30,11 @@ change 3 at 1 with (1+2) in H |- *.
 change 3 at 1 with (1+2) in H, H|-.
 change 3 in |- * at 1.
  *)
+
+(* Test that pretyping checks allowed elimination sorts *)
+
+Goal True.
+Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x).
+Fail change True with
+        match ex_intro _ True (eq_refl True) with ex_intro x _ => x end.
+Abort.
diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v
index 908b5f77..001beae7 100644
--- a/test-suite/success/coercions.v
+++ b/test-suite/success/coercions.v
@@ -81,3 +81,11 @@ Coercion irrelevent := (fun _ => I) : True -> car (Build_Setoid True).
 
 Definition ClaimB := forall (X Y:Setoid) (f: extSetoid X Y) (x:X), f x= f x.
 
+(* Check that coercions are made visible only when modules are imported *)
+
+Module A.
+  Module B. Coercion b2n (b:bool) := if b then 0 else 1. End B.
+  Fail Check S true.
+End A.
+Import A.
+Fail Check S true.
diff --git a/test-suite/success/conv_pbs.v b/test-suite/success/conv_pbs.v
index f6ebacae..05d2c98f 100644
--- a/test-suite/success/conv_pbs.v
+++ b/test-suite/success/conv_pbs.v
@@ -221,3 +221,8 @@ with universal_completeness_stoup (Gamma:context)(A:formula){struct A}
           (ProofForallL x t (subst_formula (remove_assoc _ x rho) A)
           (eq_rect _ (fun D => Gamma'' ; D |- C) p _ (subst_commute _ _ _ _)))))
   end.
+
+
+(* A simple example that raised an uncaught exception at some point *)
+
+Fail Check fun x => @eq_refl x <: true = true.
diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v
index 8013e1d3..fc40ea96 100644
--- a/test-suite/success/destruct.v
+++ b/test-suite/success/destruct.v
@@ -74,3 +74,22 @@ destruct H.
 destruct H0.
 reflexivity.
 Qed.
+
+(* These did not work before 8.4 *)
+
+Goal (exists x, x=0) -> True.
+destruct 1 as (_,_); exact I.
+Abort.
+
+Goal (exists x, x=0 /\ True) -> True.
+destruct 1 as (_,(_,H)); exact H.
+Abort.
+
+Goal (exists x, x=0 /\ True) -> True.
+destruct 1 as (_,(_,x)); exact x.
+Abort.
+
+Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0.
+intros.
+destruct (g _). (* This was failing in at least r14571 *)
+Abort.
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
index 1862ad10..a94d8b1d 100644
--- a/test-suite/success/eauto.v
+++ b/test-suite/success/eauto.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v
index ff880d00..8c00583e 100644
--- a/test-suite/success/eqdecide.v
+++ b/test-suite/success/eqdecide.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,12 +16,7 @@ Qed.
 
 Lemma lem2 : forall x y : T, {x = y} + {x <> y}.
 intros x y.
- decide equality x y.
-Qed.
-
-Lemma lem3 : forall x y : T, {x = y} + {x <> y}.
-intros x y.
- decide equality y x.
+ decide equality.
 Qed.
 
 Lemma lem4 : forall x y : T, {x = y} + {x <> y}.
diff --git a/test-suite/success/eta.v b/test-suite/success/eta.v
new file mode 100644
index 00000000..08078012
--- /dev/null
+++ b/test-suite/success/eta.v
@@ -0,0 +1,19 @@
+(* Kernel test (head term is a constant) *)
+Check (fun a : S = S => a : S = fun x => S x).
+
+(* Kernel test (head term is a variable) *)
+Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => f x).
+
+(* Test type inference  (head term is syntactically rigid) *)
+Check (fun (a : list = list) => a : list = fun A => _ A).
+
+(* Test type inference (head term is a variable) *)
+(* This one is still to be done...
+Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => _ x).
+*)
+
+(* Test tactic unification *)
+Goal (forall f:nat->nat, (fun x => f x) = (fun x => f x)) -> S = S.
+intro H; apply H.
+Qed.
+
diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v
index 6423ad14..2f1ec757 100644
--- a/test-suite/success/evars.v
+++ b/test-suite/success/evars.v
@@ -238,3 +238,74 @@ eapply f_equal with (* should fail because ill-typed *)
         end) in H
 || injection H.
 Abort.
+
+(* A legitimate simple eapply that was failing in coq <= 8.3.
+   Cf. in Unification.w_merge the addition of an extra pose_all_metas_as_evars
+   on 30/9/2010
+*)
+
+Lemma simple_eapply_was_failing :
+ (forall f:nat->nat, exists g, f = g) -> True.
+Proof.
+ assert (modusponens : forall P Q, P -> (P->Q) -> Q) by auto.
+ intros.
+ eapply modusponens.
+ simple eapply H.
+ (* error message with V8.3 :
+    Impossible to unify "?18" with "fun g : nat -> nat => ?6 = g". *)
+Abort.
+
+(* Regression test *)
+
+Definition fo : option nat -> nat := option_rec _ (fun a => 0) 0.
+
+(* This example revealed an incorrect evar restriction at some time
+   around October 2011 *)
+
+Goal forall (A:Type) (a:A) (P:forall A, A -> Prop), (P A a) /\ (P A a).
+intros.
+refine ((fun H => conj (proj1 H) (proj2 H)) _).
+Abort.
+
+(* The argument of e below failed to be inferred from r14219 (Oct 2011) to *)
+(* r14753 after the restrictions made on detecting Miller's pattern in the *)
+(* presence of alias, only the second-order unification procedure was *)
+(* able to solve this problem but it was deactivated for 8.4 in r14219 *)
+
+Definition k0
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, n = a) o :=
+ match o with (* note: match introduces an alias! *)
+ | Some a => e _ (j a)
+ | None => O
+ end.
+
+Definition k1
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j a).
+
+Definition k2
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b).
+
+(* Other examples about aliases involved in pattern unification *)
+
+Definition k3
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, let a' := a in n = a') a (b:=a) := e _ (j b).
+
+Definition k4
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, let a' := S a in n = a') a (b:=a) := e _ (j b).
+
+Definition k5
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, let a' := S a in exists n : nat, n = a') a (b:=a) := e _ (j b).
+
+Definition k6
+  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
+  (j : forall a, exists n : nat, let n' := S n in n' = a) a (b:=a) := e _ (j b).
+
+Definition k7
+  (e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat)
+  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b).
diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v
index 4fec6e7f..3f8a3bc4 100644
--- a/test-suite/success/extraction.v
+++ b/test-suite/success/extraction.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -342,7 +342,7 @@ case H1.
 exact H0.
 intros.
 exact n.
-Qed.
+Defined.
 Extraction oups.
 (*
 let oups h0 =
diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v
index be4e0684..b25b502c 100644
--- a/test-suite/success/fix.v
+++ b/test-suite/success/fix.v
@@ -9,13 +9,12 @@ Inductive rBoolOp : Set :=
   | rAnd : rBoolOp
   | rEq : rBoolOp.
 
-Definition rlt (a b : rNat) : Prop :=
-  (a ?= b)%positive Datatypes.Eq = Datatypes.Lt.
+Definition rlt (a b : rNat) : Prop := Pcompare a b Eq = Lt.
 
 Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
 intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
  generalize (nat_of_P_gt_Gt_compare_morphism n m);
- generalize (Pcompare_Eq_eq n m); case ((n ?= m)%positive Datatypes.Eq).
+ generalize (Pcompare_Eq_eq n m); case (Pcompare n m Eq).
 intros H' H'0 H'1; right; right; auto.
 intros H' H'0 H'1; left; unfold rlt in |- *.
 apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v
index ce3e692f..e8019a90 100644
--- a/test-suite/success/implicit.v
+++ b/test-suite/success/implicit.v
@@ -107,3 +107,20 @@ Context {A:Set}.
 Definition h (a:A) := a.
 End C.
 Check h 0.
+
+(* Check implicit arguments in arity of inductive types. The three
+   following examples used to fail before r13671 *)
+
+Inductive I {A} (a:A) : forall {n:nat}, Prop :=
+ | C : I a (n:=0).
+
+Inductive I2 (x:=0) : Prop :=
+ | C2 {p:nat} : p = 0 -> I2.
+Check C2 eq_refl.
+
+Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop :=
+ | C3 : I3 a (n:=0).
+
+(* Check global implicit declaration over ref not in section *)
+
+Section D. Global Arguments eq [A] _ _. End D.
diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v
index 7626ecc4..234c4223 100644
--- a/test-suite/success/inds_type_sec.v
+++ b/test-suite/success/inds_type_sec.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v
index 3c8d8ea9..b24ed2f1 100644
--- a/test-suite/success/induct.v
+++ b/test-suite/success/induct.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -41,3 +41,26 @@ Proof.
   auto.
   auto.
 Qed.
+
+(* Check selection of occurrences by pattern *)
+
+Goal forall x, S x = S (S x).   
+intros.
+induction (S _) in |- * at -2.
+now_show (0=1).
+Undo 2.
+induction (S _) in |- * at 1 3.
+now_show (0=1).
+Undo 2.
+induction (S _) in |- * at 1.
+now_show (0=S (S x)).
+Undo 2.
+induction (S _) in |- * at 2.
+now_show (S x=0).
+Undo 2.
+induction (S _) in |- * at 3.
+now_show (S x=1).
+Undo 2.
+Fail induction (S _) in |- * at 4.
+Abort.
+
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
index 02618c2c..7387add6 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -244,6 +244,29 @@ reflexivity.
 apply I.
 Qed.
 
+(* Test binding of open terms with non linear matching *)
+
+Ltac f_non_linear t :=
+  match t with
+    (forall x y, ?u = 0) -> (forall y x, ?u = 0) =>
+       assert (forall x y:nat, u = u)
+  end.
+
+Goal True.
+f_non_linear ((forall x y, x+y = 0) -> (forall x y, y+x = 0)).
+reflexivity.
+f_non_linear ((forall a b, a+b = 0) -> (forall a b, b+a = 0)).
+reflexivity.
+f_non_linear ((forall a b, a+b = 0) -> (forall x y, y+x = 0)).
+reflexivity.
+f_non_linear ((forall x y, x+y = 0) -> (forall a b, b+a = 0)).
+reflexivity.
+f_non_linear ((forall x y, x+y = 0) -> (forall y x, x+y = 0)).
+reflexivity.
+f_non_linear ((forall x y, x+y = 0) -> (forall y x, y+x = 0)) (* should fail *)
+|| exact I.
+Qed.
+
 (* Test regular failure when clear/intro breaks soundness of the
    interpretation of terms in current environment *)
 
@@ -275,3 +298,7 @@ evar(foo:nat).
 let evval := eval compute in foo in not_eq evval 1.
 let evval := eval compute in foo in not_eq 1 evval.
 Abort.
+
+(* Check that this returns an error and not an anomaly (see r13667) *)
+
+Fail Local Tactic Notation "myintro" := intro.
diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v
index 41aa3b3e..fcadd150 100644
--- a/test-suite/success/mutual_ind.v
+++ b/test-suite/success/mutual_ind.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v
index 5a008f18..56cab0f6 100644
--- a/test-suite/success/polymorphism.v
+++ b/test-suite/success/polymorphism.v
@@ -9,4 +9,4 @@ End S.
 (*
 Check f nat nat : Set.
 *)
-Check I nat nat : Set.
+Check I nat nat : Set.
\ No newline at end of file
diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v
new file mode 100644
index 00000000..93a9ef11
--- /dev/null
+++ b/test-suite/success/proof_using.v
@@ -0,0 +1,61 @@
+Section Foo.
+
+Variable a : nat.
+
+Lemma l1 : True.
+Fail Proof using non_existing.
+Proof using a.
+exact I.
+Qed.
+
+Lemma l2 : True.
+Proof using a.
+Admitted.
+
+Lemma l3 : True.
+Proof using a.
+admit.
+Qed.
+
+End Foo.
+
+Check (l1 3).
+Check (l2 3).
+Check (l3 3).
+
+Section Bar.
+
+Variable T : Type.
+Variable a b : T.
+Variable H : a = b.
+
+Lemma l4 : a = b.
+Proof using H.
+exact H.
+Qed.
+
+End Bar.
+
+Check (l4 _ 1 1 _ : 1 = 1).
+
+Section S1.
+
+Variable v1 : nat.
+
+Section S2.
+
+Variable v2 : nat.
+
+Lemma deep : v1 = v2.
+Proof using v1 v2.
+admit.
+Qed.
+
+End S2.
+
+Check (deep 3 : v1 = 3).
+
+End S1.
+
+Check (deep 3 4 : 3 = 4).
+
diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v
new file mode 100644
index 00000000..3241e133
--- /dev/null
+++ b/test-suite/success/remember.v
@@ -0,0 +1,8 @@
+(* Testing remember and co *)
+
+Lemma A : forall (P: forall X, X -> Prop), P nat 0 -> P nat 0.
+intros.
+Fail remember nat as X.
+Fail remember nat as X in H. (* This line used to succeed in 8.3 *)
+Fail remember nat as X in |- *.
+Abort.
diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v
index 3bce52fe..08c406be 100644
--- a/test-suite/success/rewrite.v
+++ b/test-suite/success/rewrite.v
@@ -108,3 +108,24 @@ intros.
 rewrite (H _).
 reflexivity.
 Qed.
+
+(* Example of rewriting of a degenerated pattern using the right-most
+   argument of the goal. This is sometimes used in contribs, even if
+   ad hoc. Here, we have the extra requirement that checking types
+   needs delta-conversion *)
+
+Axiom s : forall (A B : Type) (p : A * B), p = (fst p, snd p).
+Definition P := (nat * nat)%type.
+Goal forall x:P, x = x.
+intros. rewrite s.
+Abort.
+
+(* Test second-order unification and failure of pattern-unification *)
+
+Goal forall (P: forall Y, Y -> Prop) Y a, Y = nat -> (True -> P Y a) -> False.
+intros.
+(* The next line used to succeed between June and November 2011 *)
+(* causing ill-typed rewriting *)
+Fail rewrite H in H0.
+Abort.
+
diff --git a/test-suite/success/searchabout.v b/test-suite/success/searchabout.v
new file mode 100644
index 00000000..d9ade314
--- /dev/null
+++ b/test-suite/success/searchabout.v
@@ -0,0 +1,60 @@
+
+(** Test of the different syntaxes of SearchAbout, in particular
+    with and without the [ ... ] delimiters *)
+
+SearchAbout plus.
+SearchAbout plus mult.
+SearchAbout "plus_n".
+SearchAbout plus "plus_n".
+SearchAbout "*".
+SearchAbout "*" "+".
+
+SearchAbout plus inside Peano.
+SearchAbout plus mult inside Peano.
+SearchAbout "plus_n" inside Peano.
+SearchAbout plus "plus_n" inside Peano.
+SearchAbout "*" inside Peano.
+SearchAbout "*" "+" inside Peano.
+
+SearchAbout plus outside Peano Logic.
+SearchAbout plus mult outside Peano Logic.
+SearchAbout "plus_n" outside Peano Logic.
+SearchAbout plus "plus_n" outside Peano Logic.
+SearchAbout "*" outside Peano Logic.
+SearchAbout "*" "+" outside Peano Logic.
+
+SearchAbout -"*" "+" outside Logic.
+SearchAbout -"*"%nat "+"%nat outside Logic.
+
+SearchAbout [plus].
+SearchAbout [plus mult].
+SearchAbout ["plus_n"].
+SearchAbout [plus "plus_n"].
+SearchAbout ["*"].
+SearchAbout ["*" "+"].
+
+SearchAbout [plus] inside Peano.
+SearchAbout [plus mult] inside Peano.
+SearchAbout ["plus_n"] inside Peano.
+SearchAbout [plus "plus_n"] inside Peano.
+SearchAbout ["*"] inside Peano.
+SearchAbout ["*" "+"] inside Peano.
+
+SearchAbout [plus] outside Peano Logic.
+SearchAbout [plus mult] outside Peano Logic.
+SearchAbout ["plus_n"] outside Peano Logic.
+SearchAbout [plus "plus_n"] outside Peano Logic.
+SearchAbout ["*"] outside Peano Logic.
+SearchAbout ["*" "+"] outside Peano Logic.
+
+SearchAbout [-"*" "+"] outside Logic.
+SearchAbout [-"*"%nat "+"%nat] outside Logic.
+
+
+(** The example in the Reference Manual *)
+
+Require Import ZArith.
+
+SearchAbout Zmult Zplus "distr".
+SearchAbout "+"%Z "*"%Z "distr" -positive -Prop.
+SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas.
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index 033b3f48..19693d70 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -130,3 +130,38 @@ intros f0 Q H.
 setoid_rewrite H.
 tauto.
 Qed.
+
+(** Check proper refreshing of the lemma application for multiple 
+   different instances in a single setoid rewrite. *)
+
+Section mult.
+  Context (fold : forall {A} {B}, (A -> B) -> A -> B).
+  Context (add : forall A, A -> A).
+  Context (fold_lemma : forall {A B f} {eqA : relation B} x, eqA (fold A B f (add A x)) (fold _ _ f x)).
+  Context (ab : forall B, A -> B).
+  Context (anat : forall A, nat -> A).
+
+Goal forall x, (fold _ _ (fun x => ab A x) (add A x) = anat _ (fold _ _ (ab nat) (add _ x))). 
+Proof. intros.
+  setoid_rewrite fold_lemma. 
+  change (fold A A (fun x0 : A => ab A x0) x = anat A (fold A nat (ab nat) x)).
+Abort.
+
+End mult.
+
+(** Current semantics for rewriting with typeclass constraints in the lemma 
+   does not fix the instance at the first unification, use [at], or simply rewrite for 
+   this semantics. *)
+
+Require Import Arith.
+
+Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}.
+Instance: Foo nat. admit. Defined.
+Instance: Foo bool. admit. Defined.
+
+Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y.
+Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort.
+
+Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y.
+Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort.
+
diff --git a/test-suite/success/simpl_tuning.v b/test-suite/success/simpl_tuning.v
new file mode 100644
index 00000000..d4191b93
--- /dev/null
+++ b/test-suite/success/simpl_tuning.v
@@ -0,0 +1,149 @@
+(* as it is dynamically inferred by simpl *)
+Arguments minus !n / m.
+
+Lemma foo x y : S (S x) - S y = 0.
+simpl.
+match goal with |- (match y with O => S x | S _ => _ end = 0) => idtac end.
+Abort. 
+
+(* we avoid exposing a match *)
+Arguments minus n m : simpl nomatch. 
+
+Lemma foo x : minus 0 x = 0.
+simpl.
+match goal with |- (0 = 0) => idtac end.
+Abort.
+
+Lemma foo x y : S (S x) - S y = 0.
+simpl.
+match goal with |- (S x - y = 0) => idtac end.
+Abort.
+
+Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0.
+simpl.
+match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end.
+Abort.
+
+(* we unfold as soon as we have 1 args, but we avoid exposing a match *)
+Arguments minus n / m : simpl nomatch. 
+
+Lemma foo : minus 0 = fun x => 0.
+simpl.
+match goal with |- minus 0 = _ => idtac end.
+Abort.
+(* This does not work as one may expect. The point is that simpl is implemented
+   as "strong (whd_simpl_state)" and after unfolding minus you have
+   (fun m => match 0 => 0 | S n => ...) that is already in whd and exposes
+   a match, that of course "strong" would reduce away but at that stage
+   we don't know, and reducing by hand under the lambda is against whd *) 
+
+(* extra tuning for the usual heuristic *)
+Arguments minus !n / m : simpl nomatch. 
+
+Lemma foo x y : S (S x) - S y = 0.
+simpl.
+match goal with |- (S x - y = 0) => idtac end.
+Abort.
+
+Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0.
+simpl.
+match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end.
+Abort.
+
+(* full control *)
+Arguments minus !n !m /.
+
+Lemma foo x y : S (S x) - S y = 0.
+simpl.
+match goal with |- (S x - y = 0) => idtac end.
+Abort.
+
+Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0.
+simpl.
+match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end.
+Abort.
+
+(* omitting /, that being immediately after the last ! is irrelevant *)
+Arguments minus !n !m.
+
+Lemma foo x y : S (S x) - S y = 0.
+simpl.
+match goal with |- (S x - y = 0) => idtac end.
+Abort.
+
+Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0.
+simpl.
+match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end.
+Abort.
+
+Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := 
+  fun x => (f (fst x), g (snd x)).
+
+Delimit Scope foo_scope with F.
+Notation "@@" := nat (only parsing) : foo_scope.
+Notation "@@" := (fun x => x) (only parsing).
+
+Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never.
+
+Lemma foo x : @pf @@ nat @@ nat nat @@ x = pf @@ @@ x.
+Abort.
+
+Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x).
+
+(* fcomp is unfolded if applied to 6 args *)
+Arguments fcomp {A B C}%type f g x /.
+
+Notation "f \o g" := (fcomp f g) (at level 50).
+
+Lemma foo (f g h : nat -> nat) x : pf (f \o g) h x = pf f h (g (fst x), snd x).
+simpl.
+match goal with |- (pf (f \o g) h x = _) => idtac end.
+case x; intros x1 x2. 
+simpl.
+match goal with |- (pf (f \o g) h _ = pf f h _) => idtac end.
+unfold pf; simpl.
+match goal with |- (f (g x1), h x2) = (f (g x1), h x2) => idtac end.
+Abort. 
+
+Definition volatile := fun x : nat => x.
+Arguments volatile /.
+
+Lemma foo : volatile = volatile.
+simpl.
+match goal with |- (fun _ => _) = _ => idtac end.
+Abort.
+
+Set Implicit Arguments.
+
+Section S1.
+
+Variable T1 : Type.
+
+Section S2.
+
+Variable T2 : Type.
+
+Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat :=
+  match n, m with
+  | 0,_ => 0
+  | S _, 0 => n
+  | S n', S m' => f x y n' v m' end.
+
+Global Arguments f x y !n !v !m.
+
+Lemma foo x y n m : f x y (S n) tt m = f x y (S n) tt (S m).
+simpl.
+match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end.
+Abort.
+
+End S2.
+
+Lemma foo T x y n m : @f T x y (S n) tt m = @f T x y (S n) tt (S m).
+simpl.
+match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end.
+Abort.
+
+End S1.
+
+Arguments f : clear implicits and scopes.
+
diff --git a/test-suite/success/telescope_canonical.v b/test-suite/success/telescope_canonical.v
new file mode 100644
index 00000000..8a607c93
--- /dev/null
+++ b/test-suite/success/telescope_canonical.v
@@ -0,0 +1,12 @@
+Structure Inner := mkI { is :> Type }.
+Structure Outer := mkO { os :> Inner }.
+
+Canonical Structure natInner := mkI nat.
+Canonical Structure natOuter := mkO natInner.
+
+Definition hidden_nat := nat.
+
+Axiom P : forall S : Outer, is (os S) -> Prop.
+
+Lemma foo (n : hidden_nat) : P _ n.
+Admitted.
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
index 66c4e080..5649e2f7 100644
--- a/test-suite/success/unfold.v
+++ b/test-suite/success/unfold.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v
index ddf122e8..997dceb4 100644
--- a/test-suite/success/unification.v
+++ b/test-suite/success/unification.v
@@ -21,6 +21,12 @@ Proof.
 intros; apply H.
 Qed.
 
+  (* Feature introduced June 2011 *)
+
+Lemma l7 : forall x (P:nat->Prop), (forall f, P (f x)) -> P (x+x).
+Proof.
+intros x P H; apply H.
+Qed.
 
 (* Example submitted for Zenon *)
 
@@ -90,12 +96,14 @@ intros.
 apply H.
 Qed.
 
+(* Feature deactivated in commit 14189 (see commit log)
 (* Test instanciation of evars by unification *)
 
 Goal (forall x, 0 + x = 0 -> True) -> True.
 intros; eapply H.
 rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *)
 Abort.
+*)
 
 (* Check handling of identity equation between evars *)
 (* The example failed to pass until revision 10623 *)
@@ -135,4 +143,44 @@ 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.
+  rewrite H with (f:=f0).
+Abort.
+
+(* Three tests provided by Dan Grayson as part of a custom patch he
+   made for a more powerful "destruct" for handling Voevodsky's
+   Univalent Foundations. The test checks if second-order matching in
+   tactic unification is able to guess by itself on which dependent
+   terms to abstract so that the elimination predicate is well-typed *)
+
+Definition test1 (X : Type) (x : X) (fxe : forall x1 : X, identity x1 x1) :
+  identity (fxe x) (fxe x).
+Proof. destruct (fxe x). apply identity_refl. Defined.
+
+(* a harder example *)
+
+Definition UU := Type .
+Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t.
+Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := newfoo : foo x0 x0.
+Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo x0 x1 -> foo x0 x1.
+Proof. intros t. exact t. Defined.
+
+Lemma test2 (T:UU) (t:T) (k : foo t t) : paths k (idonfoo k).
+Proof.
+  destruct k.
+  apply idpath.
+Defined.
+
+(* an example with two constructors *)
+
+Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU :=
+| newfoo1 : foo' x0 x0
+| newfoo2 : foo' x0 x0 .
+Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} :
+  foo' x0 x1 -> foo' x0 x1.
+Proof. intros t. exact t. Defined.
+Lemma test3 (T:UU) (t:T) (k : foo' t t) : paths k (idonfoo' k).
+Proof.
+  destruct k.
+  apply idpath.
+  apply idpath.
+Defined.
diff --git a/test-suite/success/universes-coercion.v b/test-suite/success/universes-coercion.v
new file mode 100644
index 00000000..d7504340
--- /dev/null
+++ b/test-suite/success/universes-coercion.v
@@ -0,0 +1,22 @@
+(* This example used to emphasize the absence of LEGO-style universe
+   polymorphism; Matthieu's improvements of typing on 2011/3/11 now
+   makes (apparently) that Amokrane's automatic eta-expansion in the
+   coercion mechanism works; this makes its illustration as a "weakness"
+   of universe polymorphism obsolete (example submitted by Randy Pollack).
+
+   Note that this example is not an evidence that the current
+   non-kernel eta-expansion behavior is the most expected one.  
+*)
+
+Parameter K : forall T : Type, T -> T.
+Check (K (forall T : Type, T -> T) K).
+
+(*
+   note that the inferred term is
+     "(K (forall T (* u1 *) : Type, T -> T) (fun T:Type (* u1 *) => K T))"
+   which is not eta-equivalent to 
+     "(K (forall T : Type, T -> T) K"
+   because the eta-expansion of the latter
+     "(K (forall T : Type, T -> T) (fun T:Type (* u2 *) => K T)"
+  assuming K of type "forall T (* u2 *) : Type, T -> T"
+*)
diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v
index cc40ae07..3fdcce6f 100644
--- a/test-suite/typeclasses/NewSetoid.v
+++ b/test-suite/typeclasses/NewSetoid.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,8 +11,6 @@
  * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: FSetAVL_prog.v 616 2007-08-08 12:28:10Z msozeau $ *)
-
 Require Import Coq.Program.Program.
 
 Set Implicit Arguments.
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
index 2e9dc2de..6f3827a3 100644
--- a/theories/Arith/Arith.v
+++ b/theories/Arith/Arith.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Arith_base.
 Require Export ArithRing.
diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v
index e9953e54..4f21dadf 100644
--- a/theories/Arith/Arith_base.v
+++ b/theories/Arith/Arith_base.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith_base.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Le.
 Require Export Lt.
 Require Export Plus.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 65753e31..dd514653 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Between.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Le.
 Require Import Lt.
 
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index b3dcd8ec..f384e148 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bool_nat.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Compare_dec.
 Require Export Peano_dec.
 Require Import Sumbool.
@@ -36,4 +34,4 @@ Definition nat_noteq_bool x y :=
   bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)).
 
 Definition zerop_bool x := bool_of_sumbool (zerop x).
-Definition notzerop_bool x := bool_of_sumbool (notzerop x).
\ No newline at end of file
+Definition notzerop_bool x := bool_of_sumbool (notzerop x).
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
index 2fe5c0d9..c9e6d3cf 100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Equality is decidable on [nat] *)
 
 Open Local Scope nat_scope.
@@ -52,4 +50,4 @@ Qed.
 
 Require Export Wf_nat.
 
-Require Export Min Max.
\ No newline at end of file
+Require Export Min Max.
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index 99c7415e..360d760a 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Le.
 Require Import Lt.
 Require Import Gt.
@@ -22,21 +20,21 @@ Proof.
   destruct n; auto with arith.
 Defined.
 
-Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}.
+Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}.
 Proof.
-  induction n; destruct m; auto with arith.
+  induction n in m |- *; 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 : forall n m, {m > n} + {n = m} + {n > m}.
+Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}.
 Proof.
   intros; apply lt_eq_lt_dec; assumption.
 Defined.
 
-Definition le_lt_dec : forall n m, {n <= m} + {m < n}.
+Definition le_lt_dec n m : {n <= m} + {m < n}.
 Proof.
-  induction n.
+  induction n in m |- *.
   auto with arith.
   destruct m.
   auto with arith.
@@ -200,7 +198,8 @@ Proof.
    apply -> nat_compare_lt; auto.
 Qed.
 
-Lemma nat_compare_spec : forall x y, CompSpec eq lt x y (nat_compare x y).
+Lemma nat_compare_spec :
+  forall x y, CompareSpec (x=y) (x<y) (y<x) (nat_compare x y).
 Proof.
  intros.
  destruct (nat_compare x y) as [ ]_eqn; constructor.
@@ -209,7 +208,6 @@ Proof.
  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.
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 89620f5f..24cbc3f9 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Div2.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Lt.
 Require Import Plus.
 Require Import Compare_dec.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index 60575beb..94986278 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: EqNat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Equality on natural numbers *)
 
 Open Local Scope nat_scope.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index f32e1ad4..513fd110 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -1,25 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Euclid.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Mult.
 Require Import Compare_dec.
 Require Import Wf_nat.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types a b n q r : nat.
 
 Inductive diveucl a b : Set :=
   divex : forall q r, b > r -> a = q * b + r -> diveucl a b.
 
-
 Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
 Proof.
   intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
@@ -32,7 +29,7 @@ Proof.
   elim e; auto with arith.
   intros gtbn.
   apply divex with 0 n; simpl in |- *; auto with arith.
-Qed.
+Defined.
 
 Lemma quotient :
   forall n,
@@ -50,7 +47,7 @@ Proof.
   elim H1; auto with arith.
   intros gtbn.
   exists 0; exists n; simpl in |- *; auto with arith.
-Qed.
+Defined.
 
 Lemma modulo :
   forall n,
@@ -68,4 +65,4 @@ Proof.
   elim H1; auto with arith.
   intros gtbn.
   exists n; exists 0; simpl in |- *; auto with arith.
-Qed.
+Defined.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index 5bab97c2..cd4dae98 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Even.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Here we define the predicates [even] and [odd] by mutual induction
     and we prove the decidability and the exclusion of those predicates.
     The main results about parity are proved in the module Div2. *)
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index 3b434b96..146546dc 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Factorial.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Plus.
 Require Import Mult.
 Require Import Lt.
@@ -15,13 +13,13 @@ Open Local Scope nat_scope.
 
 (** Factorial *)
 
-Boxed Fixpoint fact (n:nat) : nat :=
+Fixpoint fact (n:nat) : nat :=
   match n with
     | O => 1
     | S n => S n * fact n
   end.
 
-Arguments Scope fact [nat_scope].
+Arguments fact n%nat.
 
 Lemma lt_O_fact : forall n:nat, 0 < fact n.
 Proof.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index 43df01c0..32f453e5 100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Gt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
 <<
 Definition gt (n m:nat) := m < n.
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index b73959e7..f0ebf162 100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Le.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Order on natural numbers. [le] is defined in [Init/Peano.v] as:
 <<
 Inductive le (n:nat) : nat -> Prop :=
@@ -84,8 +82,7 @@ Hint Immediate le_Sn_le: arith v62.
 
 Theorem le_S_n : forall n m, S n <= S m -> n <= m.
 Proof.
-  intros n m H; change (pred (S n) <= pred (S m)) in |- *.
-  destruct H; simpl; auto with arith.
+  exact Peano.le_S_n.
 Qed.
 Hint Immediate le_S_n: arith v62.
 
@@ -105,11 +102,9 @@ Hint Resolve le_pred_n: arith v62.
 
 Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
 Proof.
-  destruct n; simpl; auto with arith.
-  destruct m; simpl; auto with arith.
+  exact Peano.le_pred.
 Qed.
 
-
 (** * [le] is a order on [nat] *)
 (** Antisymmetry *)
 
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index 004274fe..e07bba8d 100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as:
 <<
 Definition lt (n m:nat) := S n <= m.
@@ -96,9 +94,9 @@ Proof.
 Qed.
 Hint Resolve lt_0_Sn: arith v62.
 
-Theorem lt_n_O : forall n, ~ n < 0.
-Proof le_Sn_O.
-Hint Resolve lt_n_O: arith v62.
+Theorem lt_n_0 : forall n, ~ n < 0.
+Proof le_Sn_0.
+Hint Resolve lt_n_0: arith v62.
 
 (** * Predecessor *)
 
@@ -192,4 +190,5 @@ Hint Immediate lt_0_neq: arith v62.
 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).
+Notation lt_n_O := lt_n_0 (only parsing).
 (* end hide *)
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index d1b1b269..77dfa508 100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -1,44 +1,48 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Max.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *)
 
-(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
-
-Require Export MinMax.
+Require Import NPeano.
 
 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.
+Notation max := Peano.max (only parsing).
+
+Definition max_0_l := Nat.max_0_l.
+Definition max_0_r := Nat.max_0_r.
+Definition succ_max_distr := Nat.succ_max_distr.
+Definition plus_max_distr_l := Nat.add_max_distr_l.
+Definition plus_max_distr_r := Nat.add_max_distr_r.
+Definition max_case_strong := Nat.max_case_strong.
+Definition max_spec := Nat.max_spec.
+Definition max_dec := Nat.max_dec.
+Definition max_case := Nat.max_case.
+Definition max_idempotent := Nat.max_id.
+Definition max_assoc := Nat.max_assoc.
+Definition max_comm := Nat.max_comm.
+Definition max_l := Nat.max_l.
+Definition max_r := Nat.max_r.
+Definition le_max_l := Nat.le_max_l.
+Definition le_max_r := Nat.le_max_r.
+Definition max_lub_l := Nat.max_lub_l.
+Definition max_lub_r := Nat.max_lub_r.
+Definition max_lub := Nat.max_lub.
 
 (* begin hide *)
 (* Compatibility *)
 Notation max_case2 := max_case (only parsing).
-Notation max_SS := succ_max_distr (only parsing).
+Notation max_SS := Nat.succ_max_distr (only parsing).
 (* end hide *)
+
+Hint Resolve
+ Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith v62.
+
+Hint Resolve
+ Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith v62.
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
index 0c8b5669..bcfbe0ef 100644
--- a/theories/Arith/Min.v
+++ b/theories/Arith/Min.v
@@ -1,44 +1,42 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Min.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *)
 
-(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
-
-Require Export MinMax.
+Require Import NPeano.
 
 Open Local Scope nat_scope.
 Implicit Types m n p : nat.
 
-Notation min := MinMax.min (only parsing).
+Notation min := Peano.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.
+Definition min_0_l := Nat.min_0_l.
+Definition min_0_r := Nat.min_0_r.
+Definition succ_min_distr := Nat.succ_min_distr.
+Definition plus_min_distr_l := Nat.add_min_distr_l.
+Definition plus_min_distr_r := Nat.add_min_distr_r.
+Definition min_case_strong := Nat.min_case_strong.
+Definition min_spec := Nat.min_spec.
+Definition min_dec := Nat.min_dec.
+Definition min_case := Nat.min_case.
+Definition min_idempotent := Nat.min_id.
+Definition min_assoc := Nat.min_assoc.
+Definition min_comm := Nat.min_comm.
+Definition min_l := Nat.min_l.
+Definition min_r := Nat.min_r.
+Definition le_min_l := Nat.le_min_l.
+Definition le_min_r := Nat.le_min_r.
+Definition min_glb_l := Nat.min_glb_l.
+Definition min_glb_r := Nat.min_glb_r.
+Definition min_glb := Nat.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
+Notation min_SS := Nat.succ_min_distr (only parsing).
+(* end hide *)
diff --git a/theories/Arith/MinMax.v b/theories/Arith/MinMax.v
deleted file mode 100644
index 8a23c8f6..00000000
--- a/theories/Arith/MinMax.v
+++ /dev/null
@@ -1,113 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 1b36f236..ed215f54 100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Minus.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as:
 <<
 Fixpoint minus (n m:nat) : nat :=
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index 5dd61d67..479138a9 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Mult.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Plus.
 Require Export Minus.
 Require Export Lt.
@@ -177,19 +175,22 @@ Qed.
 Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
 Proof.
   induction n; intros; simpl in *.
-    rewrite <- 2! plus_n_O; assumption.
+    rewrite <- 2 plus_n_O; assumption.
     auto using plus_lt_compat.
 Qed.
 
 Hint Resolve mult_S_lt_compat_l: arith.
 
+Lemma mult_lt_compat_l : forall n m p, n < m -> 0 < p -> p * n < p * m.
+Proof.
+ intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp).
+ now apply mult_S_lt_compat_l.
+Qed.
+
 Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p.
 Proof.
-  intros m n p H H0.
-  induction p.
-  elim (lt_irrefl _ H0).
-  rewrite mult_comm.
-  replace (n * S p) with (S p * n); auto with arith.
+  intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp).
+  rewrite (mult_comm m), (mult_comm n). now apply mult_S_lt_compat_l.
 Qed.
 
 Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
diff --git a/theories/Arith/NatOrderedType.v b/theories/Arith/NatOrderedType.v
deleted file mode 100644
index fb4bf233..00000000
--- a/theories/Arith/NatOrderedType.v
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 5cceab8b..6eb667c1 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -1,15 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Decidable.
-
+Require Eqdep_dec.
+Require Import Le Lt.
 Open Local Scope nat_scope.
 
 Implicit Types m n x y : nat.
@@ -32,3 +31,22 @@ Hint Resolve O_or_S eq_nat_dec: arith.
 Theorem dec_eq_nat : forall n m, decidable (n = m).
   intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith.
 Defined.
+
+Definition UIP_nat:= Eqdep_dec.UIP_dec eq_nat_dec.
+
+Lemma le_unique: forall m n (h1 h2: m <= n), h1 = h2.
+Proof.
+fix 3.
+refine (fun m _ h1 => match h1 as h' in _ <= k return forall hh: m <= k, h' = hh
+  with le_n => _ |le_S i H => _ end).
+refine (fun hh => match hh as h' in _ <= k return forall eq: m = k, 
+  le_n m = match eq in _ = p return m <= p -> m <= m with |eq_refl => fun bli => bli end h' with
+    |le_n => fun eq => _ |le_S j H' => fun eq => _ end eq_refl).
+rewrite (UIP_nat _ _ eq eq_refl). reflexivity.
+subst m. destruct (Lt.lt_irrefl j H').
+refine (fun hh => match hh as h' in _ <= k return match k as k' return m <= k' -> Prop
+  with |0 => fun _ => True |S i' => fun h'' => forall H':m <= i', le_S m i' H' = h'' end h'
+    with |le_n => _ |le_S j H2 => fun H' => _ end H).
+destruct m. exact I. intros; destruct (Lt.lt_irrefl m H').
+f_equal. apply le_unique.
+Qed.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index 12f12300..02975d8f 100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -1,13 +1,11 @@
-(************************************************************************)
+ (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Plus.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Properties of addition. [add] is defined in [Init/Peano.v] as:
 <<
 Fixpoint plus (n m:nat) : nat :=
@@ -26,17 +24,10 @@ Open Local Scope nat_scope.
 
 Implicit Types m n p q : nat.
 
-(** * Zero is neutral *)
-
-Lemma plus_0_l : forall n, 0 + n = n.
-Proof.
-  reflexivity.
-Qed.
-
-Lemma plus_0_r : forall n, n + 0 = n.
-Proof.
-  intro; symmetry  in |- *; apply plus_n_O.
-Qed.
+(** * Zero is neutral 
+Deprecated : Already in Init/Peano.v *)
+Notation plus_0_l := plus_O_n (only parsing).
+Definition plus_0_r n := eq_sym (plus_n_O n).
 
 (** * Commutativity *)
 
@@ -49,14 +40,8 @@ Hint Immediate plus_comm: arith v62.
 
 (** * Associativity *)
 
-Lemma plus_Snm_nSm : forall n m, S n + m = n + S m.
-Proof.
-  intros.
-  simpl in |- *.
-  rewrite (plus_comm n m).
-  rewrite (plus_comm n (S m)).
-  trivial with arith.
-Qed.
+Definition plus_Snm_nSm : forall n m, S n + m = n + S m:=
+ plus_n_Sm.
 
 Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p.
 Proof.
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index 23419531..b4468dd1 100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_nat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Well-founded relations and natural numbers *)
 
 Require Import Lt.
@@ -260,19 +258,6 @@ Qed.
 
 Unset Implicit Arguments.
 
-(** [n]th iteration of the function [f] *)
-
-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)
-  end.
-
-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.
-  simple induction n;
-    [ simpl in |- *; auto with arith
-      | intros; simpl in |- *; apply f_equal with (f := f); apply H ].
-Qed.
+Notation iter_nat := @nat_iter (only parsing).
+Notation iter_nat_plus := @nat_iter_plus (only parsing).
+Notation iter_nat_invariant := @nat_iter_invariant (only parsing).
diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget
index c3f29d21..0b6564e1 100644
--- a/theories/Arith/vo.itarget
+++ b/theories/Arith/vo.itarget
@@ -19,5 +19,3 @@ 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 9509d9fd..d5d11cea 100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bool.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** The type [bool] is defined in the prelude as
     [Inductive bool : Set := true : bool | false : bool] *)
 
@@ -259,6 +257,11 @@ Proof.
   intros. apply orb_false_iff; trivial.
 Qed.
 
+Lemma orb_diag : forall b, b || b = b.
+Proof.
+ destr_bool.
+Qed.
+
 (** [true] is a zero for [orb] *)
 
 Lemma orb_true_r : forall b:bool, b || true = true.
@@ -364,6 +367,11 @@ Qed.
 Notation andb_b_false := andb_false_r (only parsing).
 Notation andb_false_b := andb_false_l (only parsing).
 
+Lemma andb_diag : forall b, b && b = b.
+Proof.
+ destr_bool.
+Qed.
+
 (** [true] is neutral for [andb] *)
 
 Lemma andb_true_r : forall b:bool, b && true = b.
@@ -547,6 +555,21 @@ Proof.
   destr_bool.
 Qed.
 
+Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'.
+Proof.
+ destruct b,b'; trivial.
+Qed.
+
+Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b').
+Proof.
+ destruct b,b'; trivial.
+Qed.
+
+Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'.
+Proof.
+ destruct b,b'; trivial.
+Qed.
+
 (** Lemmas about the [b = true] embedding of [bool] to [Prop] *)
 
 Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true).
@@ -768,7 +791,7 @@ Qed.
 Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b.
 Proof.
  destr_bool; intuition.
-Qed.
+Defined.
 
 (** It would be nice to join [reflect_iff] and [iff_reflect]
     in a unique [iff] statement, but this isn't allowed since
@@ -779,7 +802,7 @@ Qed.
 Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}.
 Proof.
  destruct 1; auto.
-Qed.
+Defined.
 
 (** 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 ee82caf1..d40e56bf 100644
--- a/theories/Bool/BoolEq.v
+++ b/theories/Bool/BoolEq.v
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BoolEq.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 (* Cuihtlauac Alvarado - octobre 2000 *)
 
 (** Properties of a boolean equality   *)
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index daf3a9fb..0c218163 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -1,18 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bvector.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
 
-Require Export Bool.
-Require Export Sumbool.
-Require Import Arith.
+Require Export Bool Sumbool.
+Require Vector.
+Export Vector.VectorNotations.
+Require Import Minus.
 
 Open Local Scope nat_scope.
 
@@ -30,161 +29,6 @@ as definition, since the type inference mechanism for pattern-matching
 is sometimes weaker that the one implemented for elimination tactiques.
 *)
 
-Section VECTORS.
-
-(**
-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.
-
-Inductive vector : nat -> Type :=
-  | Vnil : vector 0
-  | Vcons : forall (a:A) (n:nat), vector n -> vector (S n).
-
-Definition Vhead (n:nat) (v:vector (S n)) :=
-  match v with
-  | Vcons a _ _ => a
-  end.
-
-Definition Vtail (n:nat) (v:vector (S n)) :=
-  match v with
-  | Vcons _ _ v => v
-  end.
-
-Definition Vlast : forall n:nat, vector (S n) -> A.
-Proof.
-  induction n as [| n f]; intro v.
-  inversion v.
-  exact a.
-
-  inversion v as [| n0 a H0 H1].
-  exact (f H0).
-Defined.
-
-Fixpoint Vconst (a:A) (n:nat) :=
-  match n return vector n with
-  | O => Vnil
-  | S n => Vcons a _ (Vconst a n)
-  end.
-
-(** Shifting and truncating *)
-
-Lemma Vshiftout : forall n:nat, vector (S n) -> vector n.
-Proof.
-  induction n as [| n f]; intro v.
-  exact Vnil.
-
-  inversion v as [| a n0 H0 H1].
-  exact (Vcons a n (f H0)).
-Defined.
-
-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.
-
-Lemma Vshiftrepeat : forall n:nat, vector (S n) -> vector (S (S n)).
-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.
-
-Lemma Vtrunc : forall n p:nat, n > p -> vector n -> vector (n - p).
-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 *.
-  exact v.
-  auto with *.
-Defined.
-
-(** Concatenation of two vectors *)
-
-Fixpoint Vextend n p (v:vector n) (w:vector p) : vector (n+p) :=
-  match v with
-  | Vnil => w
-  | Vcons a n' v' => Vcons a (n'+p) (Vextend n' p v' w)
-  end.
-
-(** Uniform application on the arguments of the vector *)
-
-Variable f : A -> A.
-
-Fixpoint Vunary n (v:vector n) : vector n :=
-  match v with
-  | Vnil => Vnil
-  | Vcons a n' v' => Vcons (f a) n' (Vunary n' v')
-  end.
-
-Variable g : A -> A -> A.
-
-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.
-
-(** Eta-expansion of a vector *)
-
-Definition Vid n : vector n -> vector n :=
-  match n with
-  | O => fun _ => Vnil
-  | _ => fun v => Vcons (Vhead _ v) _ (Vtail _ v)
-  end.
-
-Lemma Vid_eq : forall (n:nat) (v:vector n), v = Vid n v.
-Proof.
-  destruct v; auto.
-Qed.
-
-Lemma VSn_eq :
-  forall (n : nat) (v : vector (S n)), v = Vcons (Vhead _ v) _ (Vtail _ v).
-Proof.
-  intros.
-  exact (Vid_eq _ v).
-Qed.
-
-Lemma V0_eq : forall (v : vector 0), v = Vnil.
-Proof.
-  intros.
-  exact (Vid_eq _ v).
-Qed.
-
-End VECTORS.
-
-(* suppressed: incompatible with Coq-Art book
-Implicit Arguments Vnil [A].
-Implicit Arguments Vcons [A n].
-*)
-
 Section BOOLEAN_VECTORS.
 
 (**
@@ -200,38 +44,38 @@ NOTA BENE: all shift operations expect predecessor of size as parameter
 (they only work on non-empty vectors).
 *)
 
-Definition Bvector := vector bool.
+Definition Bvector := Vector.t bool.
 
-Definition Bnil := @Vnil bool.
+Definition Bnil := @Vector.nil bool.
 
-Definition Bcons := @Vcons bool.
+Definition Bcons := @Vector.cons bool.
 
-Definition Bvect_true := Vconst bool true.
+Definition Bvect_true := Vector.const true.
 
-Definition Bvect_false := Vconst bool false.
+Definition Bvect_false := Vector.const false.
 
-Definition Blow := Vhead bool.
+Definition Blow := @Vector.hd bool.
 
-Definition Bhigh := Vtail bool.
+Definition Bhigh := @Vector.tl bool.
 
-Definition Bsign := Vlast bool.
+Definition Bsign := @Vector.last bool.
 
-Definition Bneg := Vunary bool negb.
+Definition Bneg n (v : Bvector n) := Vector.map negb v.
 
-Definition BVand := Vbinary bool andb.
+Definition BVand n (v : Bvector n) := Vector.map2 andb v.
 
-Definition BVor := Vbinary bool orb.
+Definition BVor n (v : Bvector n) := Vector.map2 orb v.
 
-Definition BVxor := Vbinary bool xorb.
+Definition BVxor n (v : Bvector n) := Vector.map2 xorb v.
 
 Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) :=
-  Bcons carry n (Vshiftout bool n bv).
+  Bcons carry n (Vector.shiftout bv).
 
 Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) :=
-  Bhigh (S n) (Vshiftin bool (S n) carry bv).
+  Bhigh (S n) (Vector.shiftin carry bv).
 
 Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
-  Bhigh (S n) (Vshiftrepeat bool n bv).
+  Bhigh (S n) (Vector.shiftrepeat bv).
 
 Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
   match p with
@@ -252,3 +96,4 @@ Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
   end.
 
 End BOOLEAN_VECTORS.
+
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index e49d1f97..3f03d2c1 100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: DecBool.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index 9cca05d4..6872eaea 100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: IfProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Bool.
 
 Inductive IfProp (A B:Prop) : bool -> Prop :=
@@ -47,4 +45,4 @@ Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}.
 destruct b; intro H.
 left; inversion H; auto with bool.
 right; inversion H; auto with bool.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
index 5b1822be..24b6a776 100644
--- a/theories/Bool/Sumbool.v
+++ b/theories/Bool/Sumbool.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sumbool.v 14641 2011-11-06 11:59:10Z herbelin $ 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
    disjunction "A or B", where A and B are logical propositions.
@@ -68,4 +66,4 @@ Definition bool_of_sumbool :
   intros A B H.
   elim H; intro; [exists true | exists false]; assumption.
 Defined.
-Implicit Arguments bool_of_sumbool.
\ No newline at end of file
+Arguments bool_of_sumbool : default implicits.
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
index e67ba677..bac4c0d6 100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zerob.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Arith.
 Require Import Bool.
 
@@ -39,4 +37,4 @@ Hint Resolve zerob_false_intro: bool.
 Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0.
 Proof.
   destruct n; [ inversion 1 | auto with bool ].
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v
index ea1543e3..719a9a84 100644
--- a/theories/Classes/EquivDec.v
+++ b/theories/Classes/EquivDec.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,8 +12,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: EquivDec.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Export notations. *)
 
 Require Export Coq.Classes.Equivalence.
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index e562328d..d9e9fe25 100644
--- a/theories/Classes/Equivalence.v
+++ b/theories/Classes/Equivalence.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,8 +12,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: Equivalence.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 
diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v
index eea16129..a001f2e9 100644
--- a/theories/Classes/Init.v
+++ b/theories/Classes/Init.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,8 +13,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: Init.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Hints for the proof search: these combinators should be considered rigid. *)
 
 Require Import Coq.Program.Basics.
@@ -36,4 +34,4 @@ Ltac unconvertible :=
     | |- _ => exact tt
   end.
 
-Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances.
\ No newline at end of file
+Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances.
diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index ea869a66..8e491b1b 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,8 +13,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: Morphisms.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 Require Import Coq.Relations.Relation_Definitions.
@@ -23,12 +21,6 @@ Require Export Coq.Classes.RelationClasses.
 Generalizable All Variables.
 Local Obligation Tactic := simpl_relation.
 
-Local Notation "'λ'  x .. y , t" := (fun x => .. (fun y => t) ..)
-  (at level 200, x binder, y binder, right associativity).
-
-Local Notation "'Π'  x .. y , P" := (forall x, .. (forall y, P) ..)
-  (at level 200, x binder, y binder, right associativity) : type_scope.
-
 (** * Morphisms.
 
    We now turn to the definition of [Proper] and declare standard instances.
@@ -63,8 +55,8 @@ Definition respectful {A B : Type}
 
 Delimit Scope signature_scope with signature.
 
-Arguments Scope Proper [type_scope signature_scope].
-Arguments Scope respectful [type_scope type_scope signature_scope signature_scope].
+Arguments Proper {A}%type R%signature m.
+Arguments respectful {A B}%type (R R')%signature _ _.
 
 Module ProperNotations.
 
@@ -83,17 +75,58 @@ Export ProperNotations.
 
 Open Local Scope signature_scope.
 
+(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f]
+    by repeated introductions and setoid rewrites. It should work
+    fine when [f] is a combination of already known morphisms and
+    quantifiers. *)
+
+Ltac solve_respectful t :=
+ match goal with
+   | |- respectful _ _ _ _ =>
+     let H := fresh "H" in
+     intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t)
+   | _ => t; reflexivity
+ end.
+
+Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac).
+
+(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences.
+    For example, if we know that [f] is a morphism for [E1==>E2==>E],
+    then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv]
+    into the subgoals [E1 x x'] and [E2 y y'].
+*)
+
+Ltac f_equiv :=
+ match goal with
+  | |- ?R (?f ?x) (?f' _) =>
+    let T := type of x in
+    let Rx := fresh "R" in
+    evar (Rx : relation T);
+    let H := fresh in
+    assert (H : (Rx==>R)%signature f f');
+    unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ]
+  | |- ?R ?f ?f' =>
+    try reflexivity;
+    change (Proper R f); eauto with typeclass_instances; fail
+  | _ => idtac
+ end.
+
+(** [forall_def] reifies the dependent product as a definition. *)
+
+Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x.
+
 (** Dependent pointwise lifting of a relation on the range. *)
 
-Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) :=
-  λ f g, Π a : A, sig a (f a) (g a).
+Definition forall_relation {A : Type} {B : A -> Type}
+ (sig : forall a, relation (B a)) : relation (forall x, B x) :=
+ fun f g => forall a, sig a (f a) (g a).
 
-Arguments Scope forall_relation [type_scope type_scope signature_scope].
+Arguments forall_relation {A B}%type sig%signature _ _.
 
 (** Non-dependent pointwise lifting *)
 
 Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) :=
-  Eval compute in forall_relation (B:=λ _, B) (λ _, R).
+  Eval compute in forall_relation (B:=fun _ => B) (fun _ => R).
 
 Lemma pointwise_pointwise A B (R : relation B) :
   relation_equivalence (pointwise_relation A R) (@eq A ==> R).
@@ -192,28 +225,34 @@ Hint Extern 4 (subrelation (inverse _) _) =>
 
 (** The complement of a relation conserves its proper elements. *)
 
-Program Instance complement_proper
+Program Definition complement_proper
   `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
-  Proper (RA ==> RA ==> iff) (complement R).
+  Proper (RA ==> RA ==> iff) (complement R) := _.
 
-  Next Obligation.
+ Next Obligation.
   Proof.
     unfold complement.
     pose (mR x y H x0 y0 H0).
     intuition.
   Qed.
+ 
+Hint Extern 1 (Proper _ (complement _)) => 
+  apply @complement_proper : typeclass_instances.
 
 (** The [inverse] too, actually the [flip] instance is a bit more general. *)
 
-Program Instance flip_proper
+Program Definition flip_proper
   `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
-  Proper (RB ==> RA ==> RC) (flip f).
+  Proper (RB ==> RA ==> RC) (flip f) := _.
 
   Next Obligation.
   Proof.
     apply mor ; auto.
   Qed.
 
+Hint Extern 1 (Proper _ (flip _)) => 
+  apply @flip_proper : typeclass_instances.
+
 (** Every Transitive relation gives rise to a binary morphism on [impl],
    contravariant in the first argument, covariant in the second. *)
 
@@ -369,41 +408,45 @@ Class PartialApplication.
 CoInductive normalization_done : Prop := did_normalization.
 
 Ltac partial_application_tactic :=
-  let rec do_partial_apps H m :=
+  let rec do_partial_apps H m cont := 
     match m with
-      | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H]
-      | _ => idtac
+      | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; 
+        [(do_partial_apps H m' ltac:idtac)|clear H]
+      | _ => cont
     end
   in
-  let rec do_partial H ar m :=
+  let rec do_partial H ar m := 
     match ar with
-      | 0 => do_partial_apps H m
+      | 0%nat => do_partial_apps H m ltac:(fail 1)
       | S ?n' =>
         match m with
           ?m' ?x => do_partial H n' m'
         end
     end
   in
-  let on_morphism m :=
-    let m' := fresh in head_of_constr m' m ;
-    let n := fresh in evar (n:nat) ;
-    let v := eval compute in n in clear n ;
-    let H := fresh in
-      assert(H:Params m' v) by typeclasses eauto ;
-      let v' := eval compute in v in subst m';
-      do_partial H v' m
- in
+  let params m sk fk :=
+    (let m' := fresh in head_of_constr m' m ;
+     let n := fresh in evar (n:nat) ;
+     let v := eval compute in n in clear n ;
+      let H := fresh in
+        assert(H:Params m' v) by typeclasses eauto ;
+          let v' := eval compute in v in subst m';
+            (sk H v' || fail 1))
+    || fk
+  in
+  let on_morphism m cont :=
+    params m ltac:(fun H n => do_partial H n m)
+      ltac:(cont)
+  in
   match goal with
     | [ _ : normalization_done |- _ ] => fail 1
     | [ _ : @Params _ _ _ |- _ ] => fail 1
     | [ |- @Proper ?T _ (?m ?x) ] =>
       match goal with
-        | [ _ : PartialApplication |- _ ] =>
-          class_apply @Reflexive_partial_app_morphism
-        | _ =>
-          on_morphism (m x) ||
-            (class_apply @Reflexive_partial_app_morphism ;
-              [ pose Build_PartialApplication | idtac ])
+        | [ H : PartialApplication |- _ ] =>
+          class_apply @Reflexive_partial_app_morphism; [|clear H]
+        | _ => on_morphism (m x)
+          ltac:(class_apply @Reflexive_partial_app_morphism)
       end
   end.
 
@@ -432,7 +475,7 @@ Qed.
 
 Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) :
   Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature).
-Proof. unfold Normalizes in *. intros.
+Proof. unfold Normalizes in *. intros. 
   rewrite NA, NB. firstorder.
 Qed.
 
diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v
index 5a2482d4..256bcc37 100644
--- a/theories/Classes/Morphisms_Prop.v
+++ b/theories/Classes/Morphisms_Prop.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -107,3 +107,33 @@ Program Instance all_inverse_impl_morphism {A : Type} :
     unfold pointwise_relation, all in *.
     intuition ; specialize (H x0) ; intuition.
   Qed.
+
+(** Equivalent points are simultaneously accessible or not *)
+
+Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop)
+ `(Equivalence _ E) `(Proper _ (E==>E==>iff) R) :
+ Proper (E==>iff) (Acc R).
+Proof.
+ apply proper_sym_impl_iff; auto with *.
+ intros x y EQ WF. apply Acc_intro; intros z Hz.
+ rewrite <- EQ in Hz. now apply Acc_inv with x.
+Qed.
+
+(** Equivalent relations have the same accessible points *)
+
+Instance Acc_rel_morphism {A:Type} :
+ Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A).
+Proof.
+ apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry.
+ intros R R' EQ a a' Ha WF. subst a'.
+ induction WF as [x _ WF']. constructor.
+ intros y Ryx. now apply WF', EQ.
+Qed.
+
+(** Equivalent relations are simultaneously well-founded or not *)
+
+Instance well_founded_morphism {A : Type} :
+ Proper (@relation_equivalence A ==> iff) (@well_founded A).
+Proof.
+ unfold well_founded. solve_proper.
+Qed.
diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v
index a8009f9e..7ac49eeb 100644
--- a/theories/Classes/Morphisms_Relations.v
+++ b/theories/Classes/Morphisms_Relations.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -32,11 +32,11 @@ Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==>
 
 Require Import List.
 
-Lemma predicate_equivalence_pointwise (l : list Type) :
+Lemma predicate_equivalence_pointwise (l : Tlist) :
   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) :
+Lemma predicate_implication_pointwise (l : Tlist) :
   Proper (@predicate_implication l ==> pointwise_lifting impl l) id.
 Proof. do 2 red. unfold predicate_implication. auto. Qed.
 
@@ -45,11 +45,11 @@ Proof. do 2 red. unfold predicate_implication. auto. Qed.
 
 Instance relation_equivalence_pointwise :
   Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id.
-Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed.
+Proof. intro. apply (predicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed.
 
 Instance subrelation_pointwise :
   Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id.
-Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed.
+Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed.
 
 
 Lemma inverse_pointwise_relation A (R : relation A) :
diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v
index 94c51bf1..cf05d9d4 100644
--- a/theories/Classes/RelationClasses.v
+++ b/theories/Classes/RelationClasses.v
@@ -1,13 +1,13 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** *  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.
 
@@ -15,8 +15,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: RelationClasses.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Coq.Classes.Init.
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
@@ -143,9 +141,9 @@ Program Instance impl_Transitive : Transitive impl.
 
 (** Logical equivalence. *)
 
-Program Instance iff_Reflexive : Reflexive iff.
-Program Instance iff_Symmetric : Symmetric iff.
-Program Instance iff_Transitive : Transitive iff.
+Instance iff_Reflexive : Reflexive iff := iff_refl.
+Instance iff_Symmetric : Symmetric iff := iff_sym.
+Instance iff_Transitive : Transitive iff := iff_trans.
 
 (** Leibniz equality. *)
 
@@ -158,14 +156,14 @@ Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A.
 (** A [PreOrder] is both Reflexive and Transitive. *)
 
 Class PreOrder {A} (R : relation A) : Prop := {
-  PreOrder_Reflexive :> Reflexive R ;
-  PreOrder_Transitive :> Transitive R }.
+  PreOrder_Reflexive :> Reflexive R | 2 ;
+  PreOrder_Transitive :> Transitive R | 2 }.
 
 (** A partial equivalence relation is Symmetric and Transitive. *)
 
 Class PER {A} (R : relation A) : Prop := {
-  PER_Symmetric :> Symmetric R ;
-  PER_Transitive :> Transitive R }.
+  PER_Symmetric :> Symmetric R | 3 ;
+  PER_Transitive :> Transitive R | 3 }.
 
 (** Equivalence relations. *)
 
@@ -210,17 +208,21 @@ Local Open Scope list_scope.
 
 (** A compact representation of non-dependent arities, with the codomain singled-out. *)
 
-Fixpoint arrows (l : list Type) (r : Type) : Type :=
+(* Note, we do not use [list Type] because it imposes unnecessary universe constraints *)
+Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist.
+Local Infix "::" := Tcons.
+
+Fixpoint arrows (l : Tlist) (r : Type) : Type :=
   match l with
-    | nil => r
+    | Tnil => 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 (A::nil) A.
-Definition binary_operation A := arrows (A::A::nil) A.
-Definition ternary_operation A := arrows (A::A::A::nil) A.
+Definition unary_operation A := arrows (A::Tnil) A.
+Definition binary_operation A := arrows (A::A::Tnil) A.
+Definition ternary_operation A := arrows (A::A::A::Tnil) A.
 
 (** We define n-ary [predicate]s as functions into [Prop]. *)
 
@@ -228,23 +230,23 @@ Notation predicate l := (arrows l Prop).
 
 (** Unary predicates, or sets. *)
 
-Definition unary_predicate A := predicate (A::nil).
+Definition unary_predicate A := predicate (A::Tnil).
 
 (** Homogeneous binary relations, equivalent to [relation A]. *)
 
-Definition binary_relation A := predicate (A::A::nil).
+Definition binary_relation A := predicate (A::A::Tnil).
 
 (** We can close a predicate by universal or existential quantification. *)
 
-Fixpoint predicate_all (l : list Type) : predicate l -> Prop :=
+Fixpoint predicate_all (l : Tlist) : predicate l -> Prop :=
   match l with
-    | nil => fun f => f
+    | Tnil => fun f => f
     | A :: tl => fun f => forall x : A, predicate_all tl (f x)
   end.
 
-Fixpoint predicate_exists (l : list Type) : predicate l -> Prop :=
+Fixpoint predicate_exists (l : Tlist) : predicate l -> Prop :=
   match l with
-    | nil => fun f => f
+    | Tnil => fun f => f
     | A :: tl => fun f => exists x : A, predicate_exists tl (f x)
   end.
 
@@ -253,30 +255,30 @@ Fixpoint predicate_exists (l : list Type) : predicate l -> Prop :=
    For an operator on [Prop] this lifts the operator to a binary operation. *)
 
 Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
-  (l : list Type) : binary_operation (arrows l T) :=
+  (l : Tlist) : binary_operation (arrows l T) :=
   match l with
-    | nil => fun R R' => op R R'
+    | Tnil => fun R R' => op R R'
     | A :: tl => fun R R' =>
       fun x => pointwise_extension op tl (R x) (R' x)
   end.
 
 (** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *)
 
-Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : list Type) : binary_relation (predicate l) :=
+Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : Tlist) : binary_relation (predicate l) :=
   match l with
-    | nil => fun R R' => op R R'
+    | Tnil => fun R R' => op R R'
     | A :: tl => fun R R' =>
       forall x, pointwise_lifting op tl (R x) (R' x)
   end.
 
 (** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *)
 
-Definition predicate_equivalence {l : list Type} : binary_relation (predicate l) :=
+Definition predicate_equivalence {l : Tlist} : binary_relation (predicate l) :=
   pointwise_lifting iff l.
 
 (** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *)
 
-Definition predicate_implication {l : list Type} :=
+Definition predicate_implication {l : Tlist} :=
   pointwise_lifting impl l.
 
 (** Notations for pointwise equivalence and implication of predicates. *)
@@ -297,15 +299,15 @@ 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 : Tlist} : predicate l :=
   match l with
-    | nil => True
+    | Tnil => True
     | A :: tl => fun _ => @true_predicate tl
   end.
 
-Fixpoint false_predicate {l : list Type} : predicate l :=
+Fixpoint false_predicate {l : Tlist} : predicate l :=
   match l with
-    | nil => False
+    | Tnil => False
     | A :: tl => fun _ => @false_predicate tl
   end.
 
@@ -315,6 +317,7 @@ 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).
+
   Next Obligation.
     induction l ; firstorder.
   Qed.
@@ -343,18 +346,18 @@ Program Instance predicate_implication_preorder :
    from the general ones. *)
 
 Definition relation_equivalence {A : Type} : relation (relation A) :=
-  @predicate_equivalence (_::_::nil).
+  @predicate_equivalence (_::_::Tnil).
 
 Class subrelation {A:Type} (R R' : relation A) : Prop :=
-  is_subrelation : @predicate_implication (A::A::nil) R R'.
+  is_subrelation : @predicate_implication (A::A::Tnil) R R'.
 
-Implicit Arguments subrelation [[A]].
+Arguments subrelation {A} R R'.
 
 Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_intersection (A::A::nil) R R'.
+  @predicate_intersection (A::A::Tnil) R R'.
 
 Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_union (A::A::nil) R R'.
+  @predicate_union (A::A::Tnil) R R'.
 
 (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)
 
@@ -362,10 +365,10 @@ Set Automatic Introduction.
 
 Instance relation_equivalence_equivalence (A : Type) :
   Equivalence (@relation_equivalence A).
-Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed.
+Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed.
 
 Instance relation_implication_preorder A : PreOrder (@subrelation A).
-Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed.
+Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed.
 
 (** *** Partial Order.
    A partial order is a preorder which is additionally antisymmetric.
@@ -393,7 +396,7 @@ Program Instance subrelation_partial_order :
 
   Next Obligation.
   Proof.
-    unfold relation_equivalence in *. firstorder.
+    unfold relation_equivalence in *. compute; firstorder.
   Qed.
 
 Typeclasses Opaque arrows predicate_implication predicate_equivalence
@@ -420,7 +423,7 @@ Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA
 
 (** Strict Order *)
 
-Class StrictOrder {A : Type} (R : relation A) := {
+Class StrictOrder {A : Type} (R : relation A) : Prop := {
   StrictOrder_Irreflexive :> Irreflexive R ;
   StrictOrder_Transitive :> Transitive R
 }.
diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v
index 7972c96c..2b010206 100644
--- a/theories/Classes/RelationPairs.v
+++ b/theories/Classes/RelationPairs.v
@@ -15,27 +15,25 @@ Require Import Relations Morphisms.
     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]].
+Arguments fst {A B}.
+Arguments snd {A B}.
+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].
+Arguments relation_conjunction A%type (R R')%signature _ _.
+Arguments relation_equivalence A%type (_ _)%signature.
+Arguments subrelation A%type (R R')%signature.
+Arguments Reflexive A%type R%signature.
+Arguments Irreflexive A%type R%signature.
+Arguments Symmetric A%type R%signature.
+Arguments Transitive A%type R%signature.
+Arguments PER A%type R%signature.
+Arguments Equivalence A%type R%signature.
+Arguments StrictOrder A%type R%signature.
 
 Generalizable Variables A B RA RB Ri Ro f.
 
@@ -88,10 +86,10 @@ Section RelCompFun_Instances.
     `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f).
   Proof. firstorder. Qed.
 
-  Global Instance RelCompFun_Equivalence
+  Global Program Instance RelCompFun_Equivalence
     `(Measure A B f, Equivalence _ R) : Equivalence (R@@f).
 
-  Global Instance RelCompFun_StrictOrder
+  Global Program Instance RelCompFun_StrictOrder
     `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f).
 
 End RelCompFun_Instances.
@@ -108,7 +106,7 @@ 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)
+Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B)
  `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).
 
 Lemma FstRel_ProdRel {A B}(RA:relation A) :
diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v
index e9da6874..591671d9 100644
--- a/theories/Classes/SetoidClass.v
+++ b/theories/Classes/SetoidClass.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,8 +12,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: SetoidClass.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Set Implicit Arguments.
 Unset Strict Implicit.
 
@@ -71,7 +69,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 :=
-  match type of H with
+  lazymatch type of H with
     ?x == ?y => substitute H ; clear H x
   end.
 
diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v
index 4f70b244..6708220e 100644
--- a/theories/Classes/SetoidDec.v
+++ b/theories/Classes/SetoidDec.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,16 +13,11 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: SetoidDec.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Set Implicit Arguments.
 Unset Strict Implicit.
 
 Generalizable Variables A B .
 
-Local Notation "'λ'  x .. y , t" := (fun x => .. (fun y => t) ..)
-  (at level 200, x binder, y binder, right associativity).
-
 (** Export notations. *)
 
 Require Export Coq.Classes.SetoidClass.
@@ -95,7 +90,7 @@ Program Instance bool_eqdec : EqDec (eq_setoid bool) :=
   bool_dec.
 
 Program Instance unit_eqdec : EqDec (eq_setoid unit) :=
-  λ x y, in_left.
+  fun x y => in_left.
 
   Next Obligation.
   Proof.
@@ -103,8 +98,9 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) :=
     reflexivity.
   Qed.
 
-Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) :=
-  λ x y,
+Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B))
+ : EqDec (eq_setoid (prod A B)) :=
+  fun x y =>
     let '(x1, x2) := x in
     let '(y1, y2) := y in
     if x1 == y1 then
@@ -117,8 +113,9 @@ Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : Eq
 (** 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,
+Program Instance bool_function_eqdec `(! EqDec (eq_setoid A))
+ : EqDec (eq_setoid (bool -> A)) :=
+  fun f g =>
     if f true == g true then
       if f false == g false then in_left
       else in_right
diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v
index a1a0c969..31a4f5f2 100644
--- a/theories/Classes/SetoidTactics.v
+++ b/theories/Classes/SetoidTactics.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,8 +12,6 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
-(* $Id: SetoidTactics.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop.
 Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions.
 Require Import Coq.Classes.Equivalence Coq.Program.Basics.
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index 49f595d7..c761e2a7 100644
--- a/theories/FSets/FMapAVL.v
+++ b/theories/FSets/FMapAVL.v
@@ -8,8 +8,6 @@
 
 (* Finite map library.  *)
 
-(* $Id: FMapAVL.v 13768 2011-01-06 13:55:35Z glondu $ *)
-
 (** * FMapAVL *)
 
 (** This module implements maps using AVL trees.
@@ -39,6 +37,7 @@ Open Local Scope lazy_bool_scope.
 Open Local Scope Int_scope.
 
 Definition key := X.t.
+Hint Transparent key.
 
 (** * Trees *)
 
@@ -542,12 +541,12 @@ Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo).
 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)) as [GT|LE];
        [ match goal with |- context [ 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));
+       | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
          [ 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]
@@ -823,7 +822,7 @@ 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;
- (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
+ (eapply lt_tree_trans || eapply gt_tree_trans); eauto. 
 Qed.
 Hint Resolve bal_bst.
 
@@ -1113,7 +1112,7 @@ 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;
- clear Hrl Hlr z; intro; intros; rewrite join_in in *.
+ clear Hrl Hlr; intro; intros; rewrite join_in in *.
  intuition; [ apply MX.lt_eq with x | ]; eauto.
  intuition; [ apply MX.eq_lt with x | ]; eauto.
 Qed.
@@ -1333,7 +1332,7 @@ Proof.
  inversion_clear H.
  destruct H7; simpl in *.
  order.
- destruct (elements_aux_mapsto r acc x e0); intuition eauto.
+ destruct (elements_aux_mapsto r acc x e0); intuition eauto. 
 Qed.
 
 Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s).
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
index 8944f7ce..0c1448c9 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapFacts.v 12459 2009-11-02 18:51:43Z letouzey $ *)
-
 (** * Finite maps library *)
 
 (** This functor derives additional facts from [FMapInterface.S]. These
@@ -259,7 +257,7 @@ Qed.
 
 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.
+ exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m.
 Proof.
 intros; case_eq (find x m); intros.
 exists e.
@@ -654,7 +652,7 @@ Add Relation key E.eq
  transitivity proved by E.eq_trans
  as KeySetoid.
 
-Implicit Arguments Equal [[elt]].
+Arguments Equal {elt} m m'.
 
 Add Parametric Relation (elt : Type) : (t elt) Equal
  reflexivity proved by (@Equal_refl elt)
@@ -740,7 +738,7 @@ End WFacts_fun.
 
 (** * Same facts for self-contained weak sets and for full maps *)
 
-Module WFacts (M:S) := WFacts_fun M.E M.
+Module WFacts (M:WS) := WFacts_fun M.E M.
 Module Facts := WFacts.
 
 (** * Additional Properties for weak maps
@@ -761,8 +759,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Notation eqk := (@eq_key elt).
 
   Instance eqk_equiv : Equivalence eqk.
-  Proof. split; repeat red; eauto. Qed.
-
+  Proof. unfold eq_key; split; eauto. Qed.
+  
   Instance eqke_equiv : Equivalence eqke.
   Proof.
    unfold eq_key_elt; split; repeat red; firstorder.
@@ -834,8 +832,11 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   (** * Conversions between maps and association lists. *)
 
+  Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W :=
+   fun p => f (fst p) (snd p).
+
   Definition of_list (l : list (key*elt)) :=
-    List.fold_right (fun p => add (fst p) (snd p)) (empty _) l.
+    List.fold_right (uncurry (@add _)) (empty _) l.
 
   Definition to_list := elements.
 
@@ -845,6 +846,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Proof.
   induction l as [|(k',e') l IH]; simpl; intros k e Hnodup.
   rewrite empty_mapsto_iff, InA_nil; intuition.
+  unfold uncurry; simpl.
   inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
   specialize (IH k e Hnodup'); clear Hnodup'.
   rewrite add_mapsto_iff, InA_cons, <- IH.
@@ -861,6 +863,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Proof.
   induction l as [|(k',e') l IH]; simpl; intros k Hnodup.
   apply empty_o.
+  unfold uncurry; simpl.
   inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
   specialize (IH k Hnodup'); clear Hnodup'.
   rewrite add_o, IH.
@@ -883,6 +886,14 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   (** * Fold *)
 
+  (** Alternative specification via [fold_right] *)
+
+  Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) :
+    fold f m i = List.fold_right (uncurry f) i (rev (elements m)).
+  Proof.
+   rewrite fold_1. symmetry. apply fold_left_rev_right.
+  Qed.
+
   (** ** Induction principles about fold contributed by S. Lescuyer *)
 
   (** In the following lemma, the step hypothesis is deliberately restricted
@@ -897,8 +908,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
       P m (fold f m i).
   Proof.
   intros A P f i m Hempty Hstep.
-  rewrite fold_1, <- fold_left_rev_right.
-  set (F:=fun (y : key * elt) (x : A) => f (fst y) (snd y) x).
+  rewrite fold_spec_right.
+  set (F:=uncurry f).
   set (l:=rev (elements m)).
   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)).
@@ -983,8 +994,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
      R (fold f m i) (fold g m j).
   Proof.
   intros A B R f g i j m Rempty Rstep.
-  do 2 rewrite fold_1, <- fold_left_rev_right.
-  set (l:=rev (elements m)).
+  rewrite 2 fold_spec_right. 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 with *).
@@ -1099,14 +1109,15 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 ->
    eqA (fold f m1 i) (fold f m2 i).
   Proof.
-  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  intros.
+  rewrite 2 fold_spec_right.
   assert (NoDupA eqk (rev (elements m1))) by (auto with *).
   assert (NoDupA eqk (rev (elements m2))) by (auto with *).
   apply fold_right_equivlistA_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.
+  intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto.
   rewrite <- NoDupA_altdef; auto.
   intros (k,e).
   rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H;
@@ -1116,8 +1127,9 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   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.
-  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 *.
+  intros.
+  rewrite 2 fold_spec_right.
+  set (f':=uncurry f).
   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 *).
@@ -1126,7 +1138,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
    (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.
+  unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto.
   rewrite <- NoDupA_altdef; auto.
   rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder.
   intros (a,b).
@@ -2130,8 +2142,7 @@ Module OrdProperties (M:S).
    eqA (fold f m1 i) (fold f m2 i).
   Proof.
   intros m1 m2 A eqA st f i Hf Heq.
-  do 2 rewrite fold_1.
-  do 2 rewrite <- fold_left_rev_right.
+  rewrite 2 fold_spec_right.
   apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
   intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto.
   apply eqlistA_rev. apply elements_Equal_eqlistA. auto.
@@ -2142,8 +2153,7 @@ Module OrdProperties (M:S).
    Above x m1 -> Add x e m1 m2 ->
    eqA (fold f m2 i) (f x e (fold f m1 i)).
   Proof.
-  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 *.
+  intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
   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) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto.
@@ -2158,8 +2168,7 @@ Module OrdProperties (M:S).
    Below x m1 -> Add x e m1 m2 ->
    eqA (fold f m2 i) (fold f m1 (f x e i)).
   Proof.
-  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 *.
+  intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
   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) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto.
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
index 2b9e7077..774bcd9b 100644
--- a/theories/FSets/FMapFullAVL.v
+++ b/theories/FSets/FMapFullAVL.v
@@ -8,8 +8,6 @@
 
 (* Finite map library.  *)
 
-(* $Id: FMapFullAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *)
-
 (** * FMapFullAVL
 
    This file contains some complements to [FMapAVL].
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
index bbfecfb1..4d89b562 100644
--- a/theories/FSets/FMapInterface.v
+++ b/theories/FSets/FMapInterface.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *)
-
 (** * Finite map library *)
 
 (** This file proposes interfaces for finite maps *)
@@ -58,6 +56,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.
 Module Type WSfun (E : DecidableType).
 
   Definition key := E.t.
+  Hint Transparent key.
 
   Parameter t : Type -> Type.
   (** the abstract type of maps *)
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 4b7f183c..f15ab222 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapList.v 12458 2009-11-02 18:50:33Z letouzey $ *)
-
 (** * Finite map library *)
 
 (** This file proposes an implementation of the non-dependant interface
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index 30bce2db..2e2eb166 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapPositive.v 13297 2010-07-19 23:32:42Z letouzey $ *)
-
 (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)
 
 Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface.
@@ -86,7 +84,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Section A.
   Variable A:Type.
 
-  Implicit Arguments Leaf [A].
+  Arguments Leaf [A].
 
   Definition empty : t A := Leaf.
 
@@ -496,9 +494,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').
 
-  Global Instance eqk_equiv : Equivalence eq_key.
-  Global Instance eqke_equiv : Equivalence eq_key_elt.
-  Global Instance ltk_strorder : StrictOrder lt_key.
+  Global Program Instance eqk_equiv : Equivalence eq_key.
+  Global Program Instance eqke_equiv : Equivalence eq_key_elt.
+  Global Program Instance ltk_strorder : StrictOrder lt_key.
 
   Lemma mem_find :
     forall m x, mem x m = match find x m with None => false | _ => true end.
@@ -816,7 +814,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Variable A B C : Type.
   Variable f : option A -> option B -> option C.
 
-  Implicit Arguments Leaf [A].
+  Arguments Leaf [A].
 
   Fixpoint xmap2_l (m : t A) : t C :=
       match m with
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index db479ea8..6c1e8ca8 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapWeakList.v 12458 2009-11-02 18:50:33Z letouzey $ *)
-
 (** * Finite map library *)
 
 (** This file proposes an implementation of the non-dependant interface
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
index 75904202..19b25d95 100644
--- a/theories/FSets/FMaps.v
+++ b/theories/FSets/FMaps.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *)
-
 
 Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
 Require Export DecidableType DecidableTypeEx.
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
index 2cbba723..df627a14 100644
--- a/theories/FSets/FSetAVL.v
+++ b/theories/FSets/FSetAVL.v
@@ -7,8 +7,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetAVL.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
 (** * FSetAVL : Implementation of FSetInterface via AVL trees *)
 
 (** This module implements finite sets using AVL trees.
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
index c2d921be..25ce5577 100644
--- a/theories/FSets/FSetBridge.v
+++ b/theories/FSets/FSetBridge.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetBridge.v 13253 2010-07-07 08:39:30Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This module implements bridges (as functors) from dependent
diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v
index c3d614ee..6b3d86d3 100644
--- a/theories/FSets/FSetCompat.v
+++ b/theories/FSets/FSetCompat.v
@@ -264,7 +264,7 @@ Module Update_WSets
  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.
+ Instance eq_equiv : Equivalence eq := _.
 
  Section Spec.
   Variable s s': t.
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
index 7c321779..f64df9fe 100644
--- a/theories/FSets/FSetDecide.v
+++ b/theories/FSets/FSetDecide.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetDecide.v 14527 2011-10-07 14:33:38Z letouzey $ *)
-
 (**************************************************************)
 (* FSetDecide.v                                               *)
 (*                                                            *)
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index ac55aef5..755bc7dd 100644
--- a/theories/FSets/FSetEqProperties.v
+++ b/theories/FSets/FSetEqProperties.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetEqProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This module proves many properties of finite sets that
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index 45b43d83..f473b334 100644
--- a/theories/FSets/FSetFacts.v
+++ b/theories/FSets/FSetFacts.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetFacts.v 12461 2009-11-03 08:24:06Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This functor derives additional facts from [FSetInterface.S]. These
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
index f366ed3e..a0361119 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *)
-
 (** * Finite set library *)
 
 (** Set interfaces, inspired by the one of Ocaml. When compared with
@@ -253,6 +251,7 @@ Module Type WSfun (E : DecidableType).
 
   End Spec.
 
+  Hint Transparent elt.
   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
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index 9408ba05..1f36306c 100644
--- a/theories/FSets/FSetList.v
+++ b/theories/FSets/FSetList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetList.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This file proposes an implementation of the non-dependant
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index 59e19cd3..1bad8061 100644
--- a/theories/FSets/FSetProperties.v
+++ b/theories/FSets/FSetProperties.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This functor derives additional properties from [FSetInterface.S].
@@ -337,6 +335,14 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
 
   Section Fold.
 
+  (** Alternative specification via [fold_right] *)
+
+  Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) :
+    fold f s i = List.fold_right f i (rev (elements s)).
+  Proof.
+   rewrite fold_1. symmetry. apply fold_left_rev_right.
+  Qed.
+
   Notation NoDup := (NoDupA E.eq).
   Notation InA := (InA E.eq).
 
@@ -353,8 +359,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
      P s (fold f s i).
   Proof.
   intros A P f i s Pempty Pstep.
-  rewrite fold_1, <- fold_left_rev_right.
-  set (l:=rev (elements s)).
+  rewrite fold_spec_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.
@@ -426,8 +431,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
      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, <- fold_left_rev_right.
-  set (l:=rev (elements s)).
+  rewrite 2 fold_spec_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.
@@ -485,8 +489,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   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.
+  apply fold_spec_right.
   Qed.
 
   (** An alternate (and previous) specification for [fold] was based on
@@ -1088,8 +1091,7 @@ Module OrdProperties (M:S).
    Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
   Proof.
   intros.
-  do 2 rewrite M.fold_1.
-  do 2 rewrite <- fold_left_rev_right.
+  rewrite 2 fold_spec_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.
@@ -1105,11 +1107,11 @@ Module OrdProperties (M:S).
    Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
   Proof.
   intros.
-  do 2 rewrite M.fold_1.
+  rewrite 2 M.fold_1.
   set (g:=fun (a : A) (e : elt) => f e a).
   change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
   unfold g.
-  do 2 rewrite <- fold_left_rev_right.
+  rewrite <- 2 fold_left_rev_right.
   apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
   apply eqlistA_rev.
   apply elements_Add_Below; auto.
@@ -1126,8 +1128,7 @@ Module OrdProperties (M:S).
   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.
-  do 2 rewrite <- fold_left_rev_right.
+  intros. rewrite 2 fold_spec_right.
   apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
   apply eqlistA_rev.
   apply sort_equivlistA_eqlistA; auto with set.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
index 2aa1b433..3ac5d9e4 100644
--- a/theories/FSets/FSetToFiniteSet.v
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetToFiniteSet.v 12363 2009-09-28 15:04:07Z letouzey $ *)
-
 (** * Finite sets library : conversion to old [Finite_sets] *)
 
 Require Import Ensembles Finite_sets.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index b55db37a..2ea32e97 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakList.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
 (** * Finite sets library *)
 
 (** This file proposes an implementation of the non-dependant
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
index a725c1eb..572f2865 100644
--- a/theories/FSets/FSets.v
+++ b/theories/FSets/FSets.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSets.v 13297 2010-07-19 23:32:42Z letouzey $ *)
-
 Require Export OrderedType.
 Require Export OrderedTypeEx.
 Require Export OrderedTypeAlt.
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index deadec43..41f6b70b 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -1,25 +1,33 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Datatypes.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import Notations.
 Require Import Logic.
 Declare ML Module "nat_syntax_plugin".
 
+(********************************************************************)
+(** * Datatypes with zero and one element *)
+
+(** [Empty_set] is a datatype with no inhabitant *)
+
+Inductive Empty_set : Set :=.
 
 (** [unit] is a singleton datatype with sole inhabitant [tt] *)
 
 Inductive unit : Set :=
     tt : unit.
 
+
+(********************************************************************)
+(** * The boolean datatype *)
+
 (** [bool] is the datatype of the boolean values [true] and [false] *)
 
 Inductive bool : Set :=
@@ -53,9 +61,7 @@ Definition negb (b:bool) := if b then false else true.
 Infix "||" := orb : bool_scope.
 Infix "&&" := andb : bool_scope.
 
-(*******************************)
-(** * Properties of [andb]     *)
-(*******************************)
+(** Basic properties of [andb] *)
 
 Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true.
 Proof.
@@ -104,6 +110,22 @@ Proof.
   intros P b H H0; destruct H0 in H; assumption.
 Defined.
 
+(** The [BoolSpec] inductive will be used to relate a [boolean] value
+    and two propositions corresponding respectively to the [true]
+    case and the [false] case.
+    Interest: [BoolSpec] behave nicely with [case] and [destruct].
+    See also [Bool.reflect] when [Q = ~P].
+*)
+
+Inductive BoolSpec (P Q : Prop) : bool -> Prop :=
+  | BoolSpecT : P -> BoolSpec P Q true
+  | BoolSpecF : Q -> BoolSpec P Q false.
+Hint Constructors BoolSpec.
+
+
+(********************************************************************)
+(** * Peano natural numbers *)
+
 (** [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;
@@ -115,23 +137,11 @@ Inductive nat : Set :=
 
 Delimit Scope nat_scope with nat.
 Bind Scope nat_scope with nat.
-Arguments Scope S [nat_scope].
+Arguments S _%nat.
 
-(** [Empty_set] has no inhabitant *)
 
-Inductive Empty_set : Set :=.
-
-(** [identity A a] is the family of datatypes on [A] whose sole non-empty
-    member is the singleton datatype [identity A a a] whose
-    sole inhabitant is denoted [refl_identity A a] *)
-
-Inductive identity (A:Type) (a:A) : A -> Type :=
-  identity_refl : identity a a.
-Hint Resolve identity_refl: core.
-
-Implicit Arguments identity_ind [A].
-Implicit Arguments identity_rec [A].
-Implicit Arguments identity_rect [A].
+(********************************************************************)
+(** * Container datatypes *)
 
 (** [option A] is the extension of [A] with an extra element [None] *)
 
@@ -139,7 +149,7 @@ Inductive option (A:Type) : Type :=
   | Some : A -> option A
   | None : option A.
 
-Implicit Arguments None [A].
+Arguments None [A].
 
 Definition option_map (A B:Type) (f:A->B) o :=
   match o with
@@ -155,6 +165,9 @@ Inductive sum (A B:Type) : Type :=
 
 Notation "x + y" := (sum x y) : type_scope.
 
+Arguments inl {A B} _ , [A] B _.
+Arguments inr {A B} _ , A [B] _.
+
 (** [prod A B], written [A * B], is the product of [A] and [B];
     the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
 
@@ -166,6 +179,8 @@ Add Printing Let prod.
 Notation "x * y" := (prod x y) : type_scope.
 Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
 
+Arguments pair {A B} _ _.
+
 Section projections.
   Variables A B : Type.
   Definition fst (p:A * B) := match p with
@@ -200,7 +215,40 @@ Definition prod_curry (A B C:Type) (f:A -> B -> C)
                        | pair x y => f x y
                        end.
 
-(** Comparison *)
+(** Polymorphic lists and some operations *)
+
+Inductive list (A : Type) : Type :=
+ | nil : list A
+ | cons : A -> list A -> list A.
+
+Arguments nil [A].
+Infix "::" := cons (at level 60, right associativity) : list_scope.
+Delimit Scope list_scope with list.
+Bind Scope list_scope with list.
+
+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.
+
+
+(********************************************************************)
+(** * The comparison datatype *)
 
 Inductive comparison : Set :=
   | Eq : comparison
@@ -229,68 +277,68 @@ 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]. *)
+(** The [CompareSpec] inductive relates a [comparison] value with three
+   propositions, one for each possible case. Typically, it can be used to
+   specify a comparison function via some equality and order predicates.
+   Interest: [CompareSpec] 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.
+Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop :=
+ | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq
+ | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt
+ | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt.
+Hint Constructors CompareSpec.
 
-(** For having clean interfaces after extraction, [CompSpec] is declared
+(** For having clean interfaces after extraction, [CompareSpec] is declared
     in Prop. For some situations, it is nonetheless useful to have a
-    version in Type. Interestingly, these two versions are equivalent.
-*)
+    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.
+Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type :=
+ | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq
+ | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt
+ | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt.
+Hint Constructors CompareSpecT.
 
-Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
- CompSpec eq lt x y c -> CompSpecT eq lt x y c.
+Lemma CompareSpec2Type : forall Peq Plt Pgt c,
+ CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c.
 Proof.
  destruct c; intros H; constructor; inversion_clear H; auto.
 Defined.
 
-(** Identity *)
+(** As an alternate formulation, one may also directly refer to predicates
+ [eq] and [lt] for specifying a comparison, rather that fully-applied
+ propositions. This [CompSpec] is now a particular case of [CompareSpec]. *)
 
-Definition ID := forall A:Type, A -> A.
-Definition id : ID := fun A x => x.
+Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
+ CompareSpec (eq x y) (lt x y) (lt y x).
+Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
+ CompareSpecT (eq x y) (lt x y) (lt y x).
+Hint Unfold CompSpec CompSpecT.
 
-(** Polymorphic lists and some operations *)
+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. intros. apply CompareSpec2Type; assumption. Defined.
 
-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.
+(******************************************************************)
+(** * Misc Other Datatypes *)
 
-Local Open Scope list_scope.
+(** [identity A a] is the family of datatypes on [A] whose sole non-empty
+    member is the singleton datatype [identity A a a] whose
+    sole inhabitant is denoted [refl_identity A a] *)
 
-Definition length (A : Type) : list A -> nat :=
-  fix length l :=
-  match l with
-   | nil => O
-   | _ :: l' => S (length l')
-  end.
+Inductive identity (A:Type) (a:A) : A -> Type :=
+  identity_refl : identity a a.
+Hint Resolve identity_refl: core.
 
-(** Concatenation of two lists *)
+Arguments identity_ind [A] a P f y i.
+Arguments identity_rec [A] a P f y i.
+Arguments identity_rect [A] a P f y i.
 
-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.
+(** Identity type *)
+
+Definition ID := forall A:Type, A -> A.
+Definition id : ID := fun A x => x.
 
-Infix "++" := app (right associativity, at level 60) : list_scope.
 
 (* begin hide *)
 
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index b95d78a4..d1eabcab 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import Notations.
@@ -64,6 +62,9 @@ Inductive or (A B:Prop) : Prop :=
 
 where "A \/ B" := (or A B) : type_scope.
 
+Arguments or_introl [A B] _, [A] B _.
+Arguments or_intror [A B] _, A [B] _.
+
 (** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)
 
 Definition iff (A B:Prop) := (A -> B) /\ (B -> A).
@@ -95,53 +96,53 @@ Hint Unfold iff: extcore.
 
 Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
 Proof.
-intro A; unfold not; split.
-intro H; split; [exact H | intro H1; elim H1].
-intros [H _]; exact H.
+  intro A; unfold not; split.
+  - intro H; split; [exact H | intro H1; elim H1].
+  - intros [H _]; exact H.
 Qed.
 
 Theorem and_cancel_l : forall A B C : Prop,
   (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem and_cancel_r : forall A B C : Prop,
   (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_cancel_l : forall A B C : Prop,
   (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_cancel_r : forall A B C : Prop,
   (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 (** Backward direction of the equivalences above does not need assumptions *)
@@ -149,35 +150,35 @@ Qed.
 Theorem and_iff_compat_l : forall A B C : Prop,
   (B <-> C) -> (A /\ B <-> A /\ C).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem and_iff_compat_r : forall A B C : Prop,
   (B <-> C) -> (B /\ A <-> C /\ A).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_iff_compat_l : forall A B C : Prop,
   (B <-> C) -> (A \/ B <-> A \/ C).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Theorem or_iff_compat_r : forall A B C : Prop,
   (B <-> C) -> (B \/ A <-> C \/ A).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
 Proof.
-intros A B []; split; trivial.
+  intros A B []; split; trivial.
 Qed.
 
 Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
@@ -218,11 +219,9 @@ Definition all (A:Type) (P:A -> Prop) := forall x:A, P x.
 
 (* Rule order is important to give printing priority to fully typed exists *)
 
-Notation "'exists' x , p" := (ex (fun x => p))
-  (at level 200, x ident, right associativity) : type_scope.
-Notation "'exists' x : t , p" := (ex (fun x:t => p))
-  (at level 200, x ident, right associativity,
-    format "'[' 'exists'  '/  ' x  :  t ,  '/  ' p ']'")
+Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
+  (at level 200, x binder, right associativity,
+   format "'[' 'exists'  '/  ' x .. y ,  '/  ' p ']'")
   : type_scope.
 
 Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
@@ -271,11 +270,12 @@ 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] ].
+Arguments eq {A} x _.
+Arguments eq_refl {A x} , [A] x.
 
-Implicit Arguments eq_ind [A].
-Implicit Arguments eq_rec [A].
-Implicit Arguments eq_rect [A].
+Arguments eq_ind [A] x P _ y _.
+Arguments eq_rec [A] x P _ y _.
+Arguments eq_rect [A] x P _ y _.
 
 Hint Resolve I conj or_introl or_intror eq_refl: core.
 Hint Resolve ex_intro ex_intro2: core.
@@ -334,6 +334,15 @@ Section Logic_lemmas.
   Defined.
 End Logic_lemmas.
 
+Module EqNotations.
+  Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H)
+    (at level 10, H' at level 10).
+  Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H)
+    (at level 10, H' at level 10).
+  Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H)
+    (at level 10, H' at level 10, only parsing).
+End EqNotations.
+
 Theorem f_equal2 :
   forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
     (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
@@ -392,26 +401,47 @@ Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.
 
 (** Unique existence *)
 
-Notation "'exists' ! x , P" := (ex (unique (fun x => P)))
-  (at level 200, x ident, right associativity,
-    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.
-Notation "'exists' ! x : A , P" :=
-  (ex (unique (fun x:A => P)))
-  (at level 200, x ident, right associativity,
-    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.
+Notation "'exists' ! x .. y , p" :=
+  (ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
+  (at level 200, x binder, right associativity,
+   format "'[' 'exists'  !  '/  ' x .. y ,  '/  ' p ']'")
+  : type_scope.
 
 Lemma unique_existence : forall (A:Type) (P:A->Prop),
   ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
 Proof.
   intros A P; split.
-  intros ((x,Hx),Huni); exists x; red; auto.
-  intros (x,(Hx,Huni)); split.
-  exists x; assumption.
-  intros x' x'' Hx' Hx''; transitivity x.
-  symmetry; auto.
-  auto.
+  - intros ((x,Hx),Huni); exists x; red; auto.
+  - intros (x,(Hx,Huni)); split.
+    + exists x; assumption.
+    + intros x' x'' Hx' Hx''; transitivity x.
+      symmetry; auto.
+      auto.
 Qed.
 
+Lemma forall_exists_unique_domain_coincide :
+  forall A (P:A->Prop), (exists! x, P x) ->
+  forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x).
+Proof.
+  intros A P (x & Hp & Huniq); split.
+  - intro; exists x; auto.
+  - intros (x0 & HPx0 & HQx0) x1 HPx1.
+    replace x1 with x0 by (transitivity x; [symmetry|]; auto).
+    assumption.
+Qed.   
+
+Lemma forall_exists_coincide_unique_domain :
+  forall A (P:A->Prop),
+  (forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x))
+  -> (exists! x, P x).
+Proof.
+  intros A P H.
+  destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|].
+  exists x. split; [trivial|].
+  destruct H with (Q:=fun x'=>x=x') as (_,Huniq).
+  apply Huniq. exists x; auto.
+Qed.       
+
 (** * Being inhabited *)
 
 (** The predicate [inhabited] can be used in different contexts. If [A] is
@@ -436,7 +466,7 @@ Qed.
 
 Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y.
 Proof.
-intros A x y z H1 H2. rewrite <- H2; exact H1.
+  intros A x y z H1 H2. rewrite <- H2; exact H1.
 Qed.
 
 Declare Left Step eq_stepl.
@@ -444,7 +474,7 @@ Declare Right Step eq_trans.
 
 Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
 Proof.
-intros; tauto.
+  intros; tauto.
 Qed.
 
 Declare Left Step iff_stepl.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index bf4031d5..2a833576 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This module defines type constructors for types in [Type]
     ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)
 
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 3619d827..490cbf57 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Notations.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** These are the notations whose level and associativity are imposed by Coq *)
 
 (** Notations for propositional connectives *)
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index abf843bf..c3716eaa 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** The type [nat] of Peano natural numbers (built from [O] and [S])
     is defined in [Datatypes.v] *)
 
@@ -28,7 +26,6 @@
 Require Import Notations.
 Require Import Datatypes.
 Require Import Logic.
-Unset Boxed Definitions.
 
 Open Scope nat_scope.
 
@@ -52,13 +49,7 @@ Qed.
 
 (** Injectivity of successor *)
 
-Theorem eq_add_S : forall n m:nat, S n = S m -> n = m.
-Proof.
-  intros n m Sn_eq_Sm.
-  replace (n=m) with (pred (S n) = pred (S m)) by auto using pred_Sn.
-  rewrite Sn_eq_Sm; trivial.
-Qed.
-
+Definition eq_add_S n m (H: S n = S m): n = m := f_equal pred H.
 Hint Immediate eq_add_S: core.
 
 Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m.
@@ -201,6 +192,16 @@ Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope.
 Notation "x < y < z" := (x < y /\ y < z) : nat_scope.
 Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope.
 
+Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
+Proof.
+induction 1; auto. destruct m; simpl; auto.
+Qed.
+
+Theorem le_S_n : forall n m, S n <= S m -> n <= m.
+Proof.
+intros n m. exact (le_pred (S n) (S m)).
+Qed.
+
 (** Case analysis *)
 
 Theorem nat_case :
@@ -220,3 +221,76 @@ Proof.
   induction n; auto.
   destruct m as [| n0]; auto.
 Qed.
+
+(** Maximum and minimum : definitions and specifications *)
+
+Fixpoint max n m : nat :=
+  match n, m with
+    | O, _ => m
+    | S n', O => n
+    | S n', S m' => S (max n' m')
+  end.
+
+Fixpoint min n m : nat :=
+  match n, m with
+    | O, _ => 0
+    | S n', O => 0
+    | S n', S m' => S (min n' m')
+  end.
+
+Theorem max_l : forall n m : nat, m <= n -> max n m = n.
+Proof.
+induction n; destruct m; simpl; auto. inversion 1.
+intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+Qed.
+
+Theorem max_r : forall n m : nat, n <= m -> max n m = m.
+Proof.
+induction n; destruct m; simpl; auto. inversion 1.
+intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+Qed.
+
+Theorem min_l : forall n m : nat, n <= m -> min n m = n.
+Proof.
+induction n; destruct m; simpl; auto. inversion 1.
+intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+Qed.
+
+Theorem min_r : forall n m : nat, m <= n -> min n m = m.
+Proof.
+induction n; destruct m; simpl; auto. inversion 1.
+intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+Qed.
+
+(** [n]th iteration of the function [f] *)
+
+Fixpoint nat_iter (n:nat) {A} (f:A->A) (x:A) : A :=
+  match n with
+    | O => x
+    | S n' => f (nat_iter n' f x)
+  end.
+
+Lemma nat_iter_succ_r n {A} (f:A->A) (x:A) :
+  nat_iter (S n) f x = nat_iter n f (f x).
+Proof.
+  induction n; intros; simpl; rewrite <- ?IHn; trivial.
+Qed.
+
+Theorem nat_iter_plus :
+  forall (n m:nat) {A} (f:A -> A) (x:A),
+    nat_iter (n + m) f x = nat_iter n f (nat_iter m f x).
+Proof.
+  induction n; intros; simpl; rewrite ?IHn; trivial.
+Qed.
+
+(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv],
+    then the iterates of [f] also preserve it. *)
+
+Theorem nat_iter_invariant :
+  forall (n:nat) {A} (f:A -> A) (P : A -> Prop),
+    (forall x, P x -> P (f x)) ->
+    forall x, P x -> P (nat_iter n f x).
+Proof.
+  induction n; simpl; trivial.
+  intros A f P Hf x Hx. apply Hf, IHn; trivial.
+Qed.
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 5fcb2671..e929c561 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Prelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Notations.
 Require Export Logic.
 Require Export Datatypes.
@@ -18,9 +16,12 @@ Require Export Coq.Init.Tactics.
 (* Initially available plugins
    (+ nat_syntax_plugin loaded in Datatypes) *)
 Declare ML Module "extraction_plugin".
+Declare ML Module "decl_mode_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".
+(* Default substrings not considered by queries like SearchAbout *)
+Add Search Blacklist "_admitted" "_subproof" "Private_".
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 5a951d14..637994b2 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Specif.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Basic specifications : sets that may contain logical information *)
 
 Set Implicit Arguments.
@@ -40,10 +38,10 @@ Inductive sigT2 (A:Type) (P Q:A -> Type) : Type :=
 
 (* Notations *)
 
-Arguments Scope sig [type_scope type_scope].
-Arguments Scope sig2 [type_scope type_scope type_scope].
-Arguments Scope sigT [type_scope type_scope].
-Arguments Scope sigT2 [type_scope type_scope type_scope].
+Arguments sig (A P)%type.
+Arguments sig2 (A P Q)%type.
+Arguments sigT (A P)%type.
+Arguments sigT2 (A P Q)%type.
 
 Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
 Notation "{ x  |  P  & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
@@ -128,6 +126,9 @@ Inductive sumbool (A B:Prop) : Set :=
 
 Add Printing If sumbool.
 
+Arguments left {A B} _, [A] B _.
+Arguments right {A B} _ , A [B] _.
+
 (** [sumor] is an option type equipped with the justification of why
     it may not be a regular value *)
 
@@ -138,6 +139,9 @@ Inductive sumor (A:Type) (B:Prop) : Type :=
 
 Add Printing If sumor.
 
+Arguments inleft {A B} _ , [A] B _.
+Arguments inright {A B} _ , A [B] _.
+
 (** Various forms of the axiom of choice for specifications *)
 
 Section Choice_lemmas.
@@ -152,16 +156,16 @@ Section Choice_lemmas.
   Proof.
    intro H.
    exists (fun z => proj1_sig (H z)).
-   intro z; destruct (H z); trivial.
-  Qed.
+   intro z; destruct (H z); assumption.
+  Defined.
 
   Lemma Choice2 :
    (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}.
   Proof.
     intro H.
     exists (fun z => projT1 (H z)).
-    intro z; destruct (H z); trivial.
-  Qed.
+    intro z; destruct (H z); assumption.
+  Defined.
 
   Lemma bool_choice :
    (forall x:S, {R1 x} + {R2 x}) ->
@@ -170,7 +174,7 @@ Section Choice_lemmas.
     intro H.
     exists (fun z:S => if H z then true else false).
     intro z; destruct (H z); auto.
-  Qed.
+  Defined.
 
 End Choice_lemmas.
 
@@ -188,7 +192,7 @@ Section Dependent_choice_lemmas.
     exists f.
     split. reflexivity.
     induction n; simpl; apply proj2_sig.
-  Qed.
+  Defined.
 
 End Dependent_choice_lemmas.
 
@@ -204,18 +208,18 @@ Definition Exc := option.
 Definition value := Some.
 Definition error := @None.
 
-Implicit Arguments error [A].
+Arguments error [A].
 
 Definition except := False_rec. (* for compatibility with previous versions *)
 
-Implicit Arguments except [P].
+Arguments except [P] _.
 
 Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C.
 Proof.
   intros A C h1 h2.
   apply False_rec.
   apply (h2 h1).
-Qed.
+Defined.
 
 Hint Resolve left right inleft inright: core v62.
 Hint Resolve exist exist2 existT existT2: core.
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 1fa4a77f..4d64b823 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Tactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Notations.
 Require Import Logic.
 Require Import Specif.
@@ -79,6 +77,10 @@ Ltac false_hyp H G :=
 
 Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x.
 
+(* use either discriminate or injection on a hypothesis *)
+
+Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)).
+
 (* Similar variants of destruct *)
 
 Tactic Notation "destruct_with_eqn" constr(x) :=
@@ -187,6 +189,10 @@ Ltac easy :=
 
 Tactic Notation "now" tactic(t) := t; easy.
 
+(** Slightly more than [easy]*)
+
+Ltac easy' := repeat split; simpl; easy || now destruct 1.
+
 (** A tactic to document or check what is proved at some point of a script *)
 
 Ltac now_show c := change c.
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index 5a5f672b..2bb7eae9 100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** * This module proves the validity of
     - well-founded recursion (also known as course of values)
     - well-founded induction
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index 4c14008c..ecadddbc 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: List.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import Le Gt Minus Min Bool.
+Require Import Le Gt Minus Bool.
 
 Set Implicit Arguments.
 
@@ -55,9 +53,16 @@ Section Lists.
 
 End Lists.
 
-(* Keep these notations local to prevent conflicting notations *)
-Local Notation "[ ]" := nil : list_scope.
-Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope.
+
+(** Standard notations for lists. 
+In a special module to avoid conflict. *)
+Module ListNotations.
+Notation " [ ] " := nil : list_scope.
+Notation " [ x ] " := (cons x nil) : list_scope.
+Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
+End ListNotations.
+
+Import ListNotations.
 
 (** ** Facts about lists *)
 
@@ -119,7 +124,7 @@ Section Facts.
     unfold not; intros a H; inversion_clear H.
   Qed.
 
-  Theorem 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 l2, l = l1++x::l2.
   Proof.
   induction l; simpl; destruct 1.
   subst a; auto.
@@ -254,7 +259,7 @@ Section Facts.
   Qed.
 
 
-  (** Compatibility wtih other operations *)
+  (** Compatibility with other operations *)
 
   Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
   Proof.
@@ -1643,7 +1648,7 @@ 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'.
+  exists l1' l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'.
 Proof.
   induction l1; intros.
     exists [], l'; auto.
@@ -1654,7 +1659,7 @@ 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.
+  exists l1 l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2.
 Proof.
   induction l1'; intros.
     exists [], l; auto.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index 56df3f9c..d67baf57 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ListSet.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** A Library for finite sets, implemented as lists *)
 
 (** List is loaded, but not exported.
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
index 08669499..3343aa6f 100644
--- a/theories/Lists/ListTactics.v
+++ b/theories/Lists/ListTactics.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ListTactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import BinPos.
 Require Import List.
 
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index ec31f37d..97915055 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: SetoidList.v 12919 2010-04-10 16:30:44Z herbelin $ *)
-
 Require Export List.
 Require Export Sorting.
 Require Export Setoid Basics Morphisms.
@@ -82,6 +80,10 @@ Qed.
 Definition inclA l l' := forall x, InA x l -> InA x l'.
 Definition equivlistA l l' := forall x, InA x l <-> InA x l'.
 
+Lemma incl_nil l : inclA nil l.
+Proof. intro. intros. inversion H. Qed.
+Hint Resolve incl_nil : list.
+
 (** lists with same elements modulo [eqA] at the same place *)
 
 Inductive eqlistA : list A -> list A -> Prop :=
@@ -159,8 +161,7 @@ Qed.
 Hint Resolve In_InA.
 
 Lemma InA_split : forall l x, InA x l ->
- exists l1, exists y, exists l2,
- eqA x y /\ l = l1++y::l2.
+ exists l1 y l2, eqA x y /\ l = l1++y::l2.
 Proof.
 induction l; intros; inv.
 exists (@nil A); exists a; exists l; auto.
@@ -747,7 +748,7 @@ rewrite filter_In in H; destruct H.
 eapply SortA_InfA_InA; eauto.
 Qed.
 
-Implicit Arguments eq [ [A] ].
+Arguments eq {A} x _.
 
 Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
  forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v
index 1ab4fa9d..45490c62 100644
--- a/theories/Lists/StreamMemo.v
+++ b/theories/Lists/StreamMemo.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index 02d17211..7a6f38fc 100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Streams.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 (** Streams *)
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
deleted file mode 100644
index 498a9dca..00000000
--- a/theories/Lists/TheoryList.v
+++ /dev/null
@@ -1,423 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: TheoryList.v 14641 2011-11-06 11:59:10Z herbelin $ 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.
-
-(**********************)
-(** The null function *)
-(**********************)
-
-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.
-
-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
-  | nil => true
-  | _ => false
-  end).
-*)
-Qed.
-
-(************************)
-(** The Uncons function *)
-(************************)
-
-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.
-(*
-Realizer (fun l => match l with
-  | nil => error
-  | (cons a m) => value (a,m)
-  end).
-*)
-Qed.
-
-(********************************)
-(** The head function           *)
-(********************************)
-
-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.
-(*
-Realizer (fun l => match l with
-  | nil => error
-  | (cons a m) => value a
-  end).
-*)
-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.
-(*
-Realizer (fun l => match l with
-  | nil => nil
-  | (cons a m) => m
-  end).
-*)
-Qed.
-
-(****************************************)
-(** Length of lists                     *)
-(****************************************)
-
-(* length is defined in List *)
-Fixpoint Length_l (l:list A) (n:nat) : nat :=
-  match l with
-  | nil => n
-  | _ :: m => Length_l m (S n)
-  end.
-
-(* 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.
-exists x; transitivity (S (n + length m)); auto.
-(*
-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).
-*)
-Qed.
-
-(*******************************)
-(** Members of lists           *)
-(*******************************)
-Inductive In_spec (a:A) : list A -> Prop :=
-  | in_hd : forall l:list A, In_spec a (a :: l)
-  | in_tl : forall (l:list A) (b:A), In a l -> In_spec a (b :: l).
-Hint Resolve in_hd in_tl.
-Hint Unfold In.
-Hint Resolve in_cons.
-
-Theorem In_In_spec : forall (a:A) (l:list A), In a l <-> In_spec a l.
-split.
-elim l;
- [ intros; contradiction
- | intros; elim H0; [ intros; rewrite H1; auto | auto ] ].
-intros; elim H; auto.
-Qed.
-
-Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}.
-
-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
-  end.
-
-Hint Unfold In.
-Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}.
-Proof.
-induction l.
-auto.
-elim (eqA_dec a a0).
-auto.
-simpl in |- *. elim IHl; auto.
-(*
-Realizer mem.
-*)
-Qed.
-
-(*********************************)
-(** Index of elements            *)
-(*********************************)
-
-Require Import Le.
-Require Import Lt.
-
-Inductive nth_spec : list A -> nat -> A -> Prop :=
-  | nth_spec_O : forall (a:A) (l:list A), nth_spec (a :: l) 1 a
-  | nth_spec_S :
-      forall (n:nat) (a b:A) (l:list A),
-        nth_spec l n a -> nth_spec (b :: l) (S n) a.
-Hint Resolve nth_spec_O nth_spec_S.
-
-Inductive fst_nth_spec : list A -> nat -> A -> Prop :=
-  | fst_nth_O : forall (a:A) (l:list A), fst_nth_spec (a :: l) 1 a
-  | fst_nth_S :
-      forall (n:nat) (a b:A) (l:list A),
-        a <> b -> fst_nth_spec l n a -> fst_nth_spec (b :: l) (S n) a.
-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) : Exc A :=
-  match l, n with
-  | a :: _, S O => value a
-  | _ :: l', S (S p) => Nth_func l' (S p)
-  | _, _ => error
-  end.
-
-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.
-left; exists a; auto.
-destruct (IHl (S n1)) as [[b]| o].
-left; exists b; auto.
-right; destruct o.
-absurd (S n1 = 0); auto.
-auto with arith.
-(*
-Realizer Nth_func.
-*)
-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.
-absurd (S n = 0); auto.
-auto with arith.
-Qed.
-
-Require Import Minus.
-Require Import DecBool.
-
-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))
-  end.
-
-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.
-destruct (eqA_dec a b) as [e| e].
-left; exists p.
-destruct e; elim minus_Sn_m; trivial; elim minus_n_n; auto with arith.
-destruct (irec (S p)) as [[n H]| ].
-left; exists n; auto with arith.
-elim minus_Sn_m; auto with arith.
-apply lt_le_weak; apply lt_O_minus_lt; apply nth_lt_O with m a;
- auto with arith.
-auto.
-Qed.
-
-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.
-(*
-Realizer (fun a l -> Index_p a l (S O)).
-*)
-Qed.
-
-Section Find_sec.
-Variables R P : A -> Prop.
-
-Inductive InR : list A -> Prop :=
-  | inR_hd : forall (a:A) (l:list A), R a -> InR (a :: l)
-  | inR_tl : forall (a:A) (l:list A), InR l -> InR (a :: l).
-Hint Resolve inR_hd inR_tl.
-
-Definition InR_inv (l:list A) :=
-  match l with
-  | nil => False
-  | b :: m => R b \/ InR m
-  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.
-Qed.
-
-Hypothesis RS_dec : forall a:A, {R a} + {P a}.
-
-Fixpoint find (l:list A) : Exc A :=
-  match l with
-  | nil => error
-  | a :: m => ifdec (RS_dec a) (value a) (find m)
-  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).
-left; exists a; auto.
-auto.
-(*
-Realizer find.
-*)
-Qed.
-
-Variable B : Type.
-Variable T : A -> B -> Prop.
-
-Variable TS_dec : forall a:A, {c : B | T a c} + {P a}.
-
-Fixpoint try_find (l:list A) : Exc B :=
-  match l with
-  | nil => error
-  | a :: l1 =>
-      match TS_dec a with
-      | inleft (exist c _) => value c
-      | inright _ => try_find l1
-      end
-  end.
-
-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.
-destruct (TS_dec a) as [[c H1]| ].
-left; exists c.
-exists a; auto.
-auto.
-(*
-Realizer try_find.
-*)
-Qed.
-
-End Find_sec.
-
-Section Assoc_sec.
-
-Variable B : Type.
-Fixpoint assoc (a:A) (l:list (A * B)) :
- Exc B :=
-  match l with
-  | nil => error
-  | (a', b) :: m => ifdec (eqA_dec a a') (value b) (assoc a m)
-  end.
-
-Inductive AllS_assoc (P:A -> Prop) : list (A * B) -> Prop :=
-  | allS_assoc_nil : AllS_assoc P nil
-  | allS_assoc_cons :
-      forall (a:A) (b:B) (l:list (A * B)),
-        P a -> AllS_assoc P l -> AllS_assoc P ((a, b) :: l).
-
-Hint Resolve allS_assoc_nil allS_assoc_cons.
-
-(* The specification seems too weak: it is enough to return b if the
-   list has at least an element (a,b); probably the intention is to have
-   the specification
-
-   (a:A)(l:(list A*B)){b:B|(In_spec (a,b) l)}+{(AllS_assoc [a':A]~(a=a') l)}.
-*)
-
-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.
-destruct assrec as [b'| ].
-left; exact b'.
-right; auto.
-(*
-Realizer assoc.
-*)
-Qed.
-
-End Assoc_sec.
-
-End Lists.
-
-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 0051e2c2..e849967c 100755
--- a/theories/Lists/intro.tex
+++ b/theories/Lists/intro.tex
@@ -13,10 +13,6 @@ This library includes the following files:
 \item {\tt ListSet.v} contains definitions and properties of finite
   sets, implemented as lists.
 
-\item {\tt TheoryList.v} contains complementary results on lists. Here
-  a more theoretic point of view is assumed : one extracts functions
-  from propositions, rather than defining functions and then prove them.
-
 \item {\tt Streams.v} defines the type of infinite lists (streams). It is a
   coinductive type. Basic facts are stated and proved. The streams are
   also polymorphic.
diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget
index d2a31367..adcfba49 100644
--- a/theories/Lists/vo.itarget
+++ b/theories/Lists/vo.itarget
@@ -4,4 +4,3 @@ List.vo
 SetoidList.vo
 StreamMemo.vo
 Streams.vo
-TheoryList.vo
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index d954f40c..2b388687 100644
--- a/theories/Logic/Berardi.v
+++ b/theories/Logic/Berardi.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Berardi.v 14641 2011-11-06 11:59:10Z herbelin $ 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).
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 60dbf3ea..8d82bc8e 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ChoiceFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Some facts and definitions concerning choice and description in
        intuitionistic logic.
 
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index 3f36ff38..9362a11f 100644
--- a/theories/Logic/Classical.v
+++ b/theories/Logic/Classical.v
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* File created for Coq V5.10.14b, Oct 1995 *)
 
 (** Classical Logic *)
 
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index 17b08a2f..6bc0be1d 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides classical logic and functional choice; this
     especially provides both indefinite descriptions and choice functions
     but this is weaker than providing epsilon operator and classical logic
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index ad454a4d..d35ed138 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalDescription.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides classical logic and definite description, which is
     equivalent to providing classical logic and Church's iota operator *)
 
@@ -18,14 +16,12 @@
 
 Set Implicit Arguments.
 
-Require Export Classical.
+Require Export Classical.   (* Axiomatize classical reasoning *)
+Require Export Description. (* Axiomatize constructive form of Church's iota *)
 Require Import ChoiceFacts.
 
 Notation Local inhabited A := A (only parsing).
 
-Axiom constructive_definite_description :
-  forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }.
-
 (** The idea for the following proof comes from [ChicliPottierSimpson02] *)
 
 Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
index 52ecadaf..ae32b127 100644
--- a/theories/Logic/ClassicalEpsilon.v
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides classical logic and indefinite description under
     the form of Hilbert's epsilon operator *)
 
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index 5f4516dd..bcec657a 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Some facts and definitions about classical logic
 
 Table of contents:
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
index fafa0b94..ebb73b19 100644
--- a/theories/Logic/ClassicalUniqueChoice.v
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalUniqueChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides classical logic and unique choice; this is
     weaker than providing iota operator and classical logic as the
     definite descriptions provided by the axiom of unique choice can
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
index 06502d63..7d8bde71 100644
--- a/theories/Logic/Classical_Pred_Set.v
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Set.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* File created for Coq V5.10.14b, Oct 1995, by duplication of
+   Classical_Pred_Type.v *)
 
 (** This file is obsolete, use Classical_Pred_Type.v via Classical.v
 instead *)
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
index bcd529f0..9d57fe88 100644
--- a/theories/Logic/Classical_Pred_Type.v
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is a renaming for V5.10.14b, Oct 1995, of file Classical.v
+   introduced in Coq V5.8.3, June 1993 *)
 
 (** Classical Predicate Logic on Type *)
 
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index c51050d5..d2b35da2 100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -1,12 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Prop.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* File created for Coq V5.10.14b, Oct 1995 *)
+(* Classical tactics for proving disjunctions by Julien Narboux, Jul 2005 *)
+(* Inferred proof-irrelevance and eq_rect_eq added by Hugo Herbelin, Mar 2006 *)
 
 (** Classical Propositional Logic *)
 
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
index 94e623bd..9b28a6ab 100644
--- a/theories/Logic/Classical_Type.v
+++ b/theories/Logic/Classical_Type.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file is obsolete, use Classical.v instead *)
 
 (** Classical Logic for Type *)
diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v
index 004fdef3..33550389 100644
--- a/theories/Logic/ConstructiveEpsilon.v
+++ b/theories/Logic/ConstructiveEpsilon.v
@@ -1,26 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(*i $Id: ConstructiveEpsilon.v 14628 2011-11-03 23:22:45Z herbelin $ i*)
 
-(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(** This module proves the constructive description schema, which
-infers the sigma-existence (i.e., [Set]-existence) of a witness to a
-predicate from the regular existence (i.e., [Prop]-existence). One
-requires that the underlying set is countable and that the predicate
-is decidable. *)
+(** This provides with a proof of the constructive form of definite
+and indefinite descriptions for Sigma^0_1-formulas (hereafter called
+"small" formulas), which infers the sigma-existence (i.e.,
+[Type]-existence) of a witness to a decidable predicate over a
+countable domain from the regular existence (i.e.,
+[Prop]-existence). *)
 
 (** Coq does not allow case analysis on sort [Prop] when the goal is in
-[Set]. Therefore, one cannot eliminate [exists n, P n] in order to
+not in [Prop]. Therefore, one cannot eliminate [exists n, P n] in order to
 show [{n : nat | P n}]. However, one can perform a recursion on an
 inductive predicate in sort [Prop] so that the returning type of the
-recursion is in [Set]. This trick is described in Coq'Art book, Sect.
+recursion is in [Type]. This trick is described in Coq'Art book, Sect.
 14.2.3 and 15.4. In particular, this trick is used in the proof of
 [Fix_F] in the module Coq.Init.Wf. There, recursion is done on an
 inductive predicate [Acc] and the resulting type is in [Type].
@@ -41,7 +40,7 @@ For the first one we provide explicit and short proof terms. *)
 
 (* Direct version *)
 
-Section ConstructiveIndefiniteDescription_Direct.
+Section ConstructiveIndefiniteGroundDescription_Direct.
 
 Variable P : nat -> Prop.
 
@@ -79,11 +78,11 @@ Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} :=
     | right no => linear_search (S m) (inv_before_witness m b no)
   end.
 
-Definition constructive_indefinite_description_nat :
+Definition constructive_indefinite_ground_description_nat :
   (exists n, P n) -> {n:nat | P n} :=
   fun e => linear_search O (let (n, p) := e in O_witness n (stop n p)).
 
-End ConstructiveIndefiniteDescription_Direct.
+End ConstructiveIndefiniteGroundDescription_Direct.
 
 (************************************************************************)
 
@@ -91,7 +90,7 @@ End ConstructiveIndefiniteDescription_Direct.
 
 Require Import Arith.
 
-Section ConstructiveIndefiniteDescription_Acc.
+Section ConstructiveIndefiniteGroundDescription_Acc.
 
 Variable P : nat -> Prop.
 
@@ -151,40 +150,40 @@ destruct (IH y Ryx) as [n Hn].
 exists n; assumption.
 Defined.
 
-Theorem constructive_indefinite_description_nat_Acc :
+Theorem constructive_indefinite_ground_description_nat_Acc :
   (exists n : nat, P n) -> {n : nat | P n}.
 Proof.
 intros H; apply acc_implies_P_eventually.
 apply P_eventually_implies_acc_ex; assumption.
 Defined.
 
-End ConstructiveIndefiniteDescription_Acc.
+End ConstructiveIndefiniteGroundDescription_Acc.
 
 (************************************************************************)
 
-Section ConstructiveEpsilon_nat.
+Section ConstructiveGroundEpsilon_nat.
 
 Variable P : nat -> Prop.
 
 Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}.
 
-Definition constructive_epsilon_nat (E : exists n : nat, P n) : nat
-  := proj1_sig (constructive_indefinite_description_nat P P_decidable E).
+Definition constructive_ground_epsilon_nat (E : exists n : nat, P n) : nat
+  := proj1_sig (constructive_indefinite_ground_description_nat P P_decidable E).
 
-Definition constructive_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_epsilon_nat E)
-  := proj2_sig (constructive_indefinite_description_nat P P_decidable E).
+Definition constructive_ground_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_ground_epsilon_nat E)
+  := proj2_sig (constructive_indefinite_ground_description_nat P P_decidable E).
 
-End ConstructiveEpsilon_nat.
+End ConstructiveGroundEpsilon_nat.
 
 (************************************************************************)
 
-Section ConstructiveEpsilon.
+Section ConstructiveGroundEpsilon.
 
 (** For the current purpose, we say that a set [A] is countable if
 there are functions [f : A -> nat] and [g : nat -> A] such that [g] is
 a left inverse of [f]. *)
 
-Variable A : Set.
+Variable A : Type.
 Variable f : A -> nat.
 Variable g : nat -> A.
 
@@ -201,24 +200,43 @@ Proof.
 intro n; unfold P'; destruct (P_decidable (g n)); auto.
 Defined.
 
-Lemma constructive_indefinite_description : (exists x : A, P x) -> {x : A | P x}.
+Lemma constructive_indefinite_ground_description : (exists x : A, P x) -> {x : A | P x}.
 Proof.
 intro H. assert (H1 : exists n : nat, P' n).
 destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption.
-apply (constructive_indefinite_description_nat P' P'_decidable)  in H1.
+apply (constructive_indefinite_ground_description_nat P' P'_decidable)  in H1.
 destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption.
 Defined.
 
-Lemma constructive_definite_description : (exists! x : A, P x) -> {x : A | P x}.
+Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}.
 Proof.
-  intros; apply constructive_indefinite_description; firstorder.
+  intros; apply constructive_indefinite_ground_description; firstorder.
 Defined.
 
-Definition constructive_epsilon (E : exists x : A, P x) : A
-  := proj1_sig (constructive_indefinite_description E).
-
-Definition constructive_epsilon_spec (E : (exists x, P x)) : P (constructive_epsilon E)
-  := proj2_sig (constructive_indefinite_description E).
-
-End ConstructiveEpsilon.
-
+Definition constructive_ground_epsilon (E : exists x : A, P x) : A
+  := proj1_sig (constructive_indefinite_ground_description E).
+
+Definition constructive_ground_epsilon_spec (E : (exists x, P x)) : P (constructive_ground_epsilon E)
+  := proj2_sig (constructive_indefinite_ground_description E).
+
+End ConstructiveGroundEpsilon.
+
+(* begin hide *)
+(* Compatibility: the qualificative "ground" was absent from the initial
+names of the results in this file but this had introduced confusion
+with the similarly named statement in Description.v *)
+Notation constructive_indefinite_description_nat :=
+  constructive_indefinite_ground_description_nat (only parsing).
+Notation constructive_epsilon_spec_nat :=
+  constructive_ground_epsilon_spec_nat (only parsing).
+Notation constructive_epsilon_nat :=
+  constructive_ground_epsilon_nat (only parsing).
+Notation constructive_indefinite_description :=
+  constructive_indefinite_ground_description (only parsing).
+Notation constructive_definite_description :=
+  constructive_definite_ground_description (only parsing).
+Notation constructive_epsilon_spec :=
+  constructive_ground_epsilon_spec (only parsing).
+Notation constructive_epsilon :=
+  constructive_ground_epsilon (only parsing).
+(* end hide *)
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index ace50884..fec7904e 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Decidable.v 14641 2011-11-06 11:59:10Z herbelin $	 i*)
-
 (** Properties of decidable propositions *)
 
 Definition decidable (P:Prop) := P \/ ~ P.
diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v
index c59d8460..b74ebcc8 100644
--- a/theories/Logic/Description.v
+++ b/theories/Logic/Description.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Description.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides a constructive form of definite description; it
     allows to build functions from the proof of their existence in any
     context; this is weaker than Church's iota operator *)
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 257245cc..8569e55e 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Diaconescu.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
    in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
    that the axiom of choice in equivalence classes entails
@@ -158,8 +156,8 @@ End PredExt_RelChoice_imp_EM.
 (**********************************************************************)
 (** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)
 
-(** This is an adaptation of Diaconescu's paradox exploiting that
-    proof-irrelevance is some form of extensionality *)
+(** This is an adaptation of Diaconescu's theorem, exploiting the
+    form of extensionality provided by proof-irrelevance *)
 
 Section ProofIrrel_RelChoice_imp_EqEM.
 
diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v
index 9134b3aa..cb8f8a73 100644
--- a/theories/Logic/Epsilon.v
+++ b/theories/Logic/Epsilon.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Epsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides indefinite description under the form of
     Hilbert's epsilon operator; it does not assume classical logic. *)
 
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index 7918061c..b8e99036 100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -1,13 +1,15 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *)
+(* Abstraction with respect to the eq_rect_eq axiom and creation of
+   EqdepFacts.v by Hugo Herbelin, Mar 2006 *)
 
 (** 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 2d5f1537..d84cd824 100644
--- a/theories/Logic/EqdepFacts.v
+++ b/theories/Logic/EqdepFacts.v
@@ -1,13 +1,17 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: EqdepFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *)
+(* Further documentation and variants of eq_rect_eq by Hugo Herbelin,
+   Apr 2003 *)
+(* Abstraction with respect to the eq_rect_eq axiom and renaming to
+   EqdepFacts.v by Hugo Herbelin, Mar 2006 *)
 
 (** This file defines dependent equality and shows its equivalence with
     equality on dependent pairs (inhabiting sigma-types). It derives
@@ -33,7 +37,8 @@
 
 Table of contents:
 
-1. Definition of dependent equality and equivalence with equality
+1. Definition of dependent equality and equivalence with equality of
+   dependent pairs and with dependent pair of equalities
 
 2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K
 
@@ -45,6 +50,8 @@ Table of contents:
 (************************************************************************)
 (** * Definition of dependent equality and equivalence with equality of dependent pairs *)
 
+Import EqNotations.
+
 Section Dependent_Equality.
 
   Variable U : Type.
@@ -75,11 +82,11 @@ Section Dependent_Equality.
 
   Scheme eq_indd := Induction for eq Sort Prop.
 
-  (** Equivalent definition of dependent equality expressed as a non
-      dependent inductive type *)
+  (** Equivalent definition of dependent equality as a dependent pair of
+      equalities *)
 
   Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
-    eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y.
+    eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y.
 
   Lemma eq_dep1_dep :
     forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
@@ -95,13 +102,13 @@ Section Dependent_Equality.
   Proof.
     destruct 1.
     apply eq_dep1_intro with (refl_equal p).
-    simpl in |- *; trivial.
+    simpl; trivial.
   Qed.
 
 End Dependent_Equality.
 
-Implicit Arguments eq_dep [U P].
-Implicit Arguments eq_dep1 [U P].
+Arguments eq_dep  [U P] p x q _.
+Arguments eq_dep1 [U P] p x q y.
 
 (** Dependent equality is equivalent to equality on dependent pairs *)
 
@@ -116,24 +123,103 @@ Qed.
 
 Notation eq_sigS_eq_dep := eq_sigT_eq_dep (only parsing). (* Compatibility *)
 
-Lemma equiv_eqex_eqdep :
+Lemma eq_dep_eq_sigT :
   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.
+    eq_dep p x q y -> existT P p x = existT P q y.
 Proof.
-  split.
-  (* -> *)
-  apply eq_sigT_eq_dep.
-  (* <- *)
   destruct 1; reflexivity.
 Qed.
 
-Lemma eq_dep_eq_sigT :
+Lemma eq_sigT_iff_eq_dep :
   forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
-    eq_dep p x q y -> existT P p x = existT P q y.
+    existT P p x = existT P q y <-> eq_dep p x q y.
+Proof.
+  split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT.
+Qed.
+
+Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *)
+
+Lemma eq_sig_eq_dep :
+  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+    exist P p x = exist P q y -> eq_dep p x q y.
+Proof.
+  intros.
+  dependent rewrite H.
+  apply eq_dep_intro.
+Qed.
+
+Lemma eq_dep_eq_sig :
+  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+    eq_dep p x q y -> exist P p x = exist P q y.
 Proof.
   destruct 1; reflexivity.
 Qed.
 
+Lemma eq_sig_iff_eq_dep :
+  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+    exist P p x = exist P q y <-> eq_dep p x q y.
+Proof.
+  split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
+Qed.
+
+(** Dependent equality is equivalent to a dependent pair of equalities *)
+
+Set Implicit Arguments.
+
+Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}.
+Proof.
+  intros; split; intro H.
+  - change x2 with (projT1 (existT P x2 H2)).
+    change H2 with (projT2 (existT P x2 H2)) at 5.
+    destruct H. simpl.
+    exists eq_refl.
+    reflexivity.
+  - destruct H as (->,<-).
+    reflexivity.
+Defined.
+
+Lemma eq_sigT_fst :
+  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2.
+Proof.
+  intros.
+  change x2 with (projT1 (existT P x2 H2)).
+  destruct H.
+  reflexivity.
+Defined.
+
+Lemma eq_sigT_snd :
+  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2.
+Proof.
+  intros.
+  unfold eq_sigT_fst.
+  change x2 with (projT1 (existT P x2 H2)).
+  change H2 with (projT2 (existT P x2 H2)) at 3.
+  destruct H.
+  reflexivity.
+Defined.
+
+Lemma eq_sig_fst :
+  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2.
+Proof.
+  intros.
+  change x2 with (proj1_sig (exist P x2 H2)).
+  destruct H.
+  reflexivity.
+Defined.
+
+Lemma eq_sig_snd :
+  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2.
+Proof.
+  intros.
+  unfold eq_sig_fst, eq_ind.
+  change x2 with (proj1_sig (exist P x2 H2)).
+  change H2 with (proj2_sig (exist P x2 H2)) at 3.
+  destruct H.
+  reflexivity.
+Defined.
+
+Unset Implicit Arguments.
+
 (** Exported hints *)
 
 Hint Resolve eq_dep_intro: core.
@@ -326,5 +412,5 @@ Notation inj_pairT2 := inj_pair2.
 
 End EqdepTheory.
 
-Implicit Arguments eq_dep [].
-Implicit Arguments eq_dep1 [].
+Arguments eq_dep  U P p x q _ : clear implicits.
+Arguments eq_dep1 U P p x q y : clear implicits.
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
index 77908b08..59088aa7 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -1,12 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Bruno Barras, Jan 1998 *)
+(* Made a module instance for EqdepFacts by Hugo Herbelin, Mar 2006 *)
 
 (** 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.
diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v
new file mode 100644
index 00000000..f5e71ef4
--- /dev/null
+++ b/theories/Logic/ExtensionalityFacts.v
@@ -0,0 +1,136 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Some facts and definitions about extensionality
+
+We investigate the relations between the following extensionality principles
+
+- Functional extensionality
+- Equality of projections from diagonal
+- Unicity of inverse bijections
+- Bijectivity of bijective composition
+
+Table of contents
+
+1. Definitions
+
+2. Functional extensionality <-> Equality of projections from diagonal
+
+3. Functional extensionality <-> Unicity of inverse bijections
+
+4. Functional extensionality <-> Bijectivity of bijective composition
+
+*)
+
+Set Implicit Arguments.
+
+(**********************************************************************)
+(** * Definitions *)
+
+(** Being an inverse *)
+
+Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g b) = b).
+
+(** The diagonal over A and the one-one correspondence with A *)
+
+Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }.
+
+Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}.
+
+Arguments pi1 {A} _.
+Arguments pi2 {A} _.
+
+Lemma diagonal_projs_same_behavior : forall A (x:Delta A), pi1 x = pi2 x.
+Proof.
+  destruct x as (a1,a2,Heq); assumption.
+Qed.
+
+Lemma diagonal_inverse1 : forall A, is_inverse (A:=A) delta pi1.
+Proof.
+  split; [trivial|]; destruct b as (a1,a2,[]); reflexivity.
+Qed.
+
+Lemma diagonal_inverse2 : forall A, is_inverse (A:=A) delta pi2.
+Proof.
+  split; [trivial|]; destruct b as (a1,a2,[]); reflexivity.
+Qed.
+
+(** Functional extensionality *)
+
+Local Notation FunctionalExtensionality := 
+  (forall A B (f g : A -> B), (forall x, f x = g x) -> f = g).
+
+(** Equality of projections from diagonal *)
+
+Local Notation EqDeltaProjs := (forall A, pi1 = pi2 :> (Delta A -> A)).
+
+(** Unicity of bijection inverse *)
+
+Local Notation UniqueInverse := (forall A B (f:A->B) g1 g2, is_inverse f g1 -> is_inverse f g2 -> g1 = g2).
+
+(** Bijectivity of bijective composition *)
+
+Definition action A B C (f:A->B) := (fun h:B->C => fun x => h (f x)).
+
+Local Notation BijectivityBijectiveComp := (forall A B C (f:A->B) g,
+  is_inverse f g -> is_inverse (A:=B->C) (action f) (action g)).
+
+(**********************************************************************)
+(** * Functional extensionality <-> Equality of projections from diagonal *)
+
+Theorem FunctExt_iff_EqDeltaProjs : FunctionalExtensionality <-> EqDeltaProjs.
+Proof.
+  split.
+  - intros FunExt *; apply FunExt, diagonal_projs_same_behavior. 
+  - intros EqProjs **; change f with (fun x => pi1 {|pi1:=f x; pi2:=g x; eq:=H x|}).
+    rewrite EqProjs; reflexivity.
+Qed.
+
+(**********************************************************************)
+(** * Functional extensionality <-> Unicity of bijection inverse *)
+
+Lemma FunctExt_UniqInverse : FunctionalExtensionality -> UniqueInverse.
+Proof.
+  intros FunExt * (Hg1f,Hfg1) (Hg2f,Hfg2).
+  apply FunExt. intros; congruence.
+Qed.
+
+Lemma UniqInverse_EqDeltaProjs : UniqueInverse -> EqDeltaProjs.
+Proof.
+  intros UniqInv *.
+  apply UniqInv with delta; [apply diagonal_inverse1 | apply diagonal_inverse2].
+Qed.
+
+Theorem FunctExt_iff_UniqInverse : FunctionalExtensionality <-> UniqueInverse.
+Proof.
+  split. 
+  - apply FunctExt_UniqInverse.
+  - intro; apply FunctExt_iff_EqDeltaProjs, UniqInverse_EqDeltaProjs; trivial.
+Qed.
+
+(**********************************************************************)
+(** * Functional extensionality <-> Bijectivity of bijective composition *)
+
+Lemma FunctExt_BijComp : FunctionalExtensionality -> BijectivityBijectiveComp.
+Proof.
+  intros FunExt * (Hgf,Hfg). split; unfold action.
+  - intros h; apply FunExt; intro b; rewrite Hfg; reflexivity.
+  - intros h; apply FunExt; intro a; rewrite Hgf; reflexivity.
+Qed.
+
+Lemma BijComp_FunctExt : BijectivityBijectiveComp -> FunctionalExtensionality.
+Proof.
+  intros BijComp.
+  apply FunctExt_iff_UniqInverse. intros * H1 H2.
+  destruct BijComp with (C:=A) (1:=H2) as (Hg2f,_).
+  destruct BijComp with (C:=A) (1:=H1) as (_,Hfg1).
+  rewrite <- (Hg2f g1).
+  change g1 with (action g1 (fun x => x)).
+  rewrite -> (Hfg1 (fun x => x)).
+  reflexivity.
+Qed.
diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v
index a696b6c8..35db160f 100644
--- a/theories/Logic/FunctionalExtensionality.v
+++ b/theories/Logic/FunctionalExtensionality.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: FunctionalExtensionality.v 14641 2011-11-06 11:59:10Z herbelin $ 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. *)
 
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
index afaeb51a..bb03c666 100644
--- a/theories/Logic/Hurkens.v
+++ b/theories/Logic/Hurkens.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v
index afca2ee1..8badc07c 100644
--- a/theories/Logic/IndefiniteDescription.v
+++ b/theories/Logic/IndefiniteDescription.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: IndefiniteDescription.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file provides a constructive form of indefinite description that
     allows to build choice functions; this is weaker than Hilbert's
     epsilon operator (which implies weakly classical properties) but
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index 95640d67..753009e6 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: JMeq.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** John Major's Equality as proposed by Conor McBride
 
   Reference:
@@ -26,6 +24,8 @@ Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop :=
 
 Set Elimination Schemes.
 
+Arguments JMeq_refl {A x} , [A] x.
+
 Hint Resolve JMeq_refl.
 
 Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
@@ -113,8 +113,7 @@ apply JMeq_refl.
 Qed.
 
 Lemma eq_dep_strictly_stronger_JMeq :
- exists U, exists P, exists p, exists q, exists x, exists y,
-  JMeq x y /\ ~ eq_dep U P p x q y.
+ exists U P p q x y, JMeq x y /\ ~ eq_dep U P p x q y.
 Proof.
 exists bool. exists (fun _ => True). exists true. exists false.
 exists I. exists I.
diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v
index 2a55f0bb..36508969 100644
--- a/theories/Logic/ProofIrrelevance.v
+++ b/theories/Logic/ProofIrrelevance.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v
index 160ac2d5..6accc480 100644
--- a/theories/Logic/ProofIrrelevanceFacts.v
+++ b/theories/Logic/ProofIrrelevanceFacts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 25d07fc9..d0d58e37 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RelationalChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file axiomatizes the relational form of the axiom of choice *)
 
 Axiom relational_choice :
diff --git a/theories/Logic/SetIsType.v b/theories/Logic/SetIsType.v
index df64822d..f0876fbc 100644
--- a/theories/Logic/SetIsType.v
+++ b/theories/Logic/SetIsType.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,4 +14,4 @@
     Set: simply insert some Require Export of this file at starting
     points of the development and try to recompile...  *)
 
-Notation "'Set'" := Type (only parsing).
\ No newline at end of file
+Notation "'Set'" := Type (only parsing).
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
index 96580749..bdada486 100644
--- a/theories/MSets/MSetAVL.v
+++ b/theories/MSets/MSetAVL.v
@@ -7,8 +7,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * MSetAVL : Implementation of MSetInterface via AVL trees *)
 
 (** This module implements finite sets using AVL trees.
@@ -48,6 +46,7 @@ Local Open Scope Int_scope.
 Local Open Scope lazy_bool_scope.
 
 Definition elt := X.t.
+Hint Transparent elt.
 
 (** ** Trees
 
@@ -376,7 +375,7 @@ Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A :=
   | Leaf => a
   | Node l x r _ => fold f r (f x (fold f l a))
  end.
-Implicit Arguments fold [A].
+Arguments fold [A] f s _.
 
 
 (** ** Subset *)
@@ -877,12 +876,12 @@ Open Scope Int_scope.
 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));
+     [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE];
        [ 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));
+       | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
          [ 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]
@@ -905,7 +904,7 @@ 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 *.
+ clear Hrl Hlr; intro; intros; rewrite join_spec in *.
  intuition; [ setoid_replace y with x | ]; eauto.
  intuition; [ setoid_replace y with x | ]; eauto.
 Qed.
@@ -1691,7 +1690,7 @@ Proof.
 Qed.
 
 Definition lt (s1 s2 : t) : Prop :=
- exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
+ exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
    /\ L.lt (elements s1') (elements s2').
 
 Instance lt_strorder : StrictOrder lt.
@@ -1768,7 +1767,7 @@ Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
    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.
+ simpl; intros; elim_compare x1 x2; simpl; red; auto.
 Qed.
 
 Lemma compare_cont_Cmp : forall s1 cont e2 l,
diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v
index 4ec050bd..eefd2951 100644
--- a/theories/MSets/MSetDecide.v
+++ b/theories/MSets/MSetDecide.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (**************************************************************)
 (* MSetDecide.v                                               *)
 (*                                                            *)
diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v
index fe6c3c79..2e7da404 100644
--- a/theories/MSets/MSetEqProperties.v
+++ b/theories/MSets/MSetEqProperties.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library *)
 
 (** This module proves many properties of finite sets that
diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v
index 6d38b696..4e17618f 100644
--- a/theories/MSets/MSetFacts.v
+++ b/theories/MSets/MSetFacts.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library *)
 
 (** This functor derives additional facts from [MSetInterface.S]. These
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
index 194cb904..f2b908af 100644
--- a/theories/MSets/MSetInterface.v
+++ b/theories/MSets/MSetInterface.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite set library *)
 
 (** Set interfaces, inspired by the one of Ocaml. When compared with
@@ -439,7 +437,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E.
 
  Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}.
  Definition t := t_.
- Implicit Arguments Mkt [ [is_ok] ].
+ Arguments Mkt this {is_ok}.
  Hint Resolve is_ok : typeclass_instances.
 
  Definition In (x : elt)(s : t) := M.In x s.(this).
@@ -653,7 +651,218 @@ Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O.
 End Raw2Sets.
 
 
-(** We provide an ordering for sets-as-sorted-lists *)
+(** It is in fact possible to provide an ordering on sets with
+    very little information on them (more or less only the [In]
+    predicate). This generic build of ordering is in fact not
+    used for the moment, we rather use a simplier version
+    dedicated to sets-as-sorted-lists, see [MakeListOrdering].
+*)
+
+Module Type IN (O:OrderedType).
+ Parameter Inline t : Type.
+ Parameter Inline In : O.t -> t -> Prop.
+ Declare Instance In_compat : Proper (O.eq==>eq==>iff) In.
+ Definition Equal s s' := forall x, In x s <-> In x s'.
+ Definition Empty s := forall x, ~In x s.
+End IN.
+
+Module MakeSetOrdering (O:OrderedType)(Import M:IN O).
+ Module Import MO := OrderedTypeFacts O.
+
+ Definition eq : t -> t -> Prop := Equal.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof. firstorder. Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) In.
+ Proof.
+ intros x x' Ex s s' Es. rewrite Ex. apply Es.
+ Qed.
+
+ Definition Below x s := forall y, In y s -> O.lt y x.
+ Definition Above x s := forall y, In y s -> O.lt x y.
+
+ Definition EquivBefore x s s' :=
+   forall y, O.lt y x -> (In y s <-> In y s').
+
+ Definition EmptyBetween x y s :=
+   forall z, In z s -> O.lt z y -> O.lt z x.
+
+ Definition lt s s' := exists x, EquivBefore x s s' /\
+   ((In x s' /\ Below x s) \/
+    (In x s  /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')).
+
+ Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore.
+ Proof.
+  unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2.
+  setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) Below.
+ Proof.
+  unfold Below. intros x x' Ex s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) Above.
+ Proof.
+  unfold Above. intros x x' Ex s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween.
+ Proof.
+  unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  unfold lt. intros s1 s1' E1 s2 s2' E2.
+  setoid_rewrite E1; setoid_rewrite E2; intuition.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split.
+  (* irreflexive *)
+  intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]).
+  specialize (Em x IN); order.
+  specialize (Be x IN LT); order.
+  (* transitive *)
+  intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)])
+                  (x' & EQ' & [(IN',Pre')|(IN',Lex')]).
+  (* 1) Pre / Pre --> Pre *)
+  assert (O.lt x x') by (specialize (Pre' x IN); auto).
+  exists x; split.
+  intros y Hy; rewrite <- (EQ' y); auto; order.
+  left; split; auto.
+  rewrite <- (EQ' x); auto.
+  (* 2) Pre / Lex *)
+  elim_compare x x'.
+  (* 2a) x=x' --> Pre *)
+  destruct Lex' as (y & INy & LT & Be).
+  exists y; split.
+  intros z Hz. split; intros INz.
+   specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order.
+   specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order.
+  left; split; auto.
+  intros z Hz. transitivity x; auto; order.
+  (* 2b) x<x' --> Pre *)
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  left; split; auto.
+  rewrite <- (EQ' x); auto.
+  (* 2c) x>x' --> Lex *)
+  exists x'; split.
+  intros z Hz. rewrite (EQ z) by order; auto.
+  right; split; auto.
+  rewrite (EQ x'); auto.
+  (* 3) Lex / Pre --> Lex *)
+  destruct Lex as (y & INy & LT & Be).
+  specialize (Pre' y INy).
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  right; split; auto.
+  exists y; repeat split; auto.
+  rewrite <- (EQ' y); auto.
+  intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order.
+  (* 4) Lex / Lex *)
+  elim_compare x x'.
+  (* 4a) x=x' --> impossible *)
+  destruct Lex as (y & INy & LT & Be).
+  setoid_replace x with x' in LT; auto.
+  specialize (Be x' IN' LT); order.
+  (* 4b) x<x' --> Lex *)
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  right; split; auto.
+  destruct Lex as (y & INy & LT & Be).
+  elim_compare y x'.
+   (* 4ba *)
+   destruct Lex' as (y' & Iny' & LT' & Be').
+   exists y'; repeat split; auto. order.
+   intros z Hz LTz. specialize (Be' z Hz LTz).
+    rewrite <- (EQ' z) in Hz by order.
+    apply Be; auto. order.
+   (* 4bb *)
+   exists y; repeat split; auto.
+   rewrite <- (EQ' y); auto.
+   intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order.
+   (* 4bc*)
+   assert (O.lt x' x) by auto. order.
+  (* 4c) x>x' --> Lex *)
+  exists x'; split.
+  intros z Hz. rewrite (EQ z) by order; auto.
+  right; split; auto.
+  rewrite (EQ x'); auto.
+ Qed.
+
+ Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'.
+ Proof.
+  intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]).
+  elim (Hs' x IN).
+  elim (Hs' y IN).
+ Qed.
+
+ Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s.
+
+ Lemma lt_empty_l : forall x s1 s2 s2',
+  Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'.
+ Proof.
+  intros x s1 s2 s2' Em Ab Ad.
+  exists x; split.
+  intros y Hy; split; intros IN.
+  elim (Em y IN).
+  rewrite (Ad y) in IN; destruct IN as [EQ|IN]. order.
+  specialize (Ab y IN). order.
+  left; split.
+  rewrite (Ad x). now left.
+  intros y Hy. elim (Em y Hy).
+ Qed.
+
+ Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2',
+   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
+   O.lt x1 x2 -> lt s1' s2'.
+  Proof.
+  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT.
+  exists x1; split; [ | right; split]; auto.
+  intros y Hy. rewrite (Ad1 y), (Ad2 y).
+  split; intros [U|U]; try order.
+  specialize (Ab1 y U). order.
+  specialize (Ab2 y U). order.
+  rewrite (Ad1 x1); auto with *.
+  exists x2; repeat split; auto.
+  rewrite (Ad2 x2); now left.
+  intros y. rewrite (Ad2 y). intros [U|U]. order.
+  specialize (Ab2 y U). order.
+  Qed.
+
+  Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2',
+   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
+   O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'.
+  Proof.
+  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj).
+  assert (O.lt x1 x).
+   destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto.
+  exists x; split.
+  intros z Hz. rewrite (Ad1 z), (Ad2 z).
+  split; intros [U|U]; try (left; order); right.
+  rewrite <- (EQ z); auto.
+  rewrite (EQ z); auto.
+  destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)].
+  left; split; auto.
+  rewrite (Ad2 x); auto.
+  intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); auto; order.
+  right; split; auto.
+  rewrite (Ad1 x); auto.
+  exists y; repeat split; auto.
+  rewrite (Ad2 y); auto.
+  intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); auto; order.
+  Qed.
+
+End MakeSetOrdering.
+
 
 Module MakeListOrdering (O:OrderedType).
  Module MO:=OrderedTypeFacts O.
@@ -663,7 +872,7 @@ Module MakeListOrdering (O:OrderedType).
 
  Definition eq s s' := forall x, In x s <-> In x s'.
 
- Instance eq_equiv : Equivalence eq.
+ Instance eq_equiv : Equivalence eq := _.
 
  Inductive lt_list : t -> t -> Prop :=
     | lt_nil : forall x s, lt_list nil (x :: s)
diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v
index 48af7e6a..bcf68f1d 100644
--- a/theories/MSets/MSetList.v
+++ b/theories/MSets/MSetList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library *)
 
 (** This file proposes an implementation of the non-dependant
@@ -788,8 +786,7 @@ Module MakeRaw (X: OrderedType) <: RawSets 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'.
+    exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.
 
   Instance lt_strorder : StrictOrder lt.
   Proof.
diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v
index c0038a4f..0f24d76a 100644
--- a/theories/MSets/MSetProperties.v
+++ b/theories/MSets/MSetProperties.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library *)
 
 (** This functor derives additional properties from [MSetInterface.S].
@@ -339,6 +337,14 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
   Notation NoDup := (NoDupA E.eq).
   Notation InA := (InA E.eq).
 
+  (** Alternative specification via [fold_right] *)
+
+  Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) :
+    fold f s i = List.fold_right f i (rev (elements s)).
+  Proof.
+   rewrite fold_spec. symmetry. apply fold_left_rev_right.
+  Qed.
+
   (** ** Induction principles for fold (contributed by S. Lescuyer) *)
 
   (** In the following lemma, the step hypothesis is deliberately restricted
@@ -352,8 +358,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
      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)).
+  rewrite fold_spec_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.
@@ -425,8 +430,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
      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)).
+  rewrite 2 fold_spec_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.
@@ -484,8 +488,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
   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.
+  apply fold_spec_right.
   Qed.
 
   (** An alternate (and previous) specification for [fold] was based on
@@ -1095,8 +1098,7 @@ Module OrdProperties (M:Sets).
    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.
+  rewrite 2 fold_spec_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 *.
@@ -1112,7 +1114,7 @@ Module OrdProperties (M:Sets).
    Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
   Proof.
   intros.
-  rewrite !FM.fold_1.
+  rewrite !fold_spec.
   change (eqA (fold_left (flip f) (elements s') i)
               (fold_left (flip f) (x::elements s) i)).
   unfold flip; rewrite <-!fold_left_rev_right.
@@ -1133,8 +1135,7 @@ Module OrdProperties (M:Sets).
    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.
+  rewrite 2 fold_spec_right.
   apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
   apply eqlistA_rev.
   apply sort_equivlistA_eqlistA; auto with set.
diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v
index f0b964cf..e8087bc5 100644
--- a/theories/MSets/MSetToFiniteSet.v
+++ b/theories/MSets/MSetToFiniteSet.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library : conversion to old [Finite_sets] *)
 
 Require Import Ensembles Finite_sets.
diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v
index 945cb2dd..76f09c76 100644
--- a/theories/MSets/MSetWeakList.v
+++ b/theories/MSets/MSetWeakList.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * Finite sets library *)
 
 (** This file proposes an implementation of the non-dependant
@@ -517,7 +515,7 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
 
   Definition In := InA X.eq.
   Definition eq := Equal.
-  Instance eq_equiv : Equivalence eq.
+  Instance eq_equiv : Equivalence eq := _.
 
 End MakeRaw.
 
diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v
index 958e9861..f179bcd1 100644
--- a/theories/MSets/MSets.v
+++ b/theories/MSets/MSets.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 Require Export Orders.
 Require Export OrdersEx.
 Require Export OrdersAlt.
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index 8695acca..30e35f50 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -1,500 +1,1123 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinNat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import BinPos.
-Unset Boxed Definitions.
+Require Export BinNums.
+Require Import BinPos RelationClasses Morphisms Setoid
+ Equalities OrdersFacts GenericMinMax Bool NAxioms NProperties.
+Require BinNatDef.
 
 (**********************************************************************)
-(** Binary natural numbers *)
+(** * Binary natural numbers, operations and properties *)
+(**********************************************************************)
 
-Inductive N : Set :=
-  | N0 : N
-  | Npos : positive -> N.
+(** The type [N] and its constructors [N0] and [Npos] are now
+    defined in [BinNums.v] *)
 
-(** Declare binding key for scope positive_scope *)
+(** Every definitions and properties about binary natural numbers
+    are placed in a module [N] for qualification purpose. *)
 
-Delimit Scope N_scope with N.
+Local Open Scope N_scope.
 
-(** Automatically open scope positive_scope for the constructors of N *)
+(** Every definitions and early properties about positive numbers
+    are placed in a module [N] for qualification purpose. *)
 
-Bind Scope N_scope with N.
-Arguments Scope Npos [positive_scope].
+Module N
+ <: NAxiomsSig
+ <: UsualOrderedTypeFull
+ <: UsualDecidableTypeFull
+ <: TotalOrder.
 
-Open Local Scope N_scope.
+(** Definitions of operations, now in a separate file *)
 
-Definition Ndiscr : forall n:N, { p:positive | n = Npos p } + { n = N0 }.
-Proof.
- destruct n; auto.
- left; exists p; auto.
-Defined.
+Include BinNatDef.N.
 
-(** Operation x -> 2*x+1 *)
+(** When including property functors, only inline t eq zero one two *)
 
-Definition Ndouble_plus_one x :=
-  match x with
-  | N0 => Npos 1
-  | Npos p => Npos (xI p)
-  end.
+Set Inline Level 30.
 
-(** Operation x -> 2*x *)
+(** Logical predicates *)
 
-Definition Ndouble n :=
-  match n with
-  | N0 => N0
-  | Npos p => Npos (xO p)
-  end.
+Definition eq := @Logic.eq N.
+Definition eq_equiv := @eq_equivalence N.
 
-(** Successor *)
+Definition lt x y := (x ?= y) = Lt.
+Definition gt x y := (x ?= y) = Gt.
+Definition le x y := (x ?= y) <> Gt.
+Definition ge x y := (x ?= y) <> Lt.
 
-Definition Nsucc n :=
-  match n with
-  | N0 => Npos 1
-  | Npos p => Npos (Psucc p)
-  end.
+Infix "<=" := le : N_scope.
+Infix "<" := lt : N_scope.
+Infix ">=" := ge : N_scope.
+Infix ">" := gt : N_scope.
 
-(** Predecessor *)
+Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : N_scope.
+Notation "x < y < z" := (x < y /\ y < z) : N_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : N_scope.
 
-Definition Npred (n : N) := match n with
-| N0 => N0
-| Npos p => match p with
-  | xH => N0
-  | _ => Npos (Ppred p)
-  end
-end.
+Definition divide p q := exists r, q = r*p.
+Notation "( p | q )" := (divide p q) (at level 0) : N_scope.
 
-(** Addition *)
+Definition Even n := exists m, n = 2*m.
+Definition Odd n := exists m, n = 2*m+1.
 
-Definition Nplus n m :=
-  match n, m with
-  | N0, _ => m
-  | _, N0 => n
-  | Npos p, Npos q => Npos (p + q)
-  end.
+(** Decidability of equality. *)
 
-Infix "+" := Nplus : N_scope.
+Definition eq_dec : forall n m : N, { n = m } + { n <> m }.
+Proof.
+ decide equality.
+ apply Pos.eq_dec.
+Defined.
 
-(** Subtraction *)
+(** Discrimination principle *)
 
-Definition Nminus (n m : N) :=
-match n, m with
-| N0, _ => N0
-| n, N0 => n
-| Npos n', Npos m' =>
-  match Pminus_mask n' m' with
-  | IsPos p => Npos p
-  | _ => N0
-  end
-end.
+Definition discr n : { p:positive | n = Npos p } + { n = N0 }.
+Proof.
+ destruct n; auto.
+ left; exists p; auto.
+Defined.
 
-Infix "-" := Nminus : N_scope.
+(** Convenient induction principles *)
+
+Definition binary_rect (P:N -> Type) (f0 : P 0)
+  (f2 : forall n, P n -> P (double n))
+  (fS2 : forall n, P n -> P (succ_double n)) (n : N) : P n :=
+ let P' p := P (Npos p) in
+ let f2' p := f2 (Npos p) in
+ let fS2' p := fS2 (Npos p) in
+ match n with
+ | 0 => f0
+ | Npos p => positive_rect P' fS2' f2' (fS2 0 f0) p
+ end.
 
-(** Multiplication *)
+Definition binary_rec (P:N -> Set) := binary_rect P.
+Definition binary_ind (P:N -> Prop) := binary_rect P.
 
-Definition Nmult n m :=
-  match n, m with
-  | N0, _ => N0
-  | _, N0 => N0
-  | Npos p, Npos q => Npos (p * q)
-  end.
+(** Peano induction on binary natural numbers *)
 
-Infix "*" := Nmult : N_scope.
+Definition peano_rect
+  (P : N -> Type) (f0 : P 0)
+    (f : forall n : N, P n -> P (succ n)) (n : N) : P n :=
+let P' p := P (Npos p) in
+let f' p := f (Npos p) in
+match n with
+| 0 => f0
+| Npos p => Pos.peano_rect P' (f 0 f0) f' p
+end.
 
-(** Boolean Equality *)
+Theorem peano_rect_base P a f : peano_rect P a f 0 = a.
+Proof.
+reflexivity.
+Qed.
 
-Definition Neqb n m :=
- match n, m with
-  | N0, N0 => true
-  | Npos n, Npos m => Peqb n m
-  | _,_ => false
- end.
+Theorem peano_rect_succ P a f n :
+ peano_rect P a f (succ n) = f n (peano_rect P a f n).
+Proof.
+destruct n; simpl.
+trivial.
+now rewrite Pos.peano_rect_succ.
+Qed.
 
-(** Order *)
+Definition peano_ind (P : N -> Prop) := peano_rect P.
 
-Definition Ncompare n m :=
-  match n, m with
-  | N0, N0 => Eq
-  | N0, Npos m' => Lt
-  | Npos n', N0 => Gt
-  | Npos n', Npos m' => (n' ?= m')%positive Eq
-  end.
+Definition peano_rec (P : N -> Set) := peano_rect P.
 
-Infix "?=" := Ncompare (at level 70, no associativity) : N_scope.
+Theorem peano_rec_base P a f : peano_rec P a f 0 = a.
+Proof.
+apply peano_rect_base.
+Qed.
 
-Definition Nlt (x y:N) := (x ?= y) = Lt.
-Definition Ngt (x y:N) := (x ?= y) = Gt.
-Definition Nle (x y:N) := (x ?= y) <> Gt.
-Definition Nge (x y:N) := (x ?= y) <> Lt.
+Theorem peano_rec_succ P a f n :
+ peano_rec P a f (succ n) = f n (peano_rec P a f n).
+Proof.
+apply peano_rect_succ.
+Qed.
 
-Infix "<=" := Nle : N_scope.
-Infix "<" := Nlt : N_scope.
-Infix ">=" := Nge : N_scope.
-Infix ">" := Ngt : N_scope.
+(** Properties of mixed successor and predecessor. *)
 
-(** Min and max *)
+Lemma pos_pred_spec p : Pos.pred_N p = pred (Npos p).
+Proof.
+ now destruct p.
+Qed.
 
-Definition Nmin (n n' : N) := match Ncompare n n' with
- | Lt | Eq => n
- | Gt => n'
- end.
+Lemma succ_pos_spec n : Npos (succ_pos n) = succ n.
+Proof.
+ now destruct n.
+Qed.
 
-Definition Nmax (n n' : N) := match Ncompare n n' with
- | Lt | Eq => n'
- | Gt => n
- end.
+Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n.
+Proof.
+ destruct n. trivial. apply Pos.pred_N_succ.
+Qed.
 
-(** Decidability of equality. *)
+Lemma succ_pos_pred p : succ (Pos.pred_N p) = Npos p.
+Proof.
+ destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double.
+Qed.
+
+(** Properties of successor and predecessor *)
 
-Definition N_eq_dec : forall n m : N, { n = m } + { n <> m }.
+Theorem pred_succ n : pred (succ n) = n.
 Proof.
- decide equality.
- apply positive_eq_dec.
-Defined.
+destruct n; trivial. simpl. apply Pos.pred_N_succ.
+Qed.
 
-(** convenient induction principles *)
+Theorem pred_sub n : pred n = sub n 1.
+Proof.
+ now destruct n as [|[p|p|]].
+Qed.
 
-Lemma N_ind_double :
- forall (a:N) (P:N -> Prop),
-   P N0 ->
-   (forall a, P a -> P (Ndouble a)) ->
-   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+Theorem succ_0_discr n : succ n <> 0.
 Proof.
-  intros; elim a. trivial.
-  simple induction p. intros.
-  apply (H1 (Npos p0)); trivial.
-  intros; apply (H0 (Npos p0)); trivial.
-  intros; apply (H1 N0); assumption.
+now destruct n.
 Qed.
 
-Lemma N_rec_double :
- forall (a:N) (P:N -> Set),
-   P N0 ->
-   (forall a, P a -> P (Ndouble a)) ->
-   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+(** Specification of addition *)
+
+Theorem add_0_l n : 0 + n = n.
 Proof.
-  intros; elim a. trivial.
-  simple induction p. intros.
-  apply (H1 (Npos p0)); trivial.
-  intros; apply (H0 (Npos p0)); trivial.
-  intros; apply (H1 N0); assumption.
+reflexivity.
 Qed.
 
-(** Peano induction on binary natural numbers *)
+Theorem add_succ_l n m : succ n + m = succ (n + m).
+Proof.
+destruct n, m; unfold succ, add; now rewrite ?Pos.add_1_l, ?Pos.add_succ_l.
+Qed.
 
-Definition Nrect
-  (P : N -> Type) (a : P N0)
-    (f : forall n : N, P n -> P (Nsucc n)) (n : N) : P n :=
-let f' (p : positive) (x : P (Npos p)) := f (Npos p) x in
-let P' (p : positive) := P (Npos p) in
-match n return (P n) with
-| N0 => a
-| Npos p => Prect P' (f N0 a) f' p
-end.
+(** Specification of subtraction. *)
 
-Theorem Nrect_base : forall P a f, Nrect P a f N0 = a.
+Theorem sub_0_r n : n - 0 = n.
 Proof.
-intros P a f; simpl; reflexivity.
+now destruct n.
 Qed.
 
-Theorem Nrect_step : forall P a f n, Nrect P a f (Nsucc n) = f n (Nrect P a f n).
+Theorem sub_succ_r n m : n - succ m = pred (n - m).
 Proof.
-intros P a f; destruct n as [| p]; simpl;
-[rewrite Prect_base | rewrite Prect_succ]; reflexivity.
+destruct n as [|p], m as [|q]; trivial.
+now destruct p.
+simpl. rewrite Pos.sub_mask_succ_r, Pos.sub_mask_carry_spec.
+now destruct (Pos.sub_mask p q) as [|[r|r|]|].
 Qed.
 
-Definition Nind (P : N -> Prop) := Nrect P.
+(** Specification of multiplication *)
 
-Definition Nrec (P : N -> Set) := Nrect P.
+Theorem mul_0_l n : 0 * n = 0.
+Proof.
+reflexivity.
+Qed.
 
-Theorem Nrec_base : forall P a f, Nrec P a f N0 = a.
+Theorem mul_succ_l n m : (succ n) * m = n * m + m.
 Proof.
-intros P a f; unfold Nrec; apply Nrect_base.
+destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm.
+apply Pos.mul_succ_l.
 Qed.
 
-Theorem Nrec_step : forall P a f n, Nrec P a f (Nsucc n) = f n (Nrec P a f n).
+(** Specification of boolean comparisons. *)
+
+Lemma eqb_eq n m : eqb n m = true <-> n=m.
 Proof.
-intros P a f; unfold Nrec; apply Nrect_step.
+destruct n as [|n], m as [|m]; simpl; try easy'.
+rewrite Pos.eqb_eq. split; intro H. now subst. now destr_eq H.
 Qed.
 
-(** Properties of successor and predecessor *)
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
+Proof.
+  unfold ltb, lt. destruct compare; easy'.
+Qed.
 
-Theorem Npred_succ : forall n : N, Npred (Nsucc n) = n.
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
 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.
+  unfold leb, le. destruct compare; easy'.
 Qed.
 
-(** Properties of addition *)
+(** Basic properties of comparison *)
+
+Theorem compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
+Proof.
+destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence.
+Qed.
 
-Theorem Nplus_0_l : forall n:N, N0 + n = n.
+Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
 Proof.
 reflexivity.
 Qed.
 
-Theorem Nplus_0_r : forall n:N, n + N0 = n.
+Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
 Proof.
-destruct n; reflexivity.
+reflexivity.
 Qed.
 
-Theorem Nplus_comm : forall n m:N, n + m = m + n.
+Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
 Proof.
-intros.
-destruct n; destruct m; simpl in |- *; try reflexivity.
-rewrite Pplus_comm; reflexivity.
+destruct n, m; simpl; trivial. apply Pos.compare_antisym.
+Qed.
+
+(** Some more advanced properties of comparison and orders,
+    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)
+
+Include BoolOrderFacts.
+
+(** We regroup here some results used for proving the correctness
+    of more advanced functions. These results will also be provided
+    by the generic functor of properties about natural numbers
+    instantiated at the end of the file. *)
+
+Module Import Private_BootStrap.
+
+Theorem add_0_r n : n + 0 = n.
+Proof.
+now destruct n.
 Qed.
 
-Theorem Nplus_assoc : forall n m p:N, n + (m + p) = n + m + p.
+Theorem add_comm n m : n + m = m + n.
+Proof.
+destruct n, m; simpl; try reflexivity. simpl. f_equal. apply Pos.add_comm.
+Qed.
+
+Theorem add_assoc n m p : n + (m + p) = n + m + p.
 Proof.
-intros.
 destruct n; try reflexivity.
 destruct m; try reflexivity.
 destruct p; try reflexivity.
-simpl in |- *; rewrite Pplus_assoc; reflexivity.
+simpl. f_equal. apply Pos.add_assoc.
+Qed.
+
+Lemma sub_add n m : n <= m -> m - n + n = m.
+Proof.
+ destruct n as [|p], m as [|q]; simpl; try easy'. intros H.
+ case Pos.sub_mask_spec; intros; simpl; subst; trivial.
+ now rewrite Pos.add_comm.
+ apply Pos.le_nlt in H. elim H. apply Pos.lt_add_r.
+Qed.
+
+Theorem mul_comm n m : n * m = m * n.
+Proof.
+destruct n, m; simpl; trivial. f_equal. apply Pos.mul_comm.
+Qed.
+
+Lemma le_0_l n : 0<=n.
+Proof.
+now destruct n.
+Qed.
+
+Lemma leb_spec n m : BoolSpec (n<=m) (m<n) (n <=? m).
+Proof.
+ unfold le, lt, leb. rewrite (compare_antisym n m).
+ case compare; now constructor.
+Qed.
+
+Lemma add_lt_cancel_l n m p : p+n < p+m -> n<m.
+Proof.
+ intro H. destruct p. simpl; auto.
+ destruct n; destruct m.
+ elim (Pos.lt_irrefl _ H).
+ red; auto.
+ rewrite add_0_r in H. simpl in H.
+ red in H. simpl in H.
+ elim (Pos.lt_not_add_l _ _ H).
+ now apply (Pos.add_lt_mono_l p).
+Qed.
+
+End Private_BootStrap.
+
+(** Specification of lt and le. *)
+
+Lemma lt_succ_r n m : n < succ m <-> n<=m.
+Proof.
+destruct n as [|p], m as [|q]; simpl; try easy'.
+split. now destruct p. now destruct 1.
+apply Pos.lt_succ_r.
 Qed.
 
-Theorem Nplus_succ : forall n m:N, Nsucc n + m = Nsucc (n + m).
+(** Properties of [double] and [succ_double] *)
+
+Lemma double_spec n : double n = 2 * n.
 Proof.
-destruct n; destruct m.
-  simpl in |- *; reflexivity.
-  unfold Nsucc, Nplus in |- *; rewrite <- Pplus_one_succ_l; reflexivity.
-  simpl in |- *; reflexivity.
-  simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity.
+ reflexivity.
 Qed.
 
-Theorem Nsucc_0 : forall n : N, Nsucc n <> N0.
+Lemma succ_double_spec n : succ_double n = 2 * n + 1.
 Proof.
-intro n; elim n; simpl Nsucc; intros; discriminate.
+ now destruct n.
 Qed.
 
-Theorem Nsucc_inj : forall n m:N, Nsucc n = Nsucc m -> n = m.
+Lemma double_add n m : double (n+m) = double n + double m.
 Proof.
-destruct n; destruct m; simpl in |- *; intro H; reflexivity || injection H;
- clear H; intro H.
-  symmetry  in H; contradiction Psucc_not_one with p.
-  contradiction Psucc_not_one with p.
-  rewrite Psucc_inj with (1 := H); reflexivity.
+ now destruct n, m.
 Qed.
 
-Theorem Nplus_reg_l : forall n m p:N, n + m = n + p -> m = p.
+Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m.
 Proof.
-intro n; pattern n in |- *; apply Nind; clear n; simpl in |- *.
-  trivial.
-  intros n IHn m p H0; do 2 rewrite Nplus_succ in H0.
-  apply IHn; apply Nsucc_inj; assumption.
+ now destruct n, m.
 Qed.
 
-(** Properties of subtraction. *)
+Lemma double_mul n m : double (n*m) = double n * m.
+Proof.
+ now destruct n, m.
+Qed.
 
-Lemma Nminus_N0_Nle : forall n n' : N, n - n' = N0 <-> n <= n'.
+Lemma succ_double_mul n m :
+ succ_double n * m = double n * m + m.
 Proof.
-destruct n as [| p]; destruct n' as [| q]; unfold Nle; simpl;
-split; intro H; try discriminate; try reflexivity.
-now elim H.
-intro H1; apply Pminus_mask_Gt in H1. destruct H1 as [h [H1 _]].
-rewrite H1 in H; discriminate.
-case_eq (Pcompare p q Eq); intro H1; rewrite H1 in H; try now elim H.
-assert (H2 : p = q); [now apply Pcompare_Eq_eq |]. now rewrite H2, Pminus_mask_diag.
-now rewrite Pminus_mask_Lt.
+ destruct n; simpl; destruct m; trivial.
+ now rewrite Pos.add_comm.
 Qed.
 
-Theorem Nminus_0_r : forall n : N, n - N0 = n.
+Lemma div2_double n : div2 (double n) = n.
 Proof.
 now destruct n.
 Qed.
 
-Theorem Nminus_succ_r : forall n m : N, n - (Nsucc m) = Npred (n - m).
+Lemma div2_succ_double n : div2 (succ_double n) = n.
 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 |].
+now destruct n.
 Qed.
 
-(** Properties of multiplication *)
+Lemma double_inj n m : double n = double m -> n = m.
+Proof.
+intro H. rewrite <- (div2_double n), H. apply div2_double.
+Qed.
 
-Theorem Nmult_0_l : forall n:N, N0 * n = N0.
+Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m.
 Proof.
-reflexivity.
+intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double.
 Qed.
 
-Theorem Nmult_1_l : forall n:N, Npos 1 * n = n.
+Lemma succ_double_lt n m : n<m -> succ_double n < double m.
 Proof.
-destruct n; reflexivity.
+ destruct n as [|n], m as [|m]; intros H; try easy.
+ unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H.
 Qed.
 
-Theorem Nmult_Sn_m : forall n m : N, (Nsucc n) * m = m + n * m.
+
+(** Specification of minimum and maximum *)
+
+Theorem min_l n m : n <= m -> min n m = n.
 Proof.
-destruct n as [| n]; destruct m as [| m]; simpl; auto.
-rewrite Pmult_Sn_m; reflexivity.
+unfold min, le. case compare; trivial. now destruct 1.
 Qed.
 
-Theorem Nmult_1_r : forall n:N, n * Npos 1%positive = n.
+Theorem min_r n m : m <= n -> min n m = m.
 Proof.
-destruct n; simpl in |- *; try reflexivity.
-rewrite Pmult_1_r; reflexivity.
+unfold min, le. rewrite compare_antisym.
+case compare_spec; trivial. now destruct 2.
 Qed.
 
-Theorem Nmult_comm : forall n m:N, n * m = m * n.
+Theorem max_l n m : m <= n -> max n m = n.
 Proof.
-intros.
-destruct n; destruct m; simpl in |- *; try reflexivity.
-rewrite Pmult_comm; reflexivity.
+unfold max, le. rewrite compare_antisym.
+case compare_spec; auto. now destruct 2.
 Qed.
 
-Theorem Nmult_assoc : forall n m p:N, n * (m * p) = n * m * p.
+Theorem max_r n m : n <= m -> max n m = m.
 Proof.
-intros.
-destruct n; try reflexivity.
-destruct m; try reflexivity.
-destruct p; try reflexivity.
-simpl in |- *; rewrite Pmult_assoc; reflexivity.
+unfold max, le. case compare; trivial. now destruct 1.
 Qed.
 
-Theorem Nmult_plus_distr_r : forall n m p:N, (n + m) * p = n * p + m * p.
+(** 0 is the least natural number *)
+
+Theorem compare_0_r n : (n ?= 0) <> Lt.
 Proof.
-intros.
-destruct n; try reflexivity.
-destruct m; destruct p; try reflexivity.
-simpl in |- *; rewrite Pmult_plus_distr_r; reflexivity.
+now destruct n.
 Qed.
 
-Theorem Nmult_reg_r : forall n m p:N, p <> N0 -> n * p = m * p -> n = m.
+(** Specifications of power *)
+
+Lemma pow_0_r n : n ^ 0 = 1.
+Proof. reflexivity. Qed.
+
+Lemma pow_succ_r n p : 0<=p -> n^(succ p) = n * n^p.
+Proof.
+ intros _.
+ destruct n, p; simpl; trivial; f_equal. apply Pos.pow_succ_r.
+Qed.
+
+Lemma pow_neg_r n p : p<0 -> n^p = 0.
 Proof.
-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.
+ now destruct p.
 Qed.
 
-(** Properties of boolean order. *)
+(** Specification of square *)
 
-Lemma Neqb_eq : forall n m, Neqb n m = true <-> n=m.
+Lemma square_spec n : square n = n * n.
 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.
+ destruct n; trivial. simpl. f_equal. apply Pos.square_spec.
 Qed.
 
-(** Properties of comparison *)
+(** Specification of Base-2 logarithm *)
 
-Lemma Ncompare_refl : forall n, (n ?= n) = Eq.
+Lemma size_log2 n : n<>0 -> size n = succ (log2 n).
 Proof.
-destruct n; simpl; auto.
-apply Pcompare_refl.
+ destruct n as [|[n|n| ]]; trivial. now destruct 1.
 Qed.
 
-Theorem Ncompare_Eq_eq : forall n m:N, (n ?= m) = Eq -> n = m.
+Lemma size_gt n : n < 2^(size n).
 Proof.
-destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H;
- reflexivity || (try discriminate H).
-  rewrite (Pcompare_Eq_eq n m H); reflexivity.
+ destruct n. reflexivity. simpl. apply Pos.size_gt.
 Qed.
 
-Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m.
+Lemma size_le n : 2^(size n) <= succ_double n.
 Proof.
-split; intros;
- [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ].
+ destruct n. discriminate. simpl.
+ change (2^Pos.size p <= Pos.succ (p~0))%positive.
+ apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le.
 Qed.
 
-Lemma Ncompare_antisym : forall n m, CompOpp (n ?= m) = (m ?= n).
+Lemma log2_spec n : 0 < n ->
+ 2^(log2 n) <= n < 2^(succ (log2 n)).
 Proof.
-destruct n; destruct m; simpl; auto.
-exact (Pcompare_antisym p p0 Eq).
+ destruct n as [|[p|p|]]; discriminate || intros _; simpl; split.
+ apply (size_le (Npos p)).
+ apply Pos.size_gt.
+ apply Pos.size_le.
+ apply Pos.size_gt.
+ discriminate.
+ reflexivity.
 Qed.
 
-Lemma Ngt_Nlt : forall n m, n > m -> m < n.
+Lemma log2_nonpos n : n<=0 -> log2 n = 0.
 Proof.
-unfold Ngt, Nlt; intros n m GT.
-rewrite <- Ncompare_antisym, GT; reflexivity.
+ destruct n; intros Hn. reflexivity. now destruct Hn.
 Qed.
 
-Theorem Nlt_irrefl : forall n : N, ~ n < n.
+(** Specification of parity functions *)
+
+Lemma even_spec n : even n = true <-> Even n.
 Proof.
-intro n; unfold Nlt; now rewrite Ncompare_refl.
+ destruct n.
+ split. now exists 0.
+ trivial.
+ destruct p; simpl; split; try easy.
+ intros (m,H). now destruct m.
+ now exists (Npos p).
+ intros (m,H). now destruct m.
 Qed.
 
-Theorem Nlt_trans : forall n m q, n < m -> m < q -> n < q.
+Lemma odd_spec n : odd n = true <-> Odd n.
 Proof.
-destruct n;
- destruct m; try discriminate;
- destruct q; try discriminate; auto.
-eapply Plt_trans; eauto.
+ destruct n.
+ split. discriminate.
+ intros (m,H). now destruct m.
+ destruct p; simpl; split; try easy.
+ now exists (Npos p).
+ intros (m,H). now destruct m.
+ now exists 0.
 Qed.
 
-Theorem Nlt_not_eq : forall n m, n < m -> ~ n = m.
+(** Specification of the euclidean division *)
+
+Theorem pos_div_eucl_spec (a:positive)(b:N) :
+  let (q,r) := pos_div_eucl a b in Npos a = q * b + r.
 Proof.
- intros n m LT EQ. subst m. elim (Nlt_irrefl n); auto.
+  induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta.
+  (* a~1 *)
+  destruct pos_div_eucl as (q,r).
+  change (Npos a~1) with (succ_double (Npos a)).
+  rewrite IHa, succ_double_add, double_mul.
+  case leb_spec; intros H; trivial.
+  rewrite succ_double_mul, <- add_assoc. f_equal.
+  now rewrite (add_comm b), sub_add.
+  (* a~0 *)
+  destruct pos_div_eucl as (q,r).
+  change (Npos a~0) with (double (Npos a)).
+  rewrite IHa, double_add, double_mul.
+  case leb_spec; intros H; trivial.
+  rewrite succ_double_mul, <- add_assoc. f_equal.
+  now rewrite (add_comm b), sub_add.
+  (* 1 *)
+  now destruct b as [|[ | | ]].
 Qed.
 
-Theorem Ncompare_n_Sm :
-  forall n m : N, Ncompare n (Nsucc m) = Lt <-> Ncompare n m = Lt \/ n = m.
+Theorem div_eucl_spec a b :
+ let (q,r) := div_eucl a b in a = b * q + r.
 Proof.
-intros n m; split; destruct n as [| p]; destruct m as [| q]; simpl; auto.
-destruct p; simpl; intros; discriminate.
-pose proof (Pcompare_p_Sq p q) as (?,_).
-assert (p = q <-> Npos p = Npos q); [split; congruence | tauto].
-intros H; destruct H; discriminate.
-pose proof (Pcompare_p_Sq p q) as (_,?);
-assert (p = q <-> Npos p = Npos q); [split; congruence | tauto].
+  destruct a as [|a], b as [|b]; unfold div_eucl; trivial.
+  generalize (pos_div_eucl_spec a (Npos b)).
+  destruct pos_div_eucl. now rewrite mul_comm.
 Qed.
 
-Lemma Nle_lteq : forall x y, x <= y <-> x < y \/ x=y.
+Theorem div_mod' a b : a = b * (a/b) + (a mod b).
 Proof.
-unfold Nle, Nlt; intros.
-generalize (Ncompare_eq_correct x y).
-destruct (x ?= y); intuition; discriminate.
+  generalize (div_eucl_spec a b).
+  unfold div, modulo. now destruct div_eucl.
 Qed.
 
-Lemma Ncompare_spec : forall x y, CompSpec eq Nlt x y (Ncompare x y).
+Definition div_mod a b : b<>0 -> a = b * (a/b) + (a mod b).
 Proof.
-intros.
-destruct (Ncompare x y) as [ ]_eqn; constructor; auto.
-apply Ncompare_Eq_eq; auto.
-apply Ngt_Nlt; auto.
+ intros _. apply div_mod'.
 Qed.
 
-(** 0 is the least natural number *)
+Theorem pos_div_eucl_remainder (a:positive) (b:N) :
+  b<>0 -> snd (pos_div_eucl a b) < b.
+Proof.
+  intros Hb.
+  induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta.
+  (* a~1 *)
+  destruct pos_div_eucl as (q,r); simpl in *.
+  case leb_spec; intros H; simpl; trivial.
+  apply add_lt_cancel_l with b. rewrite add_comm, sub_add by trivial.
+  destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
+  apply (succ_double_lt _ _ IHa).
+  (* a~0 *)
+  destruct pos_div_eucl as (q,r); simpl in *.
+  case leb_spec; intros H; simpl; trivial.
+  apply add_lt_cancel_l with b. rewrite add_comm, sub_add by trivial.
+  destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
+  now destruct r.
+  (* 1 *)
+  destruct b as [|[ | | ]]; easy || (now destruct Hb).
+Qed.
+
+Theorem mod_lt a b : b<>0 -> a mod b < b.
+Proof.
+  destruct b as [ |b]. now destruct 1.
+  destruct a as [ |a]. reflexivity.
+  unfold modulo. simpl. apply pos_div_eucl_remainder.
+Qed.
+
+Theorem mod_bound_pos a b : 0<=a -> 0<b -> 0 <= a mod b < b.
+Proof.
+ intros _ H. split. apply le_0_l. apply mod_lt. now destruct b.
+Qed.
 
-Theorem Ncompare_0 : forall n : N, Ncompare n N0 <> Lt.
+(** Specification of square root *)
+
+Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n.
+Proof.
+ destruct n. reflexivity.
+ unfold sqrtrem, sqrt, Pos.sqrt.
+ destruct (Pos.sqrtrem p) as (s,r). now destruct r.
+Qed.
+
+Lemma sqrtrem_spec n :
+ let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s.
+Proof.
+ destruct n. now split.
+ generalize (Pos.sqrtrem_spec p). simpl.
+ destruct 1; simpl; subst; now split.
+Qed.
+
+Lemma sqrt_spec n : 0<=n ->
+ let s := sqrt n in s*s <= n < (succ s)*(succ s).
+Proof.
+ intros _. destruct n. now split. apply (Pos.sqrt_spec p).
+Qed.
+
+Lemma sqrt_neg n : n<0 -> sqrt n = 0.
+Proof.
+ now destruct n.
+Qed.
+
+(** Specification of gcd *)
+
+(** The first component of ggcd is gcd *)
+
+Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b.
+Proof.
+ destruct a as [|p], b as [|q]; simpl; auto.
+ assert (H := Pos.ggcd_gcd p q).
+ destruct Pos.ggcd as (g,(aa,bb)); simpl; now f_equal.
+Qed.
+
+(** The other components of ggcd are indeed the correct factors. *)
+
+Lemma ggcd_correct_divisors a b :
+  let '(g,(aa,bb)) := ggcd a b in
+  a=g*aa /\ b=g*bb.
+Proof.
+ destruct a as [|p], b as [|q]; simpl; auto.
+ now rewrite Pos.mul_1_r.
+ now rewrite Pos.mul_1_r.
+ generalize (Pos.ggcd_correct_divisors p q).
+ destruct Pos.ggcd as (g,(aa,bb)); simpl.
+ destruct 1; split; now f_equal.
+Qed.
+
+(** We can use this fact to prove a part of the gcd correctness *)
+
+Lemma gcd_divide_l a b : (gcd a b | a).
+Proof.
+ rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa.
+  now rewrite mul_comm.
+Qed.
+
+Lemma gcd_divide_r a b : (gcd a b | b).
 Proof.
-destruct n; discriminate.
+ rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb.
+  now rewrite mul_comm.
 Qed.
 
-(** Dividing by 2 *)
+(** We now prove directly that gcd is the greatest amongst common divisors *)
 
-Definition Ndiv2 (n:N) :=
-  match n with
-  | N0 => N0
-  | Npos 1 => N0
-  | Npos (xO p) => Npos p
-  | Npos (xI p) => Npos p
-  end.
+Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c|gcd a b).
+Proof.
+ destruct a as [ |p], b as [ |q]; simpl; trivial.
+ destruct c as [ |r]. intros (s,H). destruct s; discriminate.
+ intros ([ |s],Hs) ([ |t],Ht); try discriminate; simpl in *.
+ destruct (Pos.gcd_greatest p q r) as (u,H).
+ exists s. now inversion Hs.
+ exists t. now inversion Ht.
+ exists (Npos u). simpl; now f_equal.
+Qed.
+
+Lemma gcd_nonneg a b : 0 <= gcd a b.
+Proof. apply le_0_l. Qed.
+
+(** Specification of bitwise functions *)
+
+(** Correctness proofs for [testbit]. *)
+
+Lemma testbit_even_0 a : testbit (2*a) 0 = false.
+Proof.
+ now destruct a.
+Qed.
 
-Lemma Ndouble_div2 : forall n:N, Ndiv2 (Ndouble n) = n.
+Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
 Proof.
-  destruct n; trivial.
+ now destruct a.
 Qed.
 
-Lemma Ndouble_plus_one_div2 :
- forall n:N, Ndiv2 (Ndouble_plus_one n) = n.
+Lemma testbit_succ_r_div2 a n : 0<=n ->
+ testbit a (succ n) = testbit (div2 a) n.
 Proof.
-  destruct n; trivial.
+ intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial;
+  f_equal; apply Pos.pred_N_succ.
 Qed.
 
-Lemma Ndouble_inj : forall n m, Ndouble n = Ndouble m -> n = m.
+Lemma testbit_odd_succ a n : 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a n.
 Proof.
-  intros. rewrite <- (Ndouble_div2 n). rewrite H. apply Ndouble_div2.
+ intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a.
 Qed.
 
-Lemma Ndouble_plus_one_inj :
- forall n m, Ndouble_plus_one n = Ndouble_plus_one m -> n = m.
+Lemma testbit_even_succ a n : 0<=n ->
+ testbit (2*a) (succ n) = testbit a n.
 Proof.
-  intros. rewrite <- (Ndouble_plus_one_div2 n). rewrite H. apply Ndouble_plus_one_div2.
+ intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a.
 Qed.
+
+Lemma testbit_neg_r a n : n<0 -> testbit a n = false.
+Proof.
+ now destruct n.
+Qed.
+
+(** Correctness proofs for shifts *)
+
+Lemma shiftr_succ_r a n :
+ shiftr a (succ n) = div2 (shiftr a n).
+Proof.
+ destruct n; simpl; trivial. apply Pos.iter_succ.
+Qed.
+
+Lemma shiftl_succ_r a n :
+ shiftl a (succ n) = double (shiftl a n).
+Proof.
+ destruct n, a; simpl; trivial. f_equal. apply Pos.iter_succ.
+Qed.
+
+Lemma shiftr_spec a n m : 0<=m ->
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ intros _. revert a m.
+ induction n using peano_ind; intros a m. now rewrite add_0_r.
+ rewrite add_comm, add_succ_l, add_comm, <- add_succ_l.
+ now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l.
+Qed.
+
+Lemma shiftl_spec_high a n m : 0<=m -> n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ intros _ H.
+ rewrite <- (sub_add n m H) at 1.
+ set (m' := m-n). clearbody m'. clear H m. revert a m'.
+ induction n using peano_ind; intros a m.
+ rewrite add_0_r; now destruct a.
+ rewrite shiftl_succ_r.
+ rewrite add_comm, add_succ_l, add_comm.
+ now rewrite testbit_succ_r_div2, div2_double by apply le_0_l.
+Qed.
+
+Lemma shiftl_spec_low a n m : m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ revert a m.
+ induction n using peano_ind; intros a m H.
+ elim (le_0_l m). now rewrite compare_antisym, H.
+ rewrite shiftl_succ_r.
+ destruct m. now destruct (shiftl a n).
+ rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l.
+ apply IHn.
+ apply add_lt_cancel_l with 1. rewrite 2 (add_succ_l 0). simpl.
+ now rewrite succ_pos_pred.
+Qed.
+
+Definition div2_spec a : div2 a = shiftr a 1.
+Proof.
+ reflexivity.
+Qed.
+
+(** Semantics of bitwise operations *)
+
+Lemma pos_lxor_spec p p' n :
+ testbit (Pos.lxor p p') n = xorb (Pos.testbit p n) (Pos.testbit p' n).
+Proof.
+ revert p' n.
+ induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
+ (specialize (IH p'); destruct Pos.lxor; trivial; now rewrite <-IH) ||
+ (now destruct Pos.testbit).
+Qed.
+
+Lemma lxor_spec a a' n :
+ testbit (lxor a a') n = xorb (testbit a n) (testbit a' n).
+Proof.
+ destruct a, a'; simpl; trivial.
+ now destruct Pos.testbit.
+ now destruct Pos.testbit.
+ apply pos_lxor_spec.
+Qed.
+
+Lemma pos_lor_spec p p' n :
+ Pos.testbit (Pos.lor p p') n = (Pos.testbit p n) || (Pos.testbit p' n).
+Proof.
+ revert p' n.
+ induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
+  apply IH || now rewrite orb_false_r.
+Qed.
+
+Lemma lor_spec a a' n :
+ testbit (lor a a') n = (testbit a n) || (testbit a' n).
+Proof.
+ destruct a, a'; simpl; trivial.
+ now rewrite orb_false_r.
+ apply pos_lor_spec.
+Qed.
+
+Lemma pos_land_spec p p' n :
+ testbit (Pos.land p p') n = (Pos.testbit p n) && (Pos.testbit p' n).
+Proof.
+ revert p' n.
+ induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
+ (specialize (IH p'); destruct Pos.land; trivial; now rewrite <-IH) ||
+ (now rewrite andb_false_r).
+Qed.
+
+Lemma land_spec a a' n :
+ testbit (land a a') n = (testbit a n) && (testbit a' n).
+Proof.
+ destruct a, a'; simpl; trivial.
+ now rewrite andb_false_r.
+ apply pos_land_spec.
+Qed.
+
+Lemma pos_ldiff_spec p p' n :
+ testbit (Pos.ldiff p p') n = (Pos.testbit p n) && negb (Pos.testbit p' n).
+Proof.
+ revert p' n.
+ induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
+ (specialize (IH p'); destruct Pos.ldiff; trivial; now rewrite <-IH) ||
+ (now rewrite andb_true_r).
+Qed.
+
+Lemma ldiff_spec a a' n :
+ testbit (ldiff a a') n = (testbit a n) && negb (testbit a' n).
+Proof.
+ destruct a, a'; simpl; trivial.
+ now rewrite andb_true_r.
+ apply pos_ldiff_spec.
+Qed.
+
+(** Specification of constants *)
+
+Lemma one_succ : 1 = succ 0.
+Proof. reflexivity. Qed.
+
+Lemma two_succ : 2 = succ 1.
+Proof. reflexivity. Qed.
+
+Definition pred_0 : pred 0 = 0.
+Proof. reflexivity. Qed.
+
+(** Proofs of morphisms, obvious since eq is Leibniz *)
+
+Local Obligation Tactic := simpl_relation.
+Program Definition succ_wd : Proper (eq==>eq) succ := _.
+Program Definition pred_wd : Proper (eq==>eq) pred := _.
+Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
+Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
+Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
+Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
+Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
+Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
+Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
+Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
+
+(** Generic induction / recursion *)
+
+Theorem bi_induction :
+  forall A : N -> Prop, Proper (Logic.eq==>iff) A ->
+    A N0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n.
+Proof.
+intros A A_wd A0 AS. apply peano_rect. assumption. intros; now apply -> AS.
+Qed.
+
+Definition recursion {A} : A -> (N -> A -> A) -> N -> A :=
+  peano_rect (fun _ => A).
+
+Instance recursion_wd {A} (Aeq : relation A) :
+ Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion.
+Proof.
+intros a a' Ea f f' Ef x x' Ex. subst x'.
+induction x using peano_ind.
+trivial.
+unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef.
+Qed.
+
+Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a.
+Proof. reflexivity. Qed.
+
+Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A):
+ Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f ->
+  forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
+Proof.
+unfold recursion; intros a_wd f_wd n. induction n using peano_ind.
+rewrite peano_rect_succ. now apply f_wd.
+rewrite !peano_rect_succ in *. now apply f_wd.
+Qed.
+
+(** Instantiation of generic properties of natural numbers *)
+
+Include NProp
+ <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+(** Otherwise N stays associated with abstract_scope : (TODO FIX) *)
+Bind Scope N_scope with N.
+
+(** In generic statements, the predicates [lt] and [le] have been
+  favored, whereas [gt] and [ge] don't even exist in the abstract
+  layers. The use of [gt] and [ge] is hence not recommended. We provide
+  here the bare minimal results to related them with [lt] and [le]. *)
+
+Lemma gt_lt_iff n m : n > m <-> m < n.
+Proof.
+ unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
+Qed.
+
+Lemma gt_lt n m : n > m -> m < n.
+Proof.
+ apply gt_lt_iff.
+Qed.
+
+Lemma lt_gt n m : n < m -> m > n.
+Proof.
+ apply gt_lt_iff.
+Qed.
+
+Lemma ge_le_iff n m : n >= m <-> m <= n.
+Proof.
+ unfold le, ge. now rewrite compare_antisym, CompOpp_iff.
+Qed.
+
+Lemma ge_le n m : n >= m -> m <= n.
+Proof.
+ apply ge_le_iff.
+Qed.
+
+Lemma le_ge n m : n <= m -> m >= n.
+Proof.
+ apply ge_le_iff.
+Qed.
+
+(** Auxiliary results about right shift on positive numbers,
+    used in BinInt *)
+
+Lemma pos_pred_shiftl_low : forall p n m, m<n ->
+ testbit (Pos.pred_N (Pos.shiftl p n)) m = true.
+Proof.
+ induction n using peano_ind.
+ now destruct m.
+ intros m H. unfold Pos.shiftl.
+ destruct n as [|n]; simpl in *.
+ destruct m. now destruct p. elim (Pos.nlt_1_r _ H).
+ rewrite Pos.iter_succ. simpl.
+ set (u:=Pos.iter n xO p) in *; clearbody u.
+ destruct m as [|m]. now destruct u.
+ rewrite <- (IHn (Pos.pred_N m)).
+ rewrite <- (testbit_odd_succ _ (Pos.pred_N m)).
+ rewrite succ_pos_pred. now destruct u.
+ apply le_0_l.
+ apply succ_lt_mono. now rewrite succ_pos_pred.
+Qed.
+
+Lemma pos_pred_shiftl_high : forall p n m, n<=m ->
+ testbit (Pos.pred_N (Pos.shiftl p n)) m =
+ testbit (shiftl (Pos.pred_N p) n) m.
+Proof.
+ induction n using peano_ind; intros m H.
+ unfold shiftl. simpl. now destruct (Pos.pred_N p).
+ rewrite shiftl_succ_r.
+ destruct n as [|n].
+ destruct m as [|m]. now destruct H. now destruct p.
+ destruct m as [|m]. now destruct H.
+ rewrite <- (succ_pos_pred m).
+ rewrite double_spec, testbit_even_succ by apply le_0_l.
+ rewrite <- IHn.
+ rewrite testbit_succ_r_div2 by apply le_0_l.
+ f_equal. simpl. rewrite Pos.iter_succ.
+ now destruct (Pos.iter n xO p).
+ apply succ_le_mono. now rewrite succ_pos_pred.
+Qed.
+
+Lemma pred_div2_up p : Pos.pred_N (Pos.div2_up p) = div2 (Pos.pred_N p).
+Proof.
+ destruct p as [p|p| ]; trivial.
+ simpl. apply Pos.pred_N_succ.
+ destruct p; simpl; trivial.
+Qed.
+
+End N.
+
+(** Exportation of notations *)
+
+Infix "+" := N.add : N_scope.
+Infix "-" := N.sub : N_scope.
+Infix "*" := N.mul : N_scope.
+Infix "^" := N.pow : N_scope.
+
+Infix "?=" := N.compare (at level 70, no associativity) : N_scope.
+
+Infix "<=" := N.le : N_scope.
+Infix "<" := N.lt : N_scope.
+Infix ">=" := N.ge : N_scope.
+Infix ">" := N.gt : N_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : N_scope.
+Notation "x < y < z" := (x < y /\ y < z) : N_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : N_scope.
+
+Infix "=?" := N.eqb (at level 70, no associativity) : N_scope.
+Infix "<=?" := N.leb (at level 70, no associativity) : N_scope.
+Infix "<?" := N.ltb (at level 70, no associativity) : N_scope.
+
+Infix "/" := N.div : N_scope.
+Infix "mod" := N.modulo (at level 40, no associativity) : N_scope.
+
+Notation "( p | q )" := (N.divide p q) (at level 0) : N_scope.
+
+(** Compatibility notations *)
+
+(*Notation N := N (only parsing).*) (*hidden by module N above *)
+Notation N_rect := N_rect (only parsing).
+Notation N_rec := N_rec (only parsing).
+Notation N_ind := N_ind (only parsing).
+Notation N0 := N0 (only parsing).
+Notation Npos := Npos (only parsing).
+
+Notation Ndiscr := N.discr (only parsing).
+Notation Ndouble_plus_one := N.succ_double.
+Notation Ndouble := N.double (only parsing).
+Notation Nsucc := N.succ (only parsing).
+Notation Npred := N.pred (only parsing).
+Notation Nsucc_pos := N.succ_pos (only parsing).
+Notation Ppred_N := Pos.pred_N (only parsing).
+Notation Nplus := N.add (only parsing).
+Notation Nminus := N.sub (only parsing).
+Notation Nmult := N.mul (only parsing).
+Notation Neqb := N.eqb (only parsing).
+Notation Ncompare := N.compare (only parsing).
+Notation Nlt := N.lt (only parsing).
+Notation Ngt := N.gt (only parsing).
+Notation Nle := N.le (only parsing).
+Notation Nge := N.ge (only parsing).
+Notation Nmin := N.min (only parsing).
+Notation Nmax := N.max (only parsing).
+Notation Ndiv2 := N.div2 (only parsing).
+Notation Neven := N.even (only parsing).
+Notation Nodd := N.odd (only parsing).
+Notation Npow := N.pow (only parsing).
+Notation Nlog2 := N.log2 (only parsing).
+
+Notation nat_of_N := N.to_nat (only parsing).
+Notation N_of_nat := N.of_nat (only parsing).
+Notation N_eq_dec := N.eq_dec (only parsing).
+Notation Nrect := N.peano_rect (only parsing).
+Notation Nrect_base := N.peano_rect_base (only parsing).
+Notation Nrect_step := N.peano_rect_succ (only parsing).
+Notation Nind := N.peano_ind (only parsing).
+Notation Nrec := N.peano_rec (only parsing).
+Notation Nrec_base := N.peano_rec_base (only parsing).
+Notation Nrec_succ := N.peano_rec_succ (only parsing).
+
+Notation Npred_succ := N.pred_succ (only parsing).
+Notation Npred_minus := N.pred_sub (only parsing).
+Notation Nsucc_pred := N.succ_pred (only parsing).
+Notation Ppred_N_spec := N.pos_pred_spec (only parsing).
+Notation Nsucc_pos_spec := N.succ_pos_spec (only parsing).
+Notation Ppred_Nsucc := N.pos_pred_succ (only parsing).
+Notation Nplus_0_l := N.add_0_l (only parsing).
+Notation Nplus_0_r := N.add_0_r (only parsing).
+Notation Nplus_comm := N.add_comm (only parsing).
+Notation Nplus_assoc := N.add_assoc (only parsing).
+Notation Nplus_succ := N.add_succ_l (only parsing).
+Notation Nsucc_0 := N.succ_0_discr (only parsing).
+Notation Nsucc_inj := N.succ_inj (only parsing).
+Notation Nminus_N0_Nle := N.sub_0_le (only parsing).
+Notation Nminus_0_r := N.sub_0_r (only parsing).
+Notation Nminus_succ_r:= N.sub_succ_r (only parsing).
+Notation Nmult_0_l := N.mul_0_l (only parsing).
+Notation Nmult_1_l := N.mul_1_l (only parsing).
+Notation Nmult_1_r := N.mul_1_r (only parsing).
+Notation Nmult_comm := N.mul_comm (only parsing).
+Notation Nmult_assoc := N.mul_assoc (only parsing).
+Notation Nmult_plus_distr_r := N.mul_add_distr_r (only parsing).
+Notation Neqb_eq := N.eqb_eq (only parsing).
+Notation Nle_0 := N.le_0_l (only parsing).
+Notation Ncompare_refl := N.compare_refl (only parsing).
+Notation Ncompare_Eq_eq := N.compare_eq (only parsing).
+Notation Ncompare_eq_correct := N.compare_eq_iff (only parsing).
+Notation Nlt_irrefl := N.lt_irrefl (only parsing).
+Notation Nlt_trans := N.lt_trans (only parsing).
+Notation Nle_lteq := N.lt_eq_cases (only parsing).
+Notation Nlt_succ_r := N.lt_succ_r (only parsing).
+Notation Nle_trans := N.le_trans (only parsing).
+Notation Nle_succ_l := N.le_succ_l (only parsing).
+Notation Ncompare_spec := N.compare_spec (only parsing).
+Notation Ncompare_0 := N.compare_0_r (only parsing).
+Notation Ndouble_div2 := N.div2_double (only parsing).
+Notation Ndouble_plus_one_div2 := N.div2_succ_double (only parsing).
+Notation Ndouble_inj := N.double_inj (only parsing).
+Notation Ndouble_plus_one_inj := N.succ_double_inj (only parsing).
+Notation Npow_0_r := N.pow_0_r (only parsing).
+Notation Npow_succ_r := N.pow_succ_r (only parsing).
+Notation Nlog2_spec := N.log2_spec (only parsing).
+Notation Nlog2_nonpos := N.log2_nonpos (only parsing).
+Notation Neven_spec := N.even_spec (only parsing).
+Notation Nodd_spec := N.odd_spec (only parsing).
+Notation Nlt_not_eq := N.lt_neq (only parsing).
+Notation Ngt_Nlt := N.gt_lt (only parsing).
+
+(** More complex compatibility facts, expressed as lemmas
+    (to preserve scopes for instance) *)
+
+Lemma Nplus_reg_l n m p : n + m = n + p -> m = p.
+Proof (proj1 (N.add_cancel_l m p n)).
+Lemma Nmult_Sn_m n m : N.succ n * m = m + n * m.
+Proof (eq_trans (N.mul_succ_l n m) (N.add_comm _ _)).
+Lemma Nmult_plus_distr_l n m p : p * (n + m) = p * n + p * m.
+Proof (N.mul_add_distr_l p n m).
+Lemma Nmult_reg_r n m p : p <> 0 -> n * p = m * p -> n = m.
+Proof (fun H => proj1 (N.mul_cancel_r n m p H)).
+Lemma Ncompare_antisym n m : CompOpp (n ?= m) = (m ?= n).
+Proof (eq_sym (N.compare_antisym n m)).
+
+Definition N_ind_double a P f0 f2 fS2 := N.binary_ind P f0 f2 fS2 a.
+Definition N_rec_double a P f0 f2 fS2 := N.binary_rec P f0 f2 fS2 a.
+
+(** Not kept : Ncompare_n_Sm Nplus_lt_cancel_l *)
diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v
new file mode 100644
index 00000000..d7660422
--- /dev/null
+++ b/theories/NArith/BinNatDef.v
@@ -0,0 +1,381 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export BinNums.
+Require Import BinPos.
+
+Local Open Scope N_scope.
+
+(**********************************************************************)
+(** * Binary natural numbers, definitions of operations *)
+(**********************************************************************)
+
+Module N.
+
+Definition t := N.
+
+(** ** Constants *)
+
+Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
+
+(** ** Operation [x -> 2*x+1] *)
+
+Definition succ_double x :=
+  match x with
+  | 0 => 1
+  | Npos p => Npos p~1
+  end.
+
+(** ** Operation [x -> 2*x] *)
+
+Definition double n :=
+  match n with
+  | 0 => 0
+  | Npos p => Npos p~0
+  end.
+
+(** ** Successor *)
+
+Definition succ n :=
+  match n with
+  | 0 => 1
+  | Npos p => Npos (Pos.succ p)
+  end.
+
+(** ** Predecessor *)
+
+Definition pred n :=
+  match n with
+  | 0 => 0
+  | Npos p => Pos.pred_N p
+  end.
+
+(** ** The successor of a [N] can be seen as a [positive] *)
+
+Definition succ_pos (n : N) : positive :=
+ match n with
+   | N0 => 1%positive
+   | Npos p => Pos.succ p
+ end.
+
+(** ** Addition *)
+
+Definition add n m :=
+  match n, m with
+  | 0, _ => m
+  | _, 0 => n
+  | Npos p, Npos q => Npos (p + q)
+  end.
+
+Infix "+" := add : N_scope.
+
+(** Subtraction *)
+
+Definition sub n m :=
+match n, m with
+| 0, _ => 0
+| n, 0 => n
+| Npos n', Npos m' =>
+  match Pos.sub_mask n' m' with
+  | IsPos p => Npos p
+  | _ => 0
+  end
+end.
+
+Infix "-" := sub : N_scope.
+
+(** Multiplication *)
+
+Definition mul n m :=
+  match n, m with
+  | 0, _ => 0
+  | _, 0 => 0
+  | Npos p, Npos q => Npos (p * q)
+  end.
+
+Infix "*" := mul : N_scope.
+
+(** Order *)
+
+Definition compare n m :=
+  match n, m with
+  | 0, 0 => Eq
+  | 0, Npos m' => Lt
+  | Npos n', 0 => Gt
+  | Npos n', Npos m' => (n' ?= m')%positive
+  end.
+
+Infix "?=" := compare (at level 70, no associativity) : N_scope.
+
+(** Boolean equality and comparison *)
+
+(** Nota: this [eqb] is not convertible with the generated [N_beq],
+    since the underlying [Pos.eqb] differs from [positive_beq]
+    (cf BinIntDef). *)
+
+Fixpoint eqb n m :=
+  match n, m with
+    | 0, 0 => true
+    | Npos p, Npos q => Pos.eqb p q
+    | _, _ => false
+  end.
+
+Definition leb x y :=
+ match x ?= y with Gt => false | _ => true end.
+
+Definition ltb x y :=
+ match x ?= y with Lt => true | _ => false end.
+
+Infix "=?" := eqb (at level 70, no associativity) : N_scope.
+Infix "<=?" := leb (at level 70, no associativity) : N_scope.
+Infix "<?" := ltb (at level 70, no associativity) : N_scope.
+
+(** Min and max *)
+
+Definition min n n' := match n ?= n' with
+ | Lt | Eq => n
+ | Gt => n'
+ end.
+
+Definition max n n' := match n ?= n' with
+ | Lt | Eq => n'
+ | Gt => n
+ end.
+
+(** Dividing by 2 *)
+
+Definition div2 n :=
+  match n with
+  | 0 => 0
+  | 1 => 0
+  | Npos (p~0) => Npos p
+  | Npos (p~1) => Npos p
+  end.
+
+(** Parity *)
+
+Definition even n :=
+  match n with
+    | 0 => true
+    | Npos (xO _) => true
+    | _ => false
+  end.
+
+Definition odd n := negb (even n).
+
+(** Power *)
+
+Definition pow n p :=
+  match p, n with
+    | 0, _ => 1
+    | _, 0 => 0
+    | Npos p, Npos q => Npos (q^p)
+  end.
+
+Infix "^" := pow : N_scope.
+
+(** Square *)
+
+Definition square n :=
+  match n with
+    | 0 => 0
+    | Npos p => Npos (Pos.square p)
+  end.
+
+(** Base-2 logarithm *)
+
+Definition log2 n :=
+ match n with
+   | 0 => 0
+   | 1 => 0
+   | Npos (p~0) => Npos (Pos.size p)
+   | Npos (p~1) => Npos (Pos.size p)
+ end.
+
+(** How many digits in a number ?
+    Number 0 is said to have no digits at all.
+*)
+
+Definition size n :=
+ match n with
+  | 0 => 0
+  | Npos p => Npos (Pos.size p)
+ end.
+
+Definition size_nat n :=
+ match n with
+  | 0 => O
+  | Npos p => Pos.size_nat p
+ end.
+
+(** Euclidean division *)
+
+Fixpoint pos_div_eucl (a:positive)(b:N) : N * N :=
+  match a with
+    | xH =>
+       match b with 1 => (1,0) | _ => (0,1) end
+    | xO a' =>
+       let (q, r) := pos_div_eucl a' b in
+       let r' := double r in
+       if b <=? r' then (succ_double q, r' - b)
+        else (double q, r')
+    | xI a' =>
+       let (q, r) := pos_div_eucl a' b in
+       let r' := succ_double r in
+       if b <=? r' then (succ_double q, r' - b)
+        else  (double q, r')
+  end.
+
+Definition div_eucl (a b:N) : N * N :=
+  match a, b with
+   | 0,  _ => (0, 0)
+   | _, 0  => (0, a)
+   | Npos na, _ => pos_div_eucl na b
+  end.
+
+Definition div a b := fst (div_eucl a b).
+Definition modulo a b := snd (div_eucl a b).
+
+Infix "/" := div : N_scope.
+Infix "mod" := modulo (at level 40, no associativity) : N_scope.
+
+(** Greatest common divisor *)
+
+Definition gcd a b :=
+ match a, b with
+  | 0, _ => b
+  | _, 0 => a
+  | Npos p, Npos q => Npos (Pos.gcd p q)
+ end.
+
+(** Generalized Gcd, also computing rests of [a] and [b] after
+    division by gcd. *)
+
+Definition ggcd a b :=
+ match a, b with
+  | 0, _ => (b,(0,1))
+  | _, 0 => (a,(1,0))
+  | Npos p, Npos q =>
+     let '(g,(aa,bb)) := Pos.ggcd p q in
+     (Npos g, (Npos aa, Npos bb))
+ end.
+
+(** Square root *)
+
+Definition sqrtrem n :=
+ match n with
+  | 0 => (0, 0)
+  | Npos p =>
+    match Pos.sqrtrem p with
+     | (s, IsPos r) => (Npos s, Npos r)
+     | (s, _) => (Npos s, 0)
+    end
+ end.
+
+Definition sqrt n :=
+ match n with
+  | 0 => 0
+  | Npos p => Npos (Pos.sqrt p)
+ end.
+
+(** Operation over bits of a [N] number. *)
+
+(** Logical [or] *)
+
+Definition lor n m :=
+ match n, m with
+   | 0, _ => m
+   | _, 0 => n
+   | Npos p, Npos q => Npos (Pos.lor p q)
+ end.
+
+(** Logical [and] *)
+
+Definition land n m :=
+ match n, m with
+  | 0, _ => 0
+  | _, 0 => 0
+  | Npos p, Npos q => Pos.land p q
+ end.
+
+(** Logical [diff] *)
+
+Fixpoint ldiff n m :=
+ match n, m with
+  | 0, _ => 0
+  | _, 0 => n
+  | Npos p, Npos q => Pos.ldiff p q
+ end.
+
+(** [xor] *)
+
+Definition lxor n m :=
+  match n, m with
+    | 0, _ => m
+    | _, 0 => n
+    | Npos p, Npos q => Pos.lxor p q
+  end.
+
+(** Shifts *)
+
+Definition shiftl_nat (a:N)(n:nat) := nat_iter n double a.
+Definition shiftr_nat (a:N)(n:nat) := nat_iter n div2 a.
+
+Definition shiftl a n :=
+  match a with
+    | 0 => 0
+    | Npos a => Npos (Pos.shiftl a n)
+  end.
+
+Definition shiftr a n :=
+  match n with
+    | 0 => a
+    | Npos p => Pos.iter p div2 a
+  end.
+
+(** Checking whether a particular bit is set or not *)
+
+Definition testbit_nat (a:N) :=
+  match a with
+    | 0 => fun _ => false
+    | Npos p => Pos.testbit_nat p
+  end.
+
+(** Same, but with index in N *)
+
+Definition testbit a n :=
+  match a with
+    | 0 => false
+    | Npos p => Pos.testbit p n
+  end.
+
+(** Translation from [N] to [nat] and back. *)
+
+Definition to_nat (a:N) :=
+  match a with
+    | 0 => O
+    | Npos p => Pos.to_nat p
+  end.
+
+Definition of_nat (n:nat) :=
+  match n with
+    | O => 0
+    | S n' => Npos (Pos.of_succ_nat n')
+  end.
+
+(** Iteration of a function *)
+
+Definition iter (n:N) {A} (f:A->A) (x:A) : A :=
+  match n with
+    | 0 => x
+    | Npos p => Pos.iter p f x
+  end.
+
+End N.
\ No newline at end of file
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
deleted file mode 100644
index 62bd57c0..00000000
--- a/theories/NArith/BinPos.v
+++ /dev/null
@@ -1,1172 +0,0 @@
-(* -*- coding: utf-8 -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: BinPos.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Unset Boxed Definitions.
-
-Declare ML Module "z_syntax_plugin".
-
-(**********************************************************************)
-(** Binary positive numbers *)
-
-(** Original development by Pierre Crégut, CNET, Lannion, France *)
-
-Inductive positive : Set :=
-| xI : positive -> positive
-| xO : positive -> positive
-| xH : positive.
-
-(** Declare binding key for scope positive_scope *)
-
-Delimit Scope positive_scope with positive.
-
-(** Automatically open scope positive_scope for type positive, xO and xI *)
-
-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))
-    for the number 6 (which is 110 in binary notation).
-*)
-
-Notation "p ~ 1" := (xI p)
- (at level 7, left associativity, format "p '~' '1'") : positive_scope.
-Notation "p ~ 0" := (xO p)
- (at level 7, left associativity, format "p '~' '0'") : positive_scope.
-
-Open Local Scope positive_scope.
-
-(* In the current file, [xH] cannot yet be written as [1], since the
-   interpretation of positive numerical constants is not available
-   yet. We fix this here with an ad-hoc temporary notation. *)
-
-Notation Local "1" := xH (at level 7).
-
-(** Successor *)
-
-Fixpoint Psucc (x:positive) : positive :=
-  match x with
-    | p~1 => (Psucc p)~0
-    | p~0 => p~1
-    | 1 => 1~0
-  end.
-
-(** Addition *)
-
-Set Boxed Definitions.
-
-Fixpoint Pplus (x y:positive) : positive :=
-  match x, y with
-    | p~1, q~1 => (Pplus_carry p q)~0
-    | p~1, q~0 => (Pplus p q)~1
-    | p~1, 1 => (Psucc p)~0
-    | p~0, q~1 => (Pplus p q)~1
-    | p~0, q~0 => (Pplus p q)~0
-    | p~0, 1 => p~1
-    | 1, q~1 => (Psucc q)~0
-    | 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
-    | p~1, q~0 => (Pplus_carry p q)~0
-    | p~1, 1 => (Psucc p)~1
-    | p~0, q~1 => (Pplus_carry p q)~0
-    | p~0, q~0 => (Pplus p q)~1
-    | p~0, 1 => (Psucc p)~0
-    | 1, q~1 => (Psucc q)~1
-    | 1, q~0 => (Psucc q)~0
-    | 1, 1 => 1~1
-  end.
-
-Unset Boxed Definitions.
-
-Infix "+" := Pplus : positive_scope.
-
-(** From binary positive numbers to Peano natural numbers *)
-
-Fixpoint Pmult_nat (x:positive) (pow2:nat) : nat :=
-  match x with
-    | p~1 => (pow2 + Pmult_nat p (pow2 + pow2))%nat
-    | p~0 => Pmult_nat p (pow2 + pow2)%nat
-    | 1 => pow2
-  end.
-
-Definition nat_of_P (x:positive) := Pmult_nat x (S O).
-
-(** From Peano natural numbers to binary positive numbers *)
-
-Fixpoint P_of_succ_nat (n:nat) : positive :=
-  match n with
-    | O => 1
-    | S x => Psucc (P_of_succ_nat x)
-  end.
-
-(** Operation x -> 2*x-1 *)
-
-Fixpoint Pdouble_minus_one (x:positive) : positive :=
-  match x with
-    | p~1 => p~0~1
-    | p~0 => (Pdouble_minus_one p)~1
-    | 1 => 1
-  end.
-
-(** Predecessor *)
-
-Definition Ppred (x:positive) :=
-  match x with
-    | p~1 => p~0
-    | p~0 => Pdouble_minus_one p
-    | 1 => 1
-  end.
-
-(** An auxiliary type for subtraction *)
-
-Inductive positive_mask : Set :=
-| IsNul : positive_mask
-| IsPos : positive -> positive_mask
-| IsNeg : positive_mask.
-
-(** Operation x -> 2*x+1 *)
-
-Definition Pdouble_plus_one_mask (x:positive_mask) :=
-  match x with
-    | IsNul => IsPos 1
-    | IsNeg => IsNeg
-    | IsPos p => IsPos p~1
-  end.
-
-(** Operation x -> 2*x *)
-
-Definition Pdouble_mask (x:positive_mask) :=
-  match x with
-    | IsNul => IsNul
-    | IsNeg => IsNeg
-    | IsPos p => IsPos p~0
-  end.
-
-(** Operation x -> 2*x-2 *)
-
-Definition Pdouble_minus_two (x:positive) :=
-  match x with
-    | p~1 => IsPos p~0~0
-    | p~0 => IsPos (Pdouble_minus_one p)~0
-    | 1 => IsNul
-  end.
-
-(** Subtraction of binary positive numbers into a positive numbers mask *)
-
-Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask :=
-  match x, y with
-    | p~1, q~1 => Pdouble_mask (Pminus_mask p q)
-    | p~1, q~0 => Pdouble_plus_one_mask (Pminus_mask p q)
-    | p~1, 1 => IsPos p~0
-    | p~0, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q)
-    | p~0, q~0 => Pdouble_mask (Pminus_mask p q)
-    | p~0, 1 => IsPos (Pdouble_minus_one p)
-    | 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)
-    | p~1, q~0 => Pdouble_mask (Pminus_mask p q)
-    | p~1, 1 => IsPos (Pdouble_minus_one p)
-    | p~0, q~1 => Pdouble_mask (Pminus_mask_carry p q)
-    | p~0, q~0 => Pdouble_plus_one_mask (Pminus_mask_carry p q)
-    | p~0, 1 => Pdouble_minus_two p
-    | 1, _ => IsNeg
-  end.
-
-(** Subtraction of binary positive numbers x and y, returns 1 if x<=y *)
-
-Definition Pminus (x y:positive) :=
-  match Pminus_mask x y with
-    | IsPos z => z
-    | _ => 1
-  end.
-
-Infix "-" := Pminus : positive_scope.
-
-(** Multiplication on binary positive numbers *)
-
-Fixpoint Pmult (x y:positive) : positive :=
-  match x with
-    | p~1 => y + (Pmult p y)~0
-    | p~0 => (Pmult p y)~0
-    | 1 => y
-  end.
-
-Infix "*" := Pmult : positive_scope.
-
-(** Division by 2 rounded below but for 1 *)
-
-Definition Pdiv2 (z:positive) :=
-  match z with
-    | 1 => 1
-    | p~0 => p
-    | p~1 => p
-  end.
-
-Infix "/" := Pdiv2 : positive_scope.
-
-(** Comparison on binary positive numbers *)
-
-Fixpoint Pcompare (x y:positive) (r:comparison) {struct y} : comparison :=
-  match x, y with
-    | p~1, q~1 => Pcompare p q r
-    | p~1, q~0 => Pcompare p q Gt
-    | p~1, 1 => Gt
-    | p~0, q~1 => Pcompare p q Lt
-    | p~0, q~0 => Pcompare p q r
-    | p~0, 1 => Gt
-    | 1, q~1 => Lt
-    | 1, q~0 => Lt
-    | 1, 1 => r
-  end.
-
-Infix "?=" := Pcompare (at level 70, no associativity) : positive_scope.
-
-Definition Plt (x y:positive) := (Pcompare x y Eq) = Lt.
-Definition Pgt (x y:positive) := (Pcompare x y Eq) = Gt.
-Definition Ple (x y:positive) := (Pcompare x y Eq) <> Gt.
-Definition Pge (x y:positive) := (Pcompare x y Eq) <> Lt.
-
-Infix "<=" := Ple : positive_scope.
-Infix "<" := Plt : positive_scope.
-Infix ">=" := Pge : positive_scope.
-Infix ">" := Pgt : positive_scope.
-
-Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope.
-Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope.
-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
- | Gt => p'
- end.
-
-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.
-
-(**********************************************************************)
-(** Decidability of equality on binary positive numbers *)
-
-Lemma positive_eq_dec : forall x y: positive, {x = y} + {x <> y}.
-Proof.
-  decide equality.
-Defined.
-
-(* begin hide *)
-Corollary ZL11 : forall p:positive, p = 1 \/ p <> 1.
-Proof.
-  intro; edestruct positive_eq_dec; eauto.
-Qed.
-(* end hide *)
-
-(**********************************************************************)
-(** Properties of successor on binary positive numbers *)
-
-(** Specification of [xI] in term of [Psucc] and [xO] *)
-
-Lemma xI_succ_xO : forall p:positive, p~1 = Psucc p~0.
-Proof.
-  reflexivity.
-Qed.
-
-Lemma Psucc_discr : forall p:positive, p <> Psucc p.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-(** Successor and double *)
-
-Lemma Psucc_o_double_minus_one_eq_xO :
-  forall p:positive, Psucc (Pdouble_minus_one p) = p~0.
-Proof.
-  induction p; simpl; f_equal; auto.
-Qed.
-
-Lemma Pdouble_minus_one_o_succ_eq_xI :
-  forall p:positive, Pdouble_minus_one (Psucc p) = p~1.
-Proof.
-  induction p; simpl; f_equal; auto.
-Qed.
-
-Lemma xO_succ_permute :
-  forall p:positive, (Psucc p)~0 = Psucc (Psucc p~0).
-Proof.
-  induction p; simpl; auto.
-Qed.
-
-Lemma double_moins_un_xO_discr :
-  forall p:positive, Pdouble_minus_one p <> p~0.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-(** Successor and predecessor *)
-
-Lemma Psucc_not_one : forall p:positive, Psucc p <> 1.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-Lemma Ppred_succ : forall p:positive, Ppred (Psucc p) = p.
-Proof.
-  intros [[p|p| ]|[p|p| ]| ]; simpl; auto.
-  f_equal; apply Pdouble_minus_one_o_succ_eq_xI.
-Qed.
-
-Lemma Psucc_pred : forall p:positive, p = 1 \/ Psucc (Ppred p) = p.
-Proof.
-  induction p; simpl; auto.
-  right; apply Psucc_o_double_minus_one_eq_xO.
-Qed.
-
-Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)).
-
-(** Injectivity of successor *)
-
-Lemma Psucc_inj : forall p q:positive, Psucc p = Psucc q -> p = q.
-Proof.
-  induction p; intros [q|q| ] H; simpl in *; destr_eq H; f_equal; auto.
-  elim (Psucc_not_one p); auto.
-  elim (Psucc_not_one q); auto.
-Qed.
-
-(**********************************************************************)
-(** Properties of addition on binary positive numbers *)
-
-(** Specification of [Psucc] in term of [Pplus] *)
-
-Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + 1.
-Proof.
-  destruct p; reflexivity.
-Qed.
-
-Lemma Pplus_one_succ_l : forall p:positive, Psucc p = 1 + p.
-Proof.
-  destruct p; reflexivity.
-Qed.
-
-(** Specification of [Pplus_carry] *)
-
-Theorem Pplus_carry_spec :
-  forall p q:positive, Pplus_carry p q = Psucc (p + q).
-Proof.
-  induction p; destruct q; simpl; f_equal; auto.
-Qed.
-
-(** Commutativity *)
-
-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.
-
-(** 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;
-   auto using Pplus_one_succ_r; rewrite Pplus_carry_spec; auto.
-Qed.
-
-Theorem Pplus_succ_permute_l :
-  forall p q:positive, Psucc p + q = Psucc (p + q).
-Proof.
-  intros p q; rewrite Pplus_comm, (Pplus_comm p);
-    apply Pplus_succ_permute_r.
-Qed.
-
-Theorem Pplus_carry_pred_eq_plus :
-  forall p q:positive, q <> 1 -> Pplus_carry p (Ppred q) = p + q.
-Proof.
-  intros p q H; rewrite Pplus_carry_spec, <- Pplus_succ_permute_r; f_equal.
-  destruct (Psucc_pred q); [ elim H; assumption | assumption ].
-Qed.
-
-(** No neutral for addition on strictly positive numbers *)
-
-Lemma Pplus_no_neutral : forall p q:positive, q + p <> p.
-Proof.
-  induction p as [p IHp|p IHp| ]; intros [q|q| ] H;
-   destr_eq H; apply (IHp q H).
-Qed.
-
-Lemma Pplus_carry_no_neutral :
-  forall p q:positive, Pplus_carry q p <> Psucc p.
-Proof.
-  intros p q H; elim (Pplus_no_neutral p q).
-  apply Psucc_inj; rewrite <- Pplus_carry_spec; assumption.
-Qed.
-
-(** Simplification *)
-
-Lemma Pplus_carry_plus :
-  forall p q r s:positive, Pplus_carry p r = Pplus_carry q s -> p + r = q + s.
-Proof.
-  intros p q r s H; apply Psucc_inj; do 2 rewrite <- Pplus_carry_spec;
-    assumption.
-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;
-    contradict H; auto using Pplus_carry_no_neutral.
-  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.
-
-Lemma Pplus_reg_l : forall p q r:positive, p + q = p + r -> q = r.
-Proof.
-  intros p q r H; apply Pplus_reg_r with (r:=p).
-  rewrite (Pplus_comm r), (Pplus_comm q); assumption.
-Qed.
-
-Lemma Pplus_carry_reg_r :
-  forall p q r:positive, Pplus_carry p r = Pplus_carry q r -> p = q.
-Proof.
-  intros p q r H; apply Pplus_reg_r with (r:=r); apply Pplus_carry_plus;
-    assumption.
-Qed.
-
-Lemma Pplus_carry_reg_l :
-  forall p q r:positive, Pplus_carry p q = Pplus_carry p r -> q = r.
-Proof.
-  intros p q r H; apply Pplus_reg_r with (r:=p);
-  rewrite (Pplus_comm r), (Pplus_comm q); apply Pplus_carry_plus; assumption.
-Qed.
-
-(** Addition on positive is associative *)
-
-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,
-     ?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,
-     ?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.
-
-(** Commutation of addition with the double of a positive number *)
-
-Lemma Pplus_xO : forall m n : positive, (m + n)~0 = m~0 + n~0.
-Proof.
-  destruct n; destruct m; simpl; auto.
-Qed.
-
-Lemma Pplus_xI_double_minus_one :
-  forall p q:positive, (p + q)~0 = p~1 + Pdouble_minus_one q.
-Proof.
-  intros; change (p~1) with (p~0 + 1).
-  rewrite <- Pplus_assoc, <- Pplus_one_succ_l, Psucc_o_double_minus_one_eq_xO.
-  reflexivity.
-Qed.
-
-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,
-    ?Pplus_xI_double_minus_one; try reflexivity.
-  rewrite IHp; auto.
-  rewrite <- Psucc_o_double_minus_one_eq_xO, Pplus_one_succ_l; reflexivity.
-Qed.
-
-(** Misc *)
-
-Lemma Pplus_diag : forall p:positive, p + p = p~0.
-Proof.
-  induction p as [p IHp| p IHp| ]; simpl;
-   try rewrite ?Pplus_carry_spec, ?IHp; reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Peano induction and recursion on binary positive positive numbers *)
-(** (a nice proof from Conor McBride, see "The view from the left")   *)
-
-Inductive PeanoView : positive -> Type :=
-| PeanoOne : PeanoView 1
-| PeanoSucc : forall p, PeanoView p -> PeanoView (Psucc p).
-
-Fixpoint peanoView_xO p (q:PeanoView p) : PeanoView (p~0) :=
-  match q in PeanoView x return PeanoView (x~0) with
-    | PeanoOne => PeanoSucc _ PeanoOne
-    | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xO _ q))
-  end.
-
-Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) :=
-  match q in PeanoView x return PeanoView (x~1) with
-    | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne)
-    | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q))
-  end.
-
-Fixpoint peanoView p : PeanoView p :=
-  match p return PeanoView p with
-    | 1 => PeanoOne
-    | p~0 => peanoView_xO p (peanoView p)
-    | p~1 => peanoView_xI p (peanoView p)
-  end.
-
-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
-      | PeanoOne => a
-      | PeanoSucc _ q => f _ (iter _ q)
-    end).
-
-Require Import Eqdep_dec EqdepFacts.
-
-Theorem eq_dep_eq_positive :
-  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'.
-Proof.
-  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'.
-  intro. destruct p; discriminate.
-  intro. unfold p0 in H. apply Psucc_inj in H.
-  generalize q'. rewrite H. intro.
-  rewrite (IHq q'0).
-  trivial.
-  trivial.
-Qed.
-
-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),
-  Prect P a f (Psucc p) = f _ (Prect P a f p).
-Proof.
-  intros.
-  unfold Prect.
-  rewrite (PeanoViewUnique _ (peanoView (Psucc p)) (PeanoSucc _ (peanoView p))).
-  trivial.
-Qed.
-
-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.
-Qed.
-
-Definition Prec (P:positive->Set) := Prect P.
-
-(** Peano induction *)
-
-Definition Pind (P:positive->Prop) := Prect P.
-
-(** Peano case analysis *)
-
-Theorem Pcase :
-  forall P:positive -> Prop,
-    P 1 -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p.
-Proof.
-  intros; apply Pind; auto.
-Qed.
-
-(**********************************************************************)
-(** Properties of multiplication on binary positive numbers *)
-
-(** One is right neutral for multiplication *)
-
-Lemma Pmult_1_r : forall p:positive, p * 1 = p.
-Proof.
-  induction p; simpl; f_equal; auto.
-Qed.
-
-(** Successor and multiplication *)
-
-Lemma Pmult_Sn_m : forall n m : positive, (Psucc n) * m = m + n * m.
-Proof.
-  induction n as [n IHn | n IHn | ]; simpl; intro m.
-  rewrite IHn, Pplus_assoc, Pplus_diag, <-Pplus_xO; reflexivity.
-  reflexivity.
-  symmetry; apply Pplus_diag.
-Qed.
-
-(** Right reduction properties for multiplication *)
-
-Lemma Pmult_xO_permute_r : forall p q:positive, p * q~0 = (p * q)~0.
-Proof.
-  intros p q; induction p; simpl; do 2 (f_equal; auto).
-Qed.
-
-Lemma Pmult_xI_permute_r : forall p q:positive, p * q~1 = p + (p * q)~0.
-Proof.
-  intros p q; induction p as [p IHp|p IHp| ]; simpl; f_equal; auto.
-  rewrite IHp, 2 Pplus_assoc, (Pplus_comm p); reflexivity.
-Qed.
-
-(** Commutativity of multiplication *)
-
-Theorem Pmult_comm : forall p q:positive, p * q = q * p.
-Proof.
-  intros p q; induction q as [q IHq|q IHq| ]; simpl; try rewrite <- IHq;
-   auto using Pmult_xI_permute_r, Pmult_xO_permute_r, Pmult_1_r.
-Qed.
-
-(** Distributivity of multiplication over addition *)
-
-Theorem Pmult_plus_distr_l :
-  forall p q r:positive, p * (q + r) = p * q + p * r.
-Proof.
-  intros p q r; induction p as [p IHp|p IHp| ]; simpl.
-  rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0).
-  change ((p*q+p*r)~0) with (m+n).
-  rewrite 2 Pplus_assoc; f_equal.
-  rewrite <- 2 Pplus_assoc; f_equal.
-  apply Pplus_comm.
-  f_equal; auto.
-  reflexivity.
-Qed.
-
-Theorem Pmult_plus_distr_r :
-  forall p q r:positive, (p + q) * r = p * r + q * r.
-Proof.
-  intros p q r; do 3 rewrite Pmult_comm with (q:=r); apply Pmult_plus_distr_l.
-Qed.
-
-(** Associativity of multiplication *)
-
-Theorem Pmult_assoc : forall p q r:positive, p * (q * r) = p * q * r.
-Proof.
-  induction p as [p IHp| p IHp | ]; simpl; intros q r.
-  rewrite IHp; rewrite Pmult_plus_distr_r; reflexivity.
-  rewrite IHp; reflexivity.
-  reflexivity.
-Qed.
-
-(** Parity properties of multiplication *)
-
-Lemma Pmult_xI_mult_xO_discr : forall p q r:positive, p~1 * r <> q~0 * r.
-Proof.
-  intros p q r; induction r; try discriminate.
-  rewrite 2 Pmult_xO_permute_r; intro H; destr_eq H; auto.
-Qed.
-
-Lemma Pmult_xO_discr : forall p q:positive, p~0 * q <> q.
-Proof.
-  intros p q; induction q; try discriminate.
-  rewrite Pmult_xO_permute_r; injection; assumption.
-Qed.
-
-(** Simplification properties of multiplication *)
-
-Theorem Pmult_reg_r : forall p q r:positive, p * r = q * r -> p = q.
-Proof.
-  induction p as [p IHp| p IHp| ]; intros [q|q| ] r H;
-    reflexivity || apply (f_equal (A:=positive)) || apply False_ind.
-  apply IHp with (r~0); simpl in *;
-    rewrite 2 Pmult_xO_permute_r; apply Pplus_reg_l with (1:=H).
-  apply Pmult_xI_mult_xO_discr with (1:=H).
-  simpl in H; rewrite Pplus_comm in H; apply Pplus_no_neutral with (1:=H).
-  symmetry in H; apply Pmult_xI_mult_xO_discr with (1:=H).
-  apply IHp with (r~0); simpl; rewrite 2 Pmult_xO_permute_r; assumption.
-  apply Pmult_xO_discr with (1:= H).
-  simpl in H; symmetry in H; rewrite Pplus_comm in H;
-    apply Pplus_no_neutral with (1:=H).
-  symmetry in H; apply Pmult_xO_discr with (1:=H).
-Qed.
-
-Theorem Pmult_reg_l : forall p q r:positive, r * p = r * q -> p = q.
-Proof.
-  intros p q r H; apply Pmult_reg_r with (r:=r).
-  rewrite (Pmult_comm p), (Pmult_comm q); assumption.
-Qed.
-
-(** Inversion of multiplication *)
-
-Lemma Pmult_1_inversion_l : forall p q:positive, p * q = 1 -> p = 1.
-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 *)
-
-Theorem Pcompare_refl : forall p:positive, (p ?= p) Eq = Eq.
-  induction p; auto.
-Qed.
-
-(* A generalization of Pcompare_refl *)
-
-Theorem Pcompare_refl_id : forall (p : positive) (r : comparison), (p ?= p) r = r.
-  induction p; auto.
-Qed.
-
-Theorem Pcompare_not_Eq :
-  forall p q:positive, (p ?= q) Gt <> Eq /\ (p ?= q) Lt <> Eq.
-Proof.
-  induction p as [p IHp| p IHp| ]; intros [q| q| ]; split; simpl; auto;
-    discriminate || (elim (IHp q); auto).
-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;
-   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.
-  induction p; intros [q|q| ] H; simpl; auto; discriminate.
-Qed.
-
-Lemma Pcompare_eq_Lt :
-  forall p q : positive, (p ?= q) Eq = Lt <-> (p ?= q) Gt = Lt.
-Proof.
-  intros p q; split; [| apply Pcompare_Gt_Lt].
-  revert q; induction p; intros [q|q| ] H; simpl; auto; discriminate.
-Qed.
-
-Lemma Pcompare_Lt_Gt :
-  forall p q:positive, (p ?= q) Lt = Gt -> (p ?= q) Eq = Gt.
-Proof.
-  induction p; intros [q|q| ] H; simpl; auto; discriminate.
-Qed.
-
-Lemma Pcompare_eq_Gt :
-  forall p q : positive, (p ?= q) Eq = Gt <-> (p ?= q) Lt = Gt.
-Proof.
-  intros p q; split; [| apply Pcompare_Lt_Gt].
-  revert q; induction p; intros [q|q| ] H; simpl; auto; discriminate.
-Qed.
-
-Lemma Pcompare_Lt_Lt :
-  forall p q:positive, (p ?= q) Lt = Lt -> (p ?= q) Eq = Lt \/ p = q.
-Proof.
-  induction p as [p IHp| p IHp| ]; intros [q|q| ] H; simpl in *; auto;
-   destruct (IHp q H); subst; auto.
-Qed.
-
-Lemma Pcompare_Lt_eq_Lt :
-  forall p q:positive, (p ?= q) Lt = Lt <-> (p ?= q) Eq = Lt \/ p = q.
-Proof.
-  intros p q; split; [apply Pcompare_Lt_Lt |].
-  intros [H|H]; [|subst; apply Pcompare_refl_id].
-  revert q H; induction p; intros [q|q| ] H; simpl in *;
-  auto; discriminate.
-Qed.
-
-Lemma Pcompare_Gt_Gt :
-  forall p q:positive, (p ?= q) Gt = Gt -> (p ?= q) Eq = Gt \/ p = q.
-Proof.
-  induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto;
-    destruct (IHp q H); subst; auto.
-Qed.
-
-Lemma Pcompare_Gt_eq_Gt :
-  forall p q:positive, (p ?= q) Gt = Gt <-> (p ?= q) Eq = Gt \/ p = q.
-Proof.
-  intros p q; split; [apply Pcompare_Gt_Gt |].
-  intros [H|H]; [|subst; apply Pcompare_refl_id].
-  revert q H; induction p; intros [q|q| ] H; simpl in *;
-  auto; discriminate.
-Qed.
-
-Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt.
-Proof.
-  destruct r; auto.
-Qed.
-
-Ltac ElimPcompare c1 c2 :=
-  elim (Dcompare ((c1 ?= c2) Eq));
-    [ idtac | let x := fresh "H" in (intro x; case x; clear x) ].
-
-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;
-   rewrite IHp; auto.
-Qed.
-
-Lemma ZC1 : forall p q:positive, (p ?= q) Eq = Gt -> (q ?= p) Eq = Lt.
-Proof.
-  intros p q H; change Eq with (CompOpp Eq).
-  rewrite <- Pcompare_antisym, H; reflexivity.
-Qed.
-
-Lemma ZC2 : forall p q:positive, (p ?= q) Eq = Lt -> (q ?= p) Eq = Gt.
-Proof.
-  intros p q H; change Eq with (CompOpp Eq).
-  rewrite <- Pcompare_antisym, H; reflexivity.
-Qed.
-
-Lemma ZC3 : forall p q:positive, (p ?= q) Eq = Eq -> (q ?= p) Eq = Eq.
-Proof.
-  intros p q H; change Eq with (CompOpp Eq).
-  rewrite <- Pcompare_antisym, H; reflexivity.
-Qed.
-
-Lemma ZC4 : forall p q:positive, (p ?= q) Eq = CompOpp ((q ?= p) Eq).
-Proof.
-  intros; change Eq at 1 with (CompOpp Eq).
-  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.
-Proof.
-  induction p; simpl in *;
-    [ elim (Pcompare_eq_Lt p (Psucc p)); auto |
-      apply Pcompare_refl_id | reflexivity].
-Qed.
-
-Theorem Pcompare_p_Sq : forall p q : positive,
-  (p ?= Psucc q) Eq = Lt <-> (p ?= q) Eq = Lt \/ p = q.
-Proof.
-  intros p q; split.
-  (* -> *)
-  revert p q; induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *;
-   try (left; reflexivity); try (right; reflexivity).
-  destruct (IHp q (Pcompare_Gt_Lt _ _ H)); subst; auto.
-  destruct (Pcompare_eq_Lt p q); auto.
-  destruct p; discriminate.
-  left; destruct (IHp q H);
-   [ elim (Pcompare_Lt_eq_Lt p q); auto | subst; apply Pcompare_refl_id].
-  destruct (Pcompare_Lt_Lt p q H); subst; auto.
-  destruct p; discriminate.
-  (* <- *)
-  intros [H|H]; [|subst; apply Pcompare_p_Sp].
-  revert q H; induction p; intros [q|q| ] H; simpl in *;
-   auto; try discriminate.
-  destruct (Pcompare_eq_Lt p (Psucc q)); auto.
-  apply Pcompare_Gt_Lt; auto.
-  destruct (Pcompare_Lt_Lt p q H); subst; auto using Pcompare_p_Sp.
-  destruct (Pcompare_Lt_eq_Lt p q); auto.
-Qed.
-
-(** 1 is the least positive number *)
-
-Lemma Pcompare_1 : forall p, ~ (p ?= 1) Eq = Lt.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-(** Properties of the strict order on positive numbers *)
-
-Lemma Plt_1 : forall p, ~ p < 1.
-Proof.
- exact Pcompare_1.
-Qed.
-
-Lemma Plt_lt_succ : forall n m : positive, n < m -> n < Psucc m.
-Proof.
-  unfold Plt; intros n m H; apply <- Pcompare_p_Sq; auto.
-Qed.
-
-Lemma Plt_irrefl : forall p : positive, ~ p < p.
-Proof.
-  unfold Plt; intro p; rewrite Pcompare_refl; discriminate.
-Qed.
-
-Lemma Plt_trans : forall n m p : positive, n < m -> m < p -> n < p.
-Proof.
-  intros n m p; induction p using Pind; intros H H0.
-  elim (Plt_1 _ H0).
-  apply Plt_lt_succ.
-  destruct (Pcompare_p_Sq m p) as (H',_); destruct (H' H0); subst; auto.
-Qed.
-
-Theorem Plt_ind : forall (A : positive -> Prop) (n : positive),
-  A (Psucc n) ->
-    (forall m : positive, n < m -> A m -> A (Psucc m)) ->
-      forall m : positive, n < m -> A m.
-Proof.
-  intros A n AB AS m. induction m using Pind; intros H.
-  elim (Plt_1 _ H).
-  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 *)
-
-Lemma Ppred_minus : forall p, Ppred p = Pminus p 1.
-Proof.
-  destruct p; auto.
-Qed.
-
-Definition Ppred_mask (p : positive_mask) :=
-match p with
-| IsPos 1 => IsNul
-| IsPos q => IsPos (Ppred q)
-| IsNul => IsNeg
-| IsNeg => IsNeg
-end.
-
-Lemma Pminus_mask_succ_r :
-  forall p q : positive, Pminus_mask p (Psucc q) = Pminus_mask_carry p q.
-Proof.
-  induction p ; destruct q; simpl; f_equal; auto; destruct p; auto.
-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;
-   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;
-  rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec.
-  destruct (Pminus_mask p q) as [|[r|r| ]|]; auto.
-Qed.
-
-Lemma double_eq_zero_inversion :
-  forall p:positive_mask, Pdouble_mask p = IsNul -> p = IsNul.
-Proof.
-  destruct p; simpl; intros; trivial; discriminate.
-Qed.
-
-Lemma double_plus_one_zero_discr :
-  forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-Lemma double_plus_one_eq_one_inversion :
-  forall p:positive_mask, Pdouble_plus_one_mask p = IsPos 1 -> p = IsNul.
-Proof.
-  destruct p; simpl; intros; trivial; discriminate.
-Qed.
-
-Lemma double_eq_one_discr :
-  forall p:positive_mask, Pdouble_mask p <> IsPos 1.
-Proof.
-  destruct p; discriminate.
-Qed.
-
-Theorem Pminus_mask_diag : forall p:positive, Pminus_mask p p = IsNul.
-Proof.
-  induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto.
-Qed.
-
-Lemma Pminus_mask_carry_diag : forall p, Pminus_mask_carry p p = IsNeg.
-Proof.
-  induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto.
-Qed.
-
-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;
-   specialize IHp with q.
-  destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto.
-  destruct (Pminus_mask p q); simpl; auto; try discriminate.
-  destruct (Pminus_mask_carry p q); simpl; auto; try discriminate.
-  destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto.
-Qed.
-
-Lemma ZL10 :
-  forall p q:positive,
-    Pminus_mask p q = IsPos 1 -> Pminus_mask_carry p q = IsNul.
-Proof.
-  induction p; intros [q|q| ] H; simpl in *; try discriminate.
-  elim (double_eq_one_discr _ H).
-  rewrite (double_plus_one_eq_one_inversion _ H); auto.
-  rewrite (double_plus_one_eq_one_inversion _ H); auto.
-  elim (double_eq_one_discr _ H).
-  destruct p; simpl; auto; discriminate.
-Qed.
-
-(** Properties of subtraction valid only for x>y *)
-
-Lemma Pminus_mask_Gt :
-  forall p q:positive,
-    (p ?= q) Eq = Gt ->
-    exists h : positive,
-      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 *;
-   try discriminate H.
-  (* 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|]].
-  rewrite ZL10; subst; auto.
-  rewrite W; simpl; destruct r; auto; elim NE; auto.
-  (* p~1, q~0 *)
-  destruct (Pcompare_Gt_Gt _ _ H) as [H'|H']; clear H; rename H' into H.
-  destruct (IHp q H) as (r & U & V & W); exists (r~1); rewrite ?U, ?V; auto.
-  exists 1; subst; rewrite Pminus_mask_diag; auto.
-  (* p~1, 1 *)
-  exists (p~0); auto.
-  (* p~0, q~1 *)
-  destruct (IHp q (Pcompare_Lt_Gt _ _ H)) as (r & U & V & W).
-  destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]].
-  exists 1; subst; rewrite ZL10, Pplus_one_succ_r; auto.
-  exists ((Ppred r)~1); rewrite W, Pplus_carry_pred_eq_plus, V; auto.
-  (* p~0, q~0 *)
-  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|]].
-  rewrite ZL10; subst; auto.
-  rewrite W; simpl; destruct r; auto; elim NE; auto.
-  (* p~0, 1 *)
-  exists (Pdouble_minus_one p); repeat split; destruct p; simpl; auto.
-  rewrite Psucc_o_double_minus_one_eq_xO; auto.
-Qed.
-
-Theorem Pplus_minus :
-  forall p q:positive, (p ?= q) Eq = Gt -> q + (p - q) = p.
-Proof.
-  intros p q H; destruct (Pminus_mask_Gt p q H) as (r & U & V & _).
-  unfold Pminus; rewrite U; simpl; auto.
-Qed.
-
-(** When x<y, the substraction of x by y returns 1 *)
-
-Lemma Pminus_mask_Lt : forall p q:positive, p<q -> Pminus_mask p q = IsNeg.
-Proof.
-  unfold Plt; induction p as [p IHp|p IHp| ]; destruct q; simpl; intros;
-   try discriminate; try rewrite IHp; auto.
-  apply Pcompare_Gt_Lt; auto.
-  destruct (Pcompare_Lt_Lt _ _ H).
-  rewrite Pminus_mask_IsNeg; simpl; auto.
-  subst; rewrite Pminus_mask_carry_diag; auto.
-Qed.
-
-Lemma Pminus_Lt : forall p q:positive, p<q -> p-q = 1.
-Proof.
-  intros; unfold Plt, Pminus; rewrite Pminus_mask_Lt; auto.
-Qed.
-
-(** The substraction of x by x returns 1 *)
-
-Lemma Pminus_Eq : forall p:positive, p-p = 1.
-Proof.
- intros; unfold Pminus; rewrite Pminus_mask_diag; auto.
-Qed.
-
-(** Number of digits in a number *)
-
-Fixpoint Psize (p:positive) : nat :=
-  match p with
-    | 1 => S O
-    | p~1 => S (Psize p)
-    | p~0 => S (Psize p)
-  end.
-
-Lemma Psize_monotone : forall p q, (p?=q) Eq = Lt -> (Psize p <= Psize q)%nat.
-Proof.
-  assert (le0 : forall n, (0<=n)%nat) by (induction n; auto).
-  assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto).
-  induction p; destruct q; simpl; auto; intros; try discriminate.
-  intros; generalize (Pcompare_Gt_Lt _ _ H); auto.
-  intros; destruct (Pcompare_Lt_Lt _ _ H); auto; subst; auto.
-Qed.
-
-
-
-
-
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
index 48f78c50..4a5f4ee1 100644
--- a/theories/NArith/NArith.v
+++ b/theories/NArith/NArith.v
@@ -1,18 +1,33 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArith.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Library for binary natural numbers *)
 
+Require Export BinNums.
 Require Export BinPos.
 Require Export BinNat.
 Require Export Nnat.
+Require Export Ndiv_def.
+Require Export Nsqrt_def.
+Require Export Ngcd_def.
 Require Export Ndigits.
-
 Require Export NArithRing.
+
+(** [N] contains an [order] tactic for natural numbers *)
+
+(** 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]. *)
+
+Local Open Scope N_scope.
+
+Section TestOrder.
+ Let test : forall x y, x<=y -> y<=x -> x=y.
+ Proof.
+ N.order.
+ Qed.
+End TestOrder.
diff --git a/theories/NArith/NOrderedType.v b/theories/NArith/NOrderedType.v
deleted file mode 100644
index f1ab4b23..00000000
--- a/theories/NArith/NOrderedType.v
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 0e1c3de0..f2ee29cc 100644
--- a/theories/NArith/Ndec.v
+++ b/theories/NArith/Ndec.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ndec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
@@ -29,14 +27,14 @@ Proof.
   intros. now apply (Peqb_eq p p').
 Qed.
 
-Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
+Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pos.compare p p' = Eq.
 Proof.
-  intros. now rewrite Pcompare_eq_iff, <- Peqb_eq.
+  intros. now rewrite Pos.compare_eq_iff, <- Peqb_eq.
 Qed.
 
-Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
+Lemma Pcompare_Peqb : forall p p', Pos.compare p p' = Eq -> Peqb p p' = true.
 Proof.
-  intros; now rewrite Peqb_eq, <- Pcompare_eq_iff.
+  intros; now rewrite Peqb_eq, <- Pos.compare_eq_iff.
 Qed.
 
 Lemma Neqb_correct : forall n, Neqb n n = true.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
index 6b490dfc..b0c33595 100644
--- a/theories/NArith/Ndigits.v
+++ b/theories/NArith/Ndigits.v
@@ -1,320 +1,253 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ndigits.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Import Bool Morphisms Setoid Bvector BinPos BinNat Wf_nat
+ Pnat Nnat Compare_dec Lt Minus.
 
-Require Import Bool.
-Require Import Bvector.
-Require Import BinPos.
-Require Import BinNat.
+Local Open Scope N_scope.
 
-(** Operation over bits of a [N] number. *)
+(** This file is mostly obsolete, see directly [BinNat] now. *)
 
-(** [xor] *)
+(** Compatibility names for some bitwise operations *)
 
-Fixpoint Pxor (p1 p2:positive) : N :=
-  match p1, p2 with
-  | xH, xH => N0
-  | xH, xO p2 => Npos (xI p2)
-  | xH, xI p2 => Npos (xO p2)
-  | xO p1, xH => Npos (xI p1)
-  | xO p1, xO p2 => Ndouble (Pxor p1 p2)
-  | 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)
-  end.
+Notation Pxor := Pos.lxor (only parsing).
+Notation Nxor := N.lxor (only parsing).
+Notation Pbit := Pos.testbit_nat (only parsing).
+Notation Nbit := N.testbit_nat (only parsing).
 
-Definition Nxor (n n':N) :=
-  match n, n' with
-  | N0, _ => n'
-  | _, N0 => n
-  | Npos p, Npos p' => Pxor p p'
-  end.
+Notation Nxor_eq := N.lxor_eq (only parsing).
+Notation Nxor_comm := N.lxor_comm (only parsing).
+Notation Nxor_assoc := N.lxor_assoc (only parsing).
+Notation Nxor_neutral_left := N.lxor_0_l (only parsing).
+Notation Nxor_neutral_right := N.lxor_0_r (only parsing).
+Notation Nxor_nilpotent := N.lxor_nilpotent (only parsing).
 
-Lemma Nxor_neutral_left : forall n:N, Nxor N0 n = n.
+(** Equivalence of bit-testing functions,
+    either with index in [N] or in [nat]. *)
+
+Lemma Ptestbit_Pbit :
+ forall p n, Pos.testbit p (N.of_nat n) = Pbit p n.
 Proof.
-  trivial.
+ induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial;
+  rewrite <- IH; f_equal; rewrite (pred_Sn n) at 2; now rewrite N_of_pred.
 Qed.
 
-Lemma Nxor_neutral_right : forall n:N, Nxor n N0 = n.
+Lemma Ntestbit_Nbit : forall a n, N.testbit a (N.of_nat n) = Nbit a n.
 Proof.
-  destruct n; trivial.
+ destruct a. trivial. apply Ptestbit_Pbit.
 Qed.
 
-Lemma Nxor_comm : forall n n':N, Nxor n n' = Nxor n' n.
+Lemma Pbit_Ptestbit :
+ forall p n, Pbit p (N.to_nat n) = Pos.testbit p n.
 Proof.
-  destruct n; destruct n'; simpl; auto.
-  generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl;
-   auto.
-  destruct p0; trivial; rewrite Hrecp; trivial.
-  destruct p0; trivial; rewrite Hrecp; trivial.
-  destruct p0 as [p| p| ]; simpl; auto.
+ intros; now rewrite <- Ptestbit_Pbit, N2Nat.id.
 Qed.
 
-Lemma Nxor_nilpotent : forall n:N, Nxor n n = N0.
+Lemma Nbit_Ntestbit :
+ forall a n, Nbit a (N.to_nat n) = N.testbit a n.
 Proof.
-  destruct n; trivial.
-  simpl. induction p as [p IHp| p IHp| ]; trivial.
-  simpl. rewrite IHp; reflexivity.
-  simpl. rewrite IHp; reflexivity.
+ destruct a. trivial. apply Pbit_Ptestbit.
 Qed.
 
-(** Checking whether a particular bit is set on not *)
-
-Fixpoint Pbit (p:positive) : nat -> bool :=
-  match p with
-  | xH => fun n:nat => match n with
-                       | O => true
-                       | S _ => false
-                       end
-  | xO p =>
-      fun n:nat => match n with
-                   | O => false
-                   | S n' => Pbit p n'
-                   end
-  | xI p => fun n:nat => match n with
-                         | O => true
-                         | S n' => Pbit p n'
-                         end
-  end.
+(** Equivalence of shifts, index in [N] or [nat] *)
 
-Definition Nbit (a:N) :=
-  match a with
-  | N0 => fun _ => false
-  | Npos p => Pbit p
-  end.
+Lemma Nshiftr_nat_S : forall a n,
+ N.shiftr_nat a (S n) = N.div2 (N.shiftr_nat a n).
+Proof.
+ reflexivity.
+Qed.
 
-(** Auxiliary results about streams of bits *)
+Lemma Nshiftl_nat_S : forall a n,
+ N.shiftl_nat a (S n) = N.double (N.shiftl_nat a n).
+Proof.
+ reflexivity.
+Qed.
 
-Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
+Lemma Nshiftr_nat_equiv :
+ forall a n, N.shiftr_nat a (N.to_nat n) = N.shiftr a n.
+Proof.
+ intros a [|n]; simpl. unfold N.shiftr_nat.
+ trivial.
+ symmetry. apply iter_nat_of_P.
+Qed.
 
-Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f.
+Lemma Nshiftr_equiv_nat :
+ forall a n, N.shiftr a (N.of_nat n) = N.shiftr_nat a n.
 Proof.
-  unfold eqf. intros. rewrite H. reflexivity.
+ intros. now rewrite <- Nshiftr_nat_equiv, Nat2N.id.
 Qed.
 
-Lemma eqf_refl : forall f:nat -> bool, eqf f f.
+Lemma Nshiftl_nat_equiv :
+ forall a n, N.shiftl_nat a (N.to_nat n) = N.shiftl a n.
 Proof.
-  unfold eqf. trivial.
+ intros [|a] [|n]; simpl; unfold N.shiftl_nat; trivial.
+ apply nat_iter_invariant; intros; now subst.
+ rewrite <- Pos2Nat.inj_iter. symmetry. now apply Pos.iter_swap_gen.
 Qed.
 
-Lemma eqf_trans :
- forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''.
+Lemma Nshiftl_equiv_nat :
+ forall a n, N.shiftl a (N.of_nat n) = N.shiftl_nat a n.
 Proof.
-  unfold eqf. intros. rewrite H. exact (H0 n).
+ intros. now rewrite <- Nshiftl_nat_equiv, Nat2N.id.
 Qed.
 
-Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n).
+(** Correctness proofs for shifts, nat version *)
 
-Lemma xorf_eq :
- forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'.
+Lemma Nshiftr_nat_spec : forall a n m,
+  Nbit (N.shiftr_nat a n) m = Nbit a (m+n).
 Proof.
-  unfold eqf, xorf. intros. apply xorb_eq, H.
+ induction n; intros m.
+ now rewrite <- plus_n_O.
+ simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn, Nshiftr_nat_S.
+ destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial.
 Qed.
 
-Lemma xorf_assoc :
- forall f f' f'',
-   eqf (xorf (xorf f f') f'') (xorf f (xorf f' f'')).
+Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat ->
+  Nbit (N.shiftl_nat a n) m = Nbit a (m-n).
 Proof.
-  unfold eqf, xorf. intros. apply xorb_assoc.
+ induction n; intros m H.
+ now rewrite <- minus_n_O.
+ destruct m. inversion H. apply le_S_n in H.
+ simpl. rewrite <- IHn, Nshiftl_nat_S; trivial.
+ destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial.
 Qed.
 
-Lemma eqf_xorf :
- forall f f' f'' f''',
-   eqf f f' -> eqf f'' f''' -> eqf (xorf f f'') (xorf f' f''').
+Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat ->
+ Nbit (N.shiftl_nat a n) m = false.
 Proof.
-  unfold eqf, xorf. intros. rewrite H. rewrite H0. reflexivity.
+ induction n; intros m H. inversion H.
+ rewrite Nshiftl_nat_S.
+ destruct m.
+ destruct (N.shiftl_nat a n); trivial.
+ specialize (IHn m (lt_S_n _ _ H)).
+ destruct (N.shiftl_nat a n); trivial.
 Qed.
 
-(** End of auxilliary results *)
+(** A left shift for positive numbers (used in BigN) *)
+
+Lemma Pshiftl_nat_0 : forall p, Pos.shiftl_nat p 0 = p.
+Proof. reflexivity. Qed.
 
-(** This part is aimed at proving that if two numbers produce
-  the same stream of bits, then they are equal. *)
+Lemma Pshiftl_nat_S :
+ forall p n, Pos.shiftl_nat p (S n) = xO (Pos.shiftl_nat p n).
+Proof. reflexivity. Qed.
 
-Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a.
+Lemma Pshiftl_nat_N :
+ forall p n, Npos (Pos.shiftl_nat p n) = N.shiftl_nat (Npos p) n.
 Proof.
-  destruct a. trivial.
-  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.
-  exact (IHp (fun n => H (S n))).
-  absurd (false = true). discriminate.
-  exact (H 0).
+ unfold Pos.shiftl_nat, N.shiftl_nat.
+ induction n; simpl; auto. now rewrite <- IHn.
 Qed.
 
-Lemma Nbit_faithful_2 :
- forall a:N, eqf (Nbit (Npos 1)) (Nbit a) -> Npos 1 = a.
+Lemma Pshiftl_nat_plus : forall n m p,
+  Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m.
 Proof.
-  destruct a. intros. absurd (true = false). discriminate.
-  exact (H 0).
-  destruct p. intro H. absurd (N0 = Npos p). discriminate.
-  exact (Nbit_faithful_1 (Npos p) (fun n:nat => H (S n))).
-  intros. absurd (true = false). discriminate.
-  exact (H 0).
-  trivial.
+ induction m; simpl; intros. reflexivity.
+ rewrite 2 Pshiftl_nat_S. now f_equal.
+Qed.
+
+(** Semantics of bitwise operations with respect to [Nbit] *)
+
+Lemma Pxor_semantics p p' n :
+ Nbit (Pos.lxor p p') n = xorb (Pbit p n) (Pbit p' n).
+Proof.
+ rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_lxor_spec.
 Qed.
 
-Lemma Nbit_faithful_3 :
- forall (a:N) (p:positive),
-   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
-   eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a.
+Lemma Nxor_semantics a a' n :
+ Nbit (N.lxor a a') n = xorb (Nbit a n) (Nbit a' n).
 Proof.
-  destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))).
-  intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity.
-  unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity.
-  destruct p. discriminate (H0 O).
-  rewrite (H p (fun n => H0 (S n))). reflexivity.
-  discriminate (H0 0).
+ rewrite <- !Ntestbit_Nbit. apply N.lxor_spec.
 Qed.
 
-Lemma Nbit_faithful_4 :
- forall (a:N) (p:positive),
-   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
-   eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a.
+Lemma Por_semantics p p' n :
+ Pbit (Pos.lor p p') n = (Pbit p n) || (Pbit p' n).
 Proof.
-  destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))).
-  intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity.
-  intro. rewrite H0. reflexivity.
-  destruct p. rewrite (H p (fun n:nat => H0 (S n))). reflexivity.
-  discriminate (H0 0).
-  cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))).
-  intro. discriminate (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))).
-  intro. rewrite H0. reflexivity.
+ rewrite <- !Ptestbit_Pbit. apply N.pos_lor_spec.
 Qed.
 
-Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'.
+Lemma Nor_semantics a a' n :
+ Nbit (N.lor a a') n = (Nbit a n) || (Nbit a' n).
 Proof.
-  destruct a. exact Nbit_faithful_1.
-  induction p. intros a' H. apply Nbit_faithful_4. intros.
-  assert (Npos p = Npos p') by exact (IHp (Npos p') H0).
-  inversion H1. reflexivity.
-  assumption.
-  intros. apply Nbit_faithful_3. intros.
-  assert (Npos p = Npos p') by exact (IHp (Npos p') H0).
-  inversion H1. reflexivity.
-  assumption.
-  exact Nbit_faithful_2.
+ rewrite <- !Ntestbit_Nbit. apply N.lor_spec.
 Qed.
 
-(** We now describe the semantics of [Nxor] in terms of bit streams. *)
+Lemma Pand_semantics p p' n :
+ Nbit (Pos.land p p') n = (Pbit p n) && (Pbit p' n).
+Proof.
+ rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_land_spec.
+Qed.
 
-Lemma Nxor_sem_1 : forall a':N, Nbit (Nxor N0 a') 0 = Nbit a' 0.
+Lemma Nand_semantics a a' n :
+ Nbit (N.land a a') n = (Nbit a n) && (Nbit a' n).
 Proof.
-  trivial.
+ rewrite <- !Ntestbit_Nbit. apply N.land_spec.
 Qed.
 
-Lemma Nxor_sem_2 :
- forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0).
+Lemma Pdiff_semantics p p' n :
+ Nbit (Pos.ldiff p p') n = (Pbit p n) && negb (Pbit p' n).
 Proof.
-  intro. destruct a'. trivial.
-  destruct p; trivial.
+ rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_ldiff_spec.
+Qed.
+
+Lemma Ndiff_semantics a a' n :
+ Nbit (N.ldiff a a') n = (Nbit a n) && negb (Nbit a' n).
+Proof.
+ rewrite <- !Ntestbit_Nbit. apply N.ldiff_spec.
 Qed.
 
-Lemma Nxor_sem_3 :
- forall (p:positive) (a':N),
-   Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0.
+(** Equality over functional streams of bits *)
+
+Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
+
+Program Instance eqf_equiv : Equivalence eqf.
+
+Local Infix "==" := eqf (at level 70, no associativity).
+
+(** If two numbers produce the same stream of bits, they are equal. *)
+
+Local Notation Step H := (fun n => H (S n)).
+
+Lemma Pbit_faithful_0 : forall p, ~(Pbit p == (fun _ => false)).
 Proof.
-  intros. destruct a'. trivial.
-  simpl. destruct p0; trivial.
-  destruct (Pxor p p0); trivial.
-  destruct (Pxor p p0); trivial.
+ induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O).
+  apply (IHp (Step H)).
 Qed.
 
-Lemma Nxor_sem_4 :
- forall (p:positive) (a':N),
-   Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0).
+Lemma Pbit_faithful : forall p p', Pbit p == Pbit p' -> p = p'.
 Proof.
-  intros. destruct a'. trivial.
-  simpl. destruct p0; trivial.
-  destruct (Pxor p p0); trivial.
-  destruct (Pxor p p0); trivial.
+ induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial;
+  try discriminate (H O).
+ f_equal. apply (IHp _ (Step H)).
+ destruct (Pbit_faithful_0 _ (Step H)).
+ f_equal. apply (IHp _ (Step H)).
+ symmetry in H. destruct (Pbit_faithful_0 _ (Step H)).
 Qed.
 
-Lemma Nxor_sem_5 :
- forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0.
+Lemma Nbit_faithful : forall n n', Nbit n == Nbit n' -> n = n'.
 Proof.
-  destruct a; intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial.
-  destruct p. apply Nxor_sem_4.
-  change (Nbit (Nxor (Npos (xO p)) a') 0 = xorb false (Nbit a' 0)).
-  rewrite false_xorb. apply Nxor_sem_3. apply Nxor_sem_2.
+ intros [|p] [|p'] H; trivial.
+ symmetry in H. destruct (Pbit_faithful_0 _ H).
+ destruct (Pbit_faithful_0 _ H).
+ f_equal. apply Pbit_faithful, H.
 Qed.
 
-Lemma Nxor_sem_6 :
- forall n:nat,
-   (forall a a':N, Nbit (Nxor a a') n = xorf (Nbit a) (Nbit a') n) ->
-   forall a a':N,
-     Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n).
+Lemma Nbit_faithful_iff : forall n n', Nbit n == Nbit n' <-> n = n'.
 Proof.
-  intros.
-(* pose proof (fun p1 p2 => H (Npos p1) (Npos p2)) as H'. clear H. rename H' into H.*)
-  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].
-  simpl Nbit; rewrite xorb_false. reflexivity.
-  destruct p. destruct p0; simpl Nbit in *.
-  rewrite <- H; simpl; case (Pxor p p0); trivial.
-  rewrite <- H; simpl; case (Pxor p p0); trivial.
-  rewrite xorb_false. reflexivity.
-  destruct p0; simpl Nbit in *.
-  rewrite <- H; simpl; case (Pxor p p0); trivial.
-  rewrite <- H; simpl; case (Pxor p p0); trivial.
-  rewrite xorb_false. reflexivity.
-  simpl Nbit. rewrite false_xorb. destruct p0; trivial.
-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.
-  apply Nxor_sem_5. apply Nxor_sem_6; assumption.
-Qed.
-
-(** Consequences:
-       - only equal numbers lead to a null xor
-       - xor is associative
-*)
-
-Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'.
-Proof.
-  intros. apply Nbit_faithful, xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')).
-  apply eqf_sym, Nxor_semantics.
-  rewrite H. unfold eqf. trivial.
-Qed.
-
-Lemma Nxor_assoc :
- forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a'').
-Proof.
-  intros. apply Nbit_faithful.
-  apply eqf_trans with (xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')).
-  apply eqf_trans with (xorf (Nbit (Nxor a a')) (Nbit a'')).
-  apply Nxor_semantics.
-  apply eqf_xorf. apply Nxor_semantics.
-  apply eqf_refl.
-  apply eqf_trans with (xorf (Nbit a) (xorf (Nbit a') (Nbit a''))).
-  apply xorf_assoc.
-  apply eqf_trans with (xorf (Nbit a) (Nbit (Nxor a' a''))).
-  apply eqf_xorf. apply eqf_refl.
-  apply eqf_sym, Nxor_semantics.
-  apply eqf_sym, Nxor_semantics.
+ split. apply Nbit_faithful. intros; now subst.
 Qed.
 
+Local Close Scope N_scope.
+
 (** Checking whether a number is odd, i.e.
    if its lower bit is set. *)
 
-Definition Nbit0 (n:N) :=
-  match n with
-  | N0 => false
-  | Npos (xO _) => false
-  | _ => true
-  end.
+Notation Nbit0 := N.odd (only parsing).
 
 Definition Nodd (n:N) := Nbit0 n = true.
 Definition Neven (n:N) := Nbit0 n = false.
@@ -363,8 +296,8 @@ Qed.
 Lemma Nxor_bit0 :
  forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a').
 Proof.
-  intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' 0).
-  unfold xorf. rewrite Nbit0_correct, Nbit0_correct. reflexivity.
+  intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' O).
+  rewrite Nbit0_correct, Nbit0_correct. reflexivity.
 Qed.
 
 Lemma Nxor_div2 :
@@ -372,7 +305,7 @@ Lemma Nxor_div2 :
 Proof.
   intros. apply Nbit_faithful. unfold eqf. intro.
   rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)).
-  unfold xorf. rewrite 2! Ndiv2_correct.
+  rewrite 2! Ndiv2_correct.
   reflexivity.
 Qed.
 
@@ -381,7 +314,8 @@ Lemma Nneg_bit0 :
    Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a').
 Proof.
   intros.
-  rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false.
+  rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, 
+    xorb_nilpotent, xorb_false.
   reflexivity.
 Qed.
 
@@ -404,7 +338,8 @@ Lemma Nsame_bit0 :
 Proof.
   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.
+  rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb.
+    reflexivity.
 Qed.
 
 (** a lexicographic order on bits, starting from the lowest bit *)
@@ -511,8 +446,8 @@ Lemma Nless_trans :
    Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
 Proof.
   induction a as [|a IHa|a IHa] using N_ind_double; intros a' a'' H H0.
-    destruct (Nless N0 a'') as []_eqn:Heqb. trivial.
-     rewrite (N0_less_2 a'' Heqb), (Nless_z a') in H0. discriminate H0.
+    case_eq (Nless N0 a'') ; intros Heqn. trivial.
+     rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
     induction a' as [|a' _|a' _] using N_ind_double.
       rewrite (Nless_z (Ndouble a)) in H. discriminate H.
       rewrite (Nless_def_1 a a') in H.
@@ -539,10 +474,10 @@ Lemma Nless_total :
  forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
 Proof.
   induction a using N_rec_double; intro a'.
-    destruct (Nless N0 a') as []_eqn:Heqb. left. left. auto.
+    case_eq (Nless N0 a') ; intros Heqb. left. left. auto.
      right. rewrite (N0_less_2 a' Heqb). reflexivity.
     induction a' as [|a' _|a' _] using N_rec_double.
-      destruct (Nless N0 (Ndouble a)) as []_eqn:Heqb. left. right. auto.
+      case_eq (Nless N0 (Ndouble a)) ; intros Heqb. left. right. auto.
        right. exact (N0_less_2 _  Heqb).
       rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
         left. assumption.
@@ -558,11 +493,7 @@ Qed.
 
 (** Number of digits in a number *)
 
-Definition Nsize (n:N) : nat := match n with
-  | N0 => 0%nat
-  | Npos p => Psize p
- end.
-
+Notation Nsize := N.size_nat (only parsing).
 
 (** conversions between N and bit vectors. *)
 
@@ -581,9 +512,9 @@ Definition N2Bv (n:N) : Bvector (Nsize n) :=
 
 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)
+    | Vector.nil => N0
+    | Vector.cons false n bv => Ndouble (Bv2N n bv)
+    | Vector.cons true n bv => Ndouble_plus_one (Bv2N n bv)
   end.
 
 Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
@@ -599,13 +530,12 @@ Qed.
 
 Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n.
 Proof.
-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));
-  simpl; auto with arith.
+induction bv; intros.
+auto.
+simpl.
+destruct h;
+ destruct (Bv2N n bv);
+ simpl ; auto with arith.
 Qed.
 
 (** In the previous lemma, we can only replace the inequality by
@@ -615,15 +545,10 @@ Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)),
   Bsign _ bv = true <->
   Nsize (Bv2N _ bv) = (S n).
 Proof.
-induction n; intro.
-rewrite (VSn_eq _ _ bv); simpl.
-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));
-  simpl; intuition; try discriminate.
+apply Vector.rectS ; intros ; simpl.
+destruct a ; compute ; split ; intros x ; now inversion x.
+ destruct a, (Bv2N (S n) v) ;
+  simpl ;intuition ; try discriminate.
 Qed.
 
 (** To state nonetheless a second result about composition of
@@ -653,7 +578,7 @@ Qed.
    [a] plus some zeros. *)
 
 Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat),
- N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k).
+ N2Bv_gen (Nsize a + k) a = Vector.append (N2Bv a) (Bvect_false k).
 Proof.
 destruct a; simpl.
 destruct k; simpl; auto.
@@ -665,13 +590,13 @@ Qed.
 Lemma N2Bv_Bv2N : forall n (bv:Bvector n),
    N2Bv_gen n (Bv2N n bv) = bv.
 Proof.
-induction n; intros.
-rewrite (V0_eq _ bv); simpl; auto.
-rewrite (VSn_eq _ _ bv); simpl.
-generalize (IHn (Vtail _ _ bv)); clear IHn.
+induction bv; intros.
+auto.
+simpl.
+generalize IHbv; clear IHbv.
 unfold Bcons.
-destruct (Bv2N _ (Vtail _ _ bv));
- destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial;
+destruct (Bv2N _ bv);
+ destruct h; intro H; rewrite <- H; simpl; trivial;
   induction n; simpl; auto.
 Qed.
 
@@ -680,31 +605,25 @@ Qed.
 Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)),
   Nbit0 (Bv2N _ bv) = Blow _ bv.
 Proof.
+apply Vector.caseS.
 intros.
 unfold Blow.
-rewrite (VSn_eq _ _ bv) at 1.
 simpl.
-destruct (Bv2N n (Vtail bool n bv)); simpl;
- destruct (Vhead bool n bv); auto.
+destruct (Bv2N n t); simpl;
+ destruct h; auto.
 Qed.
 
-Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p<n -> bool.
-Proof.
- induction bv in p |- *.
- intros.
- exfalso; inversion H.
- intros.
- destruct p.
- exact a.
- apply (IHbv p); auto with arith.
-Defined.
+Notation Bnth := (@Vector.nth_order bool).
 
 Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n),
-  Bnth _ bv p H = Nbit (Bv2N _ bv) p.
+  Bnth bv H = Nbit (Bv2N _ bv) p.
 Proof.
 induction bv; intros.
 inversion H.
-destruct p; simpl; destruct (Bv2N n bv); destruct a; simpl in *; auto.
+destruct p ; simpl.
+  destruct (Bv2N n bv); destruct h; simpl in *; auto.
+  specialize IHbv with p (lt_S_n _ _ H).
+    simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto.
 Qed.
 
 Lemma Nbit_Nsize : forall n p, Nsize n <= p -> Nbit n p = false.
@@ -716,26 +635,30 @@ inversion H.
 inversion H.
 Qed.
 
-Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth _ (N2Bv n) p H.
+Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth (N2Bv n) H.
 Proof.
 destruct n as [|n].
 inversion H.
-induction n; simpl in *; intros; destruct p; auto with arith.
-inversion H; inversion H1.
+induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto.
+intros H ; destruct (lt_n_O _ (lt_S_n _ _ H)).
 Qed.
 
-(** Xor is the same in the two worlds. *)
+(** Binary bitwise operations are the same in the two worlds. *)
 
 Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
   Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv').
 Proof.
-induction n.
-intros.
-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 (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto.
+apply Vector.rect2 ; intros.
+now simpl.
+simpl.
+destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl in *; rewrite H ; now simpl.
 Qed.
 
+Lemma Nand_BVand : forall n (bv bv' : Bvector n),
+  Bv2N _ (BVand _ bv bv') = N.land (Bv2N _ bv) (Bv2N _ bv').
+Proof.
+refine (@Vector.rect2 _ _ _ _ _); simpl; intros; auto.
+rewrite H.
+destruct a, b, (Bv2N n v1), (Bv2N n v2);
+ simpl; auto.
+Qed.
diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v
index 586c1114..22adc505 100644
--- a/theories/NArith/Ndist.v
+++ b/theories/NArith/Ndist.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	     $Id: Ndist.v 14641 2011-11-06 11:59:10Z herbelin $	      i*)
-
 Require Import Arith.
 Require Import Min.
 Require Import BinPos.
@@ -303,7 +301,7 @@ Proof.
   cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit a'' k = false).
   intros. apply H1. reflexivity.
   intro a''. case a''. intro. reflexivity.
-  intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). unfold xorf in |- *.
+  intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k).
   rewrite
    (Nplength_zeros (Npos p) (Pplength p)
       (refl_equal (Nplength (Npos p))) k H0).
@@ -335,4 +333,4 @@ Proof.
   intro. rewrite <- H. apply Nplength_ultra.
   rewrite Nxor_assoc. rewrite <- (Nxor_assoc a'' a'' a'). rewrite Nxor_nilpotent.
   rewrite Nxor_neutral_left. reflexivity.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v
new file mode 100644
index 00000000..559f01f1
--- /dev/null
+++ b/theories/NArith/Ndiv_def.v
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinNat.
+Local Open Scope N_scope.
+
+(** Obsolete file, see [BinNat] now,
+    only compatibility notations remain here. *)
+
+Definition Pdiv_eucl a b := N.pos_div_eucl a (Npos b).
+
+Definition Pdiv_eucl_correct a b :
+  let (q,r) := Pdiv_eucl a b in Npos a = q * Npos b + r
+ := N.pos_div_eucl_spec a (Npos b).
+
+Lemma Pdiv_eucl_remainder a b :
+  snd (Pdiv_eucl a b) < Npos b.
+Proof. now apply (N.pos_div_eucl_remainder a (Npos b)). Qed.
+
+Notation Ndiv_eucl := N.div_eucl (only parsing).
+Notation Ndiv := N.div (only parsing).
+Notation Nmod := N.modulo (only parsing).
+
+Notation Ndiv_eucl_correct := N.div_eucl_spec (only parsing).
+Notation Ndiv_mod_eq := N.div_mod' (only parsing).
+Notation Nmod_lt := N.mod_lt (only parsing).
diff --git a/theories/NArith/Ngcd_def.v b/theories/NArith/Ngcd_def.v
new file mode 100644
index 00000000..13211f46
--- /dev/null
+++ b/theories/NArith/Ngcd_def.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinPos BinNat.
+Local Open Scope N_scope.
+
+(** Obsolete file, see [BinNat] now,
+    only compatibility notations remain here. *)
+
+Notation Ndivide := N.divide (only parsing).
+Notation Ngcd := N.gcd (only parsing).
+Notation Nggcd := N.ggcd (only parsing).
+Notation Nggcd_gcd := N.ggcd_gcd (only parsing).
+Notation Nggcd_correct_divisors := N.ggcd_correct_divisors (only parsing).
+Notation Ngcd_divide_l := N.gcd_divide_l (only parsing).
+Notation Ngcd_divide_r := N.gcd_divide_r (only parsing).
+Notation Ngcd_greatest := N.gcd_greatest (only parsing).
diff --git a/theories/NArith/Nminmax.v b/theories/NArith/Nminmax.v
deleted file mode 100644
index 58184a4f..00000000
--- a/theories/NArith/Nminmax.v
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 f57fab0f..133d4c23 100644
--- a/theories/NArith/Nnat.v
+++ b/theories/NArith/Nnat.v
@@ -1,370 +1,232 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Nnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import Arith_base.
-Require Import Compare_dec.
-Require Import Sumbool.
-Require Import Div2.
-Require Import Min.
-Require Import Max.
-Require Import BinPos.
-Require Import BinNat.
-Require Import BinInt.
-Require Import Pnat.
-Require Import Zmax.
-Require Import Zmin.
-Require Import Znat.
-
-(** Translation from [N] to [nat] and back. *)
-
-Definition nat_of_N (a:N) :=
-  match a with
-  | N0 => 0%nat
-  | Npos p => nat_of_P p
-  end.
-
-Definition N_of_nat (n:nat) :=
-  match n with
-  | O => N0
-  | S n' => Npos (P_of_succ_nat n')
-  end.
-
-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 |- *.
-  rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
-  rewrite nat_of_P_inj with (1 := H). reflexivity.
-Qed.
-
-Lemma nat_of_N_of_nat : forall n:nat, nat_of_N (N_of_nat n) = n.
-Proof.
-  induction n. trivial.
-  intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
-Qed.
-
-(** Interaction of this translation and usual operations. *)
-
-Lemma nat_of_Ndouble : forall a, nat_of_N (Ndouble a) = 2*(nat_of_N a).
-Proof.
-  destruct a; simpl nat_of_N; auto.
-  apply nat_of_P_xO.
-Qed.
-
-Lemma N_of_double : forall n, N_of_nat (2*n) = Ndouble (N_of_nat n).
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  rewrite <- nat_of_Ndouble.
-  apply N_of_nat_of_N.
-Qed.
-
-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 :
-  forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n).
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  rewrite <- nat_of_Ndouble_plus_one.
-  apply N_of_nat_of_N.
-Qed.
-
-Lemma nat_of_Nsucc : forall a, nat_of_N (Nsucc a) = S (nat_of_N a).
-Proof.
-  destruct a; simpl.
-  apply nat_of_P_xH.
-  apply nat_of_P_succ_morphism.
-Qed.
-
-Lemma N_of_S : forall n, N_of_nat (S n) = Nsucc (N_of_nat n).
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  rewrite <- nat_of_Nsucc.
-  apply N_of_nat_of_N.
-Qed.
-
-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 :
-  forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n').
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  rewrite <- nat_of_Nplus.
-  apply N_of_nat_of_N.
-Qed.
-
-Lemma nat_of_Nminus :
-  forall a a', nat_of_N (Nminus a a') = ((nat_of_N a)-(nat_of_N a'))%nat.
-Proof.
-  destruct a; destruct a'; simpl; auto with arith.
-  case_eq (Pcompare p p0 Eq); simpl; intros.
-  rewrite (Pcompare_Eq_eq _ _ H); auto with arith.
-  rewrite Pminus_mask_diag. simpl. apply minus_n_n.
-  rewrite Pminus_mask_Lt. pose proof (nat_of_P_lt_Lt_compare_morphism _ _ H). simpl.
-  symmetry; apply not_le_minus_0. auto with arith. assumption.
-  pose proof (Pminus_mask_Gt p p0 H) as H1. destruct H1 as [q [H1 _]]. rewrite H1; simpl.
-  replace q with (Pminus p p0) by (unfold Pminus; now rewrite H1).
-  apply nat_of_P_minus_morphism; auto.
-Qed.
-
-Lemma N_of_minus :
-  forall n n', N_of_nat (n-n') = Nminus (N_of_nat n) (N_of_nat n').
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  rewrite <- nat_of_Nminus.
-  apply N_of_nat_of_N.
-Qed.
-
-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.
+Require Import Arith_base Compare_dec Sumbool Div2 Min Max.
+Require Import BinPos BinNat Pnat.
 
-Lemma N_of_mult :
-  forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n').
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  rewrite <- nat_of_Nmult.
-  apply N_of_nat_of_N.
-Qed.
-
-Lemma nat_of_Ndiv2 :
-  forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a).
-Proof.
-  destruct a; simpl in *; auto.
-  destruct p; auto.
-  rewrite nat_of_P_xI.
-  rewrite div2_double_plus_one; auto.
-  rewrite nat_of_P_xO.
-  rewrite div2_double; auto.
-Qed.
-
-Lemma N_of_div2 :
-  forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n).
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  rewrite <- nat_of_Ndiv2.
-  apply N_of_nat_of_N.
-Qed.
-
-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.
-  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.
+(** * Conversions from [N] to [nat] *)
 
-Lemma N_of_nat_compare :
- forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n').
-Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  symmetry; apply nat_of_Ncompare.
-Qed.
+Module N2Nat.
 
-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.
-  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.
+(** [N.to_nat] is a bijection between [N] and [nat],
+    with [Pos.of_nat] as reciprocal.
+    See [Nat2N.id] below for the dual equation. *)
 
-Lemma N_of_min :
-  forall n n', N_of_nat (min n n') = Nmin (N_of_nat n) (N_of_nat n').
+Lemma id a : N.of_nat (N.to_nat a) = a.
 Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  rewrite <- nat_of_Nmin.
-  apply N_of_nat_of_N.
+ destruct a as [| p]; simpl; trivial.
+ destruct (Pos2Nat.is_succ p) as (n,H). rewrite H. simpl. f_equal.
+ apply Pos2Nat.inj. rewrite H. apply SuccNat2Pos.id_succ.
 Qed.
 
-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.
-  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.
+(** [N.to_nat] is hence injective *)
 
-Lemma N_of_max :
-  forall n n', N_of_nat (max n n') = Nmax (N_of_nat n) (N_of_nat n').
+Lemma inj a a' : N.to_nat a = N.to_nat a' -> a = a'.
 Proof.
-  intros.
-  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
-  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
-  rewrite <- nat_of_Nmax.
-  apply N_of_nat_of_N.
+ intro H. rewrite <- (id a), <- (id a'). now f_equal.
 Qed.
 
-(** Properties concerning [Z_of_N] *)
-
-Lemma Z_of_nat_of_N : forall n:N, Z_of_nat (nat_of_N n) = Z_of_N n.
+Lemma inj_iff a a' : N.to_nat a = N.to_nat a' <-> a = a'.
 Proof.
-  destruct n; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P.
+ split. apply inj. intros; now subst.
 Qed.
 
-Lemma Z_of_N_eq : forall n m, n = m -> Z_of_N n = Z_of_N m.
-Proof.
- intros; f_equal; assumption.
-Qed.
+(** Interaction of this translation and usual operations. *)
 
-Lemma Z_of_N_eq_rev : forall n m, Z_of_N n = Z_of_N m -> n = m.
+Lemma inj_double a : N.to_nat (N.double a) = 2*(N.to_nat a).
 Proof.
- intros [|n] [|m]; simpl; intros; try discriminate; congruence.
+ destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xO.
 Qed.
 
-Lemma Z_of_N_eq_iff : forall n m, n = m <-> Z_of_N n = Z_of_N m.
+Lemma inj_succ_double a : N.to_nat (N.succ_double a) = S (2*(N.to_nat a)).
 Proof.
- split; [apply Z_of_N_eq | apply Z_of_N_eq_rev].
+ destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xI.
 Qed.
 
-Lemma Z_of_N_le : forall n m, (n<=m)%N -> (Z_of_N n <= Z_of_N m)%Z.
+Lemma inj_succ a : N.to_nat (N.succ a) = S (N.to_nat a).
 Proof.
- intros [|n] [|m]; simpl; auto.
+ destruct a; simpl; trivial. apply Pos2Nat.inj_succ.
 Qed.
 
-Lemma Z_of_N_le_rev : forall n m, (Z_of_N n <= Z_of_N m)%Z -> (n<=m)%N.
+Lemma inj_add a a' :
+  N.to_nat (a + a') = N.to_nat a + N.to_nat a'.
 Proof.
- intros [|n] [|m]; simpl; auto.
+ destruct a, a'; simpl; trivial. apply Pos2Nat.inj_add.
 Qed.
 
-Lemma Z_of_N_le_iff : forall n m, (n<=m)%N <-> (Z_of_N n <= Z_of_N m)%Z.
+Lemma inj_mul a a' :
+  N.to_nat (a * a') = N.to_nat a * N.to_nat a'.
 Proof.
- split; [apply Z_of_N_le | apply Z_of_N_le_rev].
+ destruct a, a'; simpl; trivial. apply Pos2Nat.inj_mul.
 Qed.
 
-Lemma Z_of_N_lt : forall n m, (n<m)%N -> (Z_of_N n < Z_of_N m)%Z.
+Lemma inj_sub a a' :
+  N.to_nat (a - a') = N.to_nat a - N.to_nat a'.
 Proof.
- intros [|n] [|m]; simpl; auto.
+ destruct a as [|a], a' as [|a']; simpl; auto with arith.
+ destruct (Pos.compare_spec a a').
+ subst. now rewrite Pos.sub_mask_diag, <- minus_n_n.
+ rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H.
+ simpl; symmetry; apply not_le_minus_0; auto with arith.
+ destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq).
+ simpl. apply plus_minus. now rewrite <- Hq, Pos2Nat.inj_add.
 Qed.
 
-Lemma Z_of_N_lt_rev : forall n m, (Z_of_N n < Z_of_N m)%Z -> (n<m)%N.
+Lemma inj_pred a : N.to_nat (N.pred a) = pred (N.to_nat a).
 Proof.
- intros [|n] [|m]; simpl; auto.
+ intros. rewrite pred_of_minus, N.pred_sub. apply inj_sub.
 Qed.
 
-Lemma Z_of_N_lt_iff : forall n m, (n<m)%N <-> (Z_of_N n < Z_of_N m)%Z.
+Lemma inj_div2 a : N.to_nat (N.div2 a) = div2 (N.to_nat a).
 Proof.
- split; [apply Z_of_N_lt | apply Z_of_N_lt_rev].
+ destruct a as [|[p|p| ]]; trivial.
+ simpl N.to_nat. now rewrite Pos2Nat.inj_xI, div2_double_plus_one.
+ simpl N.to_nat. now rewrite Pos2Nat.inj_xO, div2_double.
 Qed.
 
-Lemma Z_of_N_ge : forall n m, (n>=m)%N -> (Z_of_N n >= Z_of_N m)%Z.
+Lemma inj_compare a a' :
+ (a ?= a')%N = nat_compare (N.to_nat a) (N.to_nat a').
 Proof.
- intros [|n] [|m]; simpl; auto.
+ destruct a, a'; simpl; trivial.
+ now destruct (Pos2Nat.is_succ p) as (n,->).
+ now destruct (Pos2Nat.is_succ p) as (n,->).
+ apply Pos2Nat.inj_compare.
 Qed.
 
-Lemma Z_of_N_ge_rev : forall n m, (Z_of_N n >= Z_of_N m)%Z -> (n>=m)%N.
+Lemma inj_max a a' :
+  N.to_nat (N.max a a') = max (N.to_nat a) (N.to_nat a').
 Proof.
- intros [|n] [|m]; simpl; auto.
+ unfold N.max. rewrite inj_compare; symmetry.
+ case nat_compare_spec; intros H; try rewrite H; auto with arith.
 Qed.
 
-Lemma Z_of_N_ge_iff : forall n m, (n>=m)%N <-> (Z_of_N n >= Z_of_N m)%Z.
+Lemma inj_min a a' :
+  N.to_nat (N.min a a') = min (N.to_nat a) (N.to_nat a').
 Proof.
- split; [apply Z_of_N_ge | apply Z_of_N_ge_rev].
+  unfold N.min; rewrite inj_compare. symmetry.
+  case nat_compare_spec; intros H; try rewrite H; auto with arith.
 Qed.
 
-Lemma Z_of_N_gt : forall n m, (n>m)%N -> (Z_of_N n > Z_of_N m)%Z.
+Lemma inj_iter a {A} (f:A->A) (x:A) :
+  N.iter a f x = nat_iter (N.to_nat a) f x.
 Proof.
- intros [|n] [|m]; simpl; auto.
+ destruct a as [|a]. trivial. apply Pos2Nat.inj_iter.
 Qed.
 
-Lemma Z_of_N_gt_rev : forall n m, (Z_of_N n > Z_of_N m)%Z -> (n>m)%N.
-Proof.
- intros [|n] [|m]; simpl; auto.
-Qed.
+End N2Nat.
 
-Lemma Z_of_N_gt_iff : forall n m, (n>m)%N <-> (Z_of_N n > Z_of_N m)%Z.
-Proof.
- split; [apply Z_of_N_gt | apply Z_of_N_gt_rev].
-Qed.
+Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double
+ N2Nat.inj_succ N2Nat.inj_add N2Nat.inj_mul N2Nat.inj_sub
+ N2Nat.inj_pred N2Nat.inj_div2 N2Nat.inj_max N2Nat.inj_min
+ N2Nat.id
+ : Nnat.
 
-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.
 
-Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p.
-Proof.
- destruct p; simpl; auto.
-Qed.
+(** * Conversions from [nat] to [N] *)
 
-Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z.
-Proof.
- destruct z; simpl; auto.
-Qed.
+Module Nat2N.
 
-Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z.
-Proof.
- destruct n; intro; discriminate.
-Qed.
+(** [N.of_nat] is an bijection between [nat] and [N],
+    with [Pos.to_nat] as reciprocal.
+    See [N2Nat.id] above for the dual equation. *)
 
-Lemma Z_of_N_plus : forall n m:N, Z_of_N (n+m) = (Z_of_N n + Z_of_N m)%Z.
+Lemma id n : N.to_nat (N.of_nat n) = n.
 Proof.
- destruct n; destruct m; auto.
+ induction n; simpl; trivial. apply SuccNat2Pos.id_succ.
 Qed.
 
-Lemma Z_of_N_mult : forall n m:N, Z_of_N (n*m) = (Z_of_N n * Z_of_N m)%Z.
-Proof.
- destruct n; destruct m; auto.
-Qed.
+Hint Rewrite id : Nnat.
+Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat.
 
-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.
+(** [N.of_nat] is hence injective *)
 
-Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n).
+Lemma inj n n' : N.of_nat n = N.of_nat n' -> n = n'.
 Proof.
- intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S.
+ intros H. rewrite <- (id n), <- (id n'). now f_equal.
 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 inj_iff n n' : N.of_nat n = N.of_nat n' <-> n = n'.
 Proof.
- intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min.
+ split. apply inj. intros; now subst.
 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).
-Proof.
- intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max.
-Qed.
+(** Interaction of this translation and usual operations. *)
 
+Lemma inj_double n : N.of_nat (2*n) = N.double (N.of_nat n).
+Proof. nat2N. Qed.
+
+Lemma inj_succ_double n : N.of_nat (S (2*n)) = N.succ_double (N.of_nat n).
+Proof. nat2N. Qed.
+
+Lemma inj_succ n : N.of_nat (S n) = N.succ (N.of_nat n).
+Proof. nat2N. Qed.
+
+Lemma inj_pred n : N.of_nat (pred n) = N.pred (N.of_nat n).
+Proof. nat2N. Qed.
+
+Lemma inj_add n n' : N.of_nat (n+n') = (N.of_nat n + N.of_nat n')%N.
+Proof. nat2N. Qed.
+
+Lemma inj_sub n n' : N.of_nat (n-n') = (N.of_nat n - N.of_nat n')%N.
+Proof. nat2N. Qed.
+
+Lemma inj_mul n n' : N.of_nat (n*n') = (N.of_nat n * N.of_nat n')%N.
+Proof. nat2N. Qed.
+
+Lemma inj_div2 n : N.of_nat (div2 n) = N.div2 (N.of_nat n).
+Proof. nat2N. Qed.
+
+Lemma inj_compare n n' :
+  nat_compare n n' = (N.of_nat n ?= N.of_nat n')%N.
+Proof. now rewrite N2Nat.inj_compare, !id. Qed.
+
+Lemma inj_min n n' :
+  N.of_nat (min n n') = N.min (N.of_nat n) (N.of_nat n').
+Proof. nat2N. Qed.
+
+Lemma inj_max n n' :
+  N.of_nat (max n n') = N.max (N.of_nat n) (N.of_nat n').
+Proof. nat2N. Qed.
+
+Lemma inj_iter n {A} (f:A->A) (x:A) :
+  nat_iter n f x = N.iter (N.of_nat n) f x.
+Proof. now rewrite N2Nat.inj_iter, !id. Qed.
+
+End Nat2N.
+
+Hint Rewrite Nat2N.id : Nnat.
+
+(** Compatibility notations *)
+
+Notation nat_of_N_inj := N2Nat.inj (only parsing).
+Notation N_of_nat_of_N := N2Nat.id (only parsing).
+Notation nat_of_Ndouble := N2Nat.inj_double (only parsing).
+Notation nat_of_Ndouble_plus_one := N2Nat.inj_succ_double (only parsing).
+Notation nat_of_Nsucc := N2Nat.inj_succ (only parsing).
+Notation nat_of_Nplus := N2Nat.inj_add (only parsing).
+Notation nat_of_Nmult := N2Nat.inj_mul (only parsing).
+Notation nat_of_Nminus := N2Nat.inj_sub (only parsing).
+Notation nat_of_Npred := N2Nat.inj_pred (only parsing).
+Notation nat_of_Ndiv2 := N2Nat.inj_div2 (only parsing).
+Notation nat_of_Ncompare := N2Nat.inj_compare (only parsing).
+Notation nat_of_Nmax := N2Nat.inj_max (only parsing).
+Notation nat_of_Nmin := N2Nat.inj_min (only parsing).
+
+Notation nat_of_N_of_nat := Nat2N.id (only parsing).
+Notation N_of_nat_inj := Nat2N.inj (only parsing).
+Notation N_of_double := Nat2N.inj_double (only parsing).
+Notation N_of_double_plus_one := Nat2N.inj_succ_double (only parsing).
+Notation N_of_S := Nat2N.inj_succ (only parsing).
+Notation N_of_pred := Nat2N.inj_pred (only parsing).
+Notation N_of_plus := Nat2N.inj_add (only parsing).
+Notation N_of_minus := Nat2N.inj_sub (only parsing).
+Notation N_of_mult := Nat2N.inj_mul (only parsing).
+Notation N_of_div2 := Nat2N.inj_div2 (only parsing).
+Notation N_of_nat_compare := Nat2N.inj_compare (only parsing).
+Notation N_of_min := Nat2N.inj_min (only parsing).
+Notation N_of_max := Nat2N.inj_max (only parsing).
diff --git a/lib/bstack.mli b/theories/NArith/Nsqrt_def.v
index 39a5202a..edb6b289 100644
--- a/lib/bstack.mli
+++ b/theories/NArith/Nsqrt_def.v
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: bstack.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Import BinNat.
 
-(* Bounded stacks. If the depth is [None], then there is no depth limit. *)
+(** Obsolete file, see [BinNat] now,
+    only compatibility notations remain here. *)
 
-type 'a t
-
-val create : int -> 'a -> 'a t
-val push : 'a t -> 'a -> unit
-val app_push : 'a t -> ('a -> 'a) -> unit
-val app_repl : 'a t -> ('a -> 'a) -> unit
-val pop : 'a t -> unit
-val top : 'a t -> 'a
-val depth : 'a t -> int
-val size : 'a t -> int
+Notation Nsqrtrem := N.sqrtrem (only parsing).
+Notation Nsqrt := N.sqrt (only parsing).
+Notation Nsqrtrem_spec := N.sqrtrem_spec (only parsing).
+Notation Nsqrt_spec := (fun n => N.sqrt_spec n (N.le_0_l n)) (only parsing).
+Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (only parsing).
diff --git a/theories/NArith/Pminmax.v b/theories/NArith/Pminmax.v
deleted file mode 100644
index 6bac033c..00000000
--- a/theories/NArith/Pminmax.v
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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
deleted file mode 100644
index 29641dbe..00000000
--- a/theories/NArith/Pnat.v
+++ /dev/null
@@ -1,462 +0,0 @@
-(* -*- coding: utf-8 -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: Pnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import BinPos.
-
-(**********************************************************************)
-(** Properties of the injection from binary positive numbers to Peano
-    natural numbers *)
-
-(** Original development by Pierre Crégut, CNET, Lannion, France *)
-
-Require Import Le.
-Require Import Lt.
-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 *)
-
-Lemma Pmult_nat_succ_morphism :
- forall (p:positive) (n:nat), Pmult_nat (Psucc p) n = n + Pmult_nat p n.
-Proof.
-intro x; induction x as [p IHp| p IHp| ]; simpl in |- *; auto; intro m;
- rewrite IHp; rewrite plus_assoc; trivial.
-Qed.
-
-Lemma nat_of_P_succ_morphism :
- forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
-Proof.
-  intro; change (S (nat_of_P p)) with (1 + nat_of_P p) in |- *;
-   unfold nat_of_P in |- *; apply Pmult_nat_succ_morphism.
-Qed.
-
-Theorem Pmult_nat_plus_carry_morphism :
- forall (p q:positive) (n:nat),
-   Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n.
-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;
- intro m;
- [ rewrite IHp; rewrite plus_assoc; trivial with arith
- | rewrite IHp; rewrite plus_assoc; trivial with arith
- | rewrite Pmult_nat_succ_morphism; rewrite plus_assoc; trivial with arith
- | rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
-Qed.
-
-Theorem nat_of_P_plus_carry_morphism :
- forall p q:positive, nat_of_P (Pplus_carry p q) = S (nat_of_P (p + q)).
-Proof.
-intros; unfold nat_of_P in |- *; rewrite Pmult_nat_plus_carry_morphism;
- simpl in |- *; trivial with arith.
-Qed.
-
-Theorem Pmult_nat_l_plus_morphism :
- forall (p q:positive) (n:nat),
-   Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
-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;
- [ 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)));
-    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)));
-    apply plus_assoc_reverse
- | intros m; rewrite IHp; apply plus_permute
- | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
-Qed.
-
-Theorem nat_of_P_plus_morphism :
- forall p q:positive, nat_of_P (p + q) = nat_of_P p + nat_of_P q.
-Proof.
-intros x y; exact (Pmult_nat_l_plus_morphism x y 1).
-Qed.
-
-(** [Pmult_nat] is a morphism for addition *)
-
-Lemma Pmult_nat_r_plus_morphism :
- forall (p:positive) (n:nat),
-   Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
-Proof.
-intro y; induction y as [p H| p H| ]; intro m;
- [ simpl in |- *; rewrite H; rewrite plus_assoc_reverse;
-    rewrite (plus_permute m (Pmult_nat p (m + m)));
-    rewrite plus_assoc_reverse; auto with arith
- | simpl in |- *; rewrite H; auto with arith
- | simpl in |- *; trivial with arith ].
-Qed.
-
-Lemma ZL6 : forall p:positive, Pmult_nat p 2 = nat_of_P p + nat_of_P p.
-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 :
- forall p q:positive, nat_of_P (p * q) = nat_of_P p * nat_of_P q.
-Proof.
-intros x y; induction x as [x' H| x' H| ];
- [ change (xI x' * y)%positive with (y + xO (x' * y))%positive in |- *;
-    rewrite nat_of_P_plus_morphism; unfold nat_of_P at 2 3 in |- *;
-    simpl in |- *; do 2 rewrite ZL6; rewrite H; rewrite mult_plus_distr_r;
-    reflexivity
- | unfold nat_of_P at 1 2 in |- *; simpl in |- *; do 2 rewrite ZL6; rewrite H;
-    rewrite mult_plus_distr_r; reflexivity
- | simpl in |- *; rewrite <- plus_n_O; reflexivity ].
-Qed.
-
-(** [nat_of_P] maps to the strictly positive subset of [nat] *)
-
-Lemma ZL4 : forall p:positive,  exists h : nat, nat_of_P p = S h.
-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 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 H2; auto with arith
- | exists 0; auto with arith ].
-Qed.
-
-(** Extra lemmas on [lt] on Peano natural numbers *)
-
-Lemma ZL7 : forall n m:nat, n < m -> n + n < m + m.
-Proof.
-intros m n H; apply lt_trans with (m := m + n);
- [ apply plus_lt_compat_l with (1 := H)
- | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
-Qed.
-
-Lemma ZL8 : forall n m:nat, n < m -> S (n + n) < m + m.
-Proof.
-intros m n H; apply le_lt_trans with (m := m + n);
- [ change (m + m < m + n) in |- *; apply plus_lt_compat_l with (1 := H)
- | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
-    from [compare] on [positive])
-
-    Part 1: [lt] on [positive] is finer than [lt] on [nat]
-*)
-
-Lemma nat_of_P_lt_Lt_compare_morphism :
- 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;
- [ unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; do 2 rewrite ZL6;
-    apply ZL7; apply H; simpl in H2; assumption
- | unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; apply ZL8;
-    apply H; simpl in H2; apply Pcompare_Gt_Lt; assumption
- | simpl in |- *; discriminate H2
- | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    elim (Pcompare_Lt_Lt p q H2);
-    [ intros H3; apply lt_S; apply ZL7; apply H; apply H3
-    | intros E; rewrite E; apply lt_n_Sn ]
- | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    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 |- *;
-    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;
-    apply lt_n_S; apply lt_O_Sn
- | simpl in |- *; discriminate H2 ].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
-    from [compare] on [positive])
-
-    Part 1: [gt] on [positive] is finer than [gt] on [nat]
-*)
-
-Lemma nat_of_P_gt_Gt_compare_morphism :
- forall p q:positive, (p ?= q) Eq = Gt -> nat_of_P p > nat_of_P q.
-Proof.
-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
-    from [compare] on [positive])
-
-    Part 2: [lt] on [nat] is finer than [lt] on [positive]
-*)
-
-Lemma nat_of_P_lt_Lt_compare_complement_morphism :
- forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q) Eq = Lt.
-Proof.
- 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
-    from [compare] on [positive])
-
-    Part 2: [gt] on [nat] is finer than [gt] on [positive]
-*)
-
-Lemma nat_of_P_gt_Gt_compare_complement_morphism :
- forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q) Eq = Gt.
-Proof.
- 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.
-induction p; simpl in |- *; auto with arith.
-intro m; apply le_trans with (m + m); auto with arith.
-Qed.
-
-Lemma lt_O_nat_of_P : forall p:positive, 0 < nat_of_P p.
-intro; unfold nat_of_P in |- *; apply lt_le_trans with 1; auto with arith.
-apply le_Pmult_nat.
-Qed.
-
-(** Pmult_nat permutes with multiplication *)
-
-Lemma Pmult_nat_mult_permute :
- forall (p:positive) (n m:nat), Pmult_nat p (m * n) = m * Pmult_nat p n.
-Proof.
-  simple induction p. intros. simpl in |- *. rewrite mult_plus_distr_l. rewrite <- (mult_plus_distr_l m n n).
-  rewrite (H (n + n) m). reflexivity.
-  intros. simpl in |- *. rewrite <- (mult_plus_distr_l m n n). apply H.
-  trivial.
-Qed.
-
-Lemma Pmult_nat_2_mult_2_permute :
- forall p:positive, Pmult_nat p 2 = 2 * Pmult_nat p 1.
-Proof.
-  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
-Qed.
-
-Lemma Pmult_nat_4_mult_2_permute :
- forall p:positive, Pmult_nat p 4 = 2 * Pmult_nat p 2.
-Proof.
-  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
-Qed.
-
-(** Mapping of xH, xO and xI through [nat_of_P] *)
-
-Lemma nat_of_P_xH : nat_of_P 1 = 1.
-Proof.
-  reflexivity.
-Qed.
-
-Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p.
-Proof.
-  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.
-  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
-    binary positive numbers *)
-
-(** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *)
-
-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.
-induction n as [|n H].
-reflexivity.
-simpl; rewrite nat_of_P_succ_morphism, H; auto.
-Qed.
-
-(** Miscellaneous lemmas on [P_of_succ_nat] *)
-
-Lemma ZL3 :
- forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n).
-Proof.
-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.
-induction n as [| n H]; simpl;
- [ auto with arith
- | rewrite <- plus_n_Sm; simpl; simpl in H; rewrite H;
-    auto with arith ].
-Qed.
-
-(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *)
-
-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.
-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
-    on [positive] *)
-
-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; 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
-    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) 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.
-
-
-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;
- 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 |- *;
- apply le_n_S; apply le_plus_r.
-Qed.
-
-(** Comparison and subtraction *)
-
-Lemma Pcompare_minus_r :
- forall p q r:positive,
-   (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;
- [ rewrite nat_of_P_minus_morphism;
-    [ apply plus_lt_reg_l with (p := nat_of_P q); rewrite le_plus_minus_r;
-       [ 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;
-             assumption
-          | apply lt_le_weak; 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 ]
-    | assumption ]
- | assumption ].
-Qed.
-
-Lemma Pcompare_minus_l :
- forall p q r:positive,
-   (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;
- [ rewrite nat_of_P_minus_morphism;
-    [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
-       rewrite le_plus_minus_r;
-       [ rewrite le_plus_minus_r;
-          [ apply nat_of_P_lt_Lt_compare_morphism; assumption
-          | apply lt_le_weak; 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 ]
-    | assumption ]
- | assumption ].
-Qed.
-
-(** Distributivity of multiplication over subtraction *)
-
-Theorem Pmult_minus_distr_l :
- forall p q 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;
- [ rewrite nat_of_P_minus_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 |- *;
-       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 ].
-Qed.
diff --git a/theories/NArith/intro.tex b/theories/NArith/intro.tex
index 83eed970..bf39bc36 100644
--- a/theories/NArith/intro.tex
+++ b/theories/NArith/intro.tex
@@ -1,4 +1,4 @@
-\section{Binary positive and non negative integers : NArith}\label{NArith}
+\section{Binary natural numbers : NArith}\label{NArith}
 
 Here are defined various arithmetical notions and their properties,
 similar to those of {\tt Arith}.
diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget
index 32f94f01..e76033f7 100644
--- a/theories/NArith/vo.itarget
+++ b/theories/NArith/vo.itarget
@@ -1,12 +1,10 @@
+BinNatDef.vo
 BinNat.vo
-BinPos.vo
 NArith.vo
 Ndec.vo
 Ndigits.vo
 Ndist.vo
 Nnat.vo
-Pnat.vo
-POrderedType.vo
-Pminmax.vo
-NOrderedType.vo
-Nminmax.vo
+Ndiv_def.vo
+Nsqrt_def.vo
+Ngcd_def.vo
\ No newline at end of file
diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v
index 510b6888..26850688 100644
--- a/theories/Numbers/BigNumPrelude.v
+++ b/theories/Numbers/BigNumPrelude.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: BigNumPrelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** * BigNumPrelude *)
 
 (** Auxillary functions & theorems used for arbitrary precision efficient
@@ -102,7 +100,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
   intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith.
   apply Zle_trans with ((b-1)*(b-1)).
   apply Zmult_le_compat;auto with zarith.
-  apply Zeq_le;ring.
+  apply Zeq_le; ring.
  Qed.
 
  Lemma sum_mul_carry : forall xh xl yh yl wc cc beta,
@@ -315,7 +313,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   apply  Zdiv_le_lower_bound;auto with zarith.
   replace (2^p) with 0.
   destruct x;compute;intro;discriminate.
-  destruct p;trivial;discriminate z.
+  destruct p;trivial;discriminate.
  Qed.
 
  Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y.
@@ -327,7 +325,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   assert (0 < 2^p);auto with zarith.
   replace (2^p) with 0.
   destruct x;change (0<y);auto with zarith.
-  destruct p;trivial;discriminate z.
+  destruct p;trivial;discriminate.
  Qed.
 
  Theorem Zgcd_div_pos a b:
diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v
new file mode 100644
index 00000000..dfb2c502
--- /dev/null
+++ b/theories/Numbers/BinNums.v
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Binary Numerical Datatypes *)
+
+Set Implicit Arguments.
+(* For compatibility, we will not use generic equality functions *)
+Local Unset Boolean Equality Schemes.
+
+Declare ML Module "z_syntax_plugin".
+
+(** [positive] is a datatype representing the strictly positive integers
+   in a binary way. Starting from 1 (represented by [xH]), one can
+   add a new least significant digit via [xO] (digit 0) or [xI] (digit 1).
+   Numbers in [positive] can also be denoted using a decimal notation;
+   e.g. [6%positive] abbreviates [xO (xI xH)] *)
+
+Inductive positive : Set :=
+  | xI : positive -> positive
+  | xO : positive -> positive
+  | xH : positive.
+
+Delimit Scope positive_scope with positive.
+Bind Scope positive_scope with positive.
+Arguments xO _%positive.
+Arguments xI _%positive.
+
+(** [N] is a datatype representing natural numbers in a binary way,
+    by extending the [positive] datatype with a zero.
+    Numbers in [N] can also be denoted using a decimal notation;
+    e.g. [6%N] abbreviates [Npos (xO (xI xH))] *)
+
+Inductive N : Set :=
+  | N0 : N
+  | Npos : positive -> N.
+
+Delimit Scope N_scope with N.
+Bind Scope N_scope with N.
+Arguments Npos _%positive.
+
+(** [Z] is a datatype representing the integers in a binary way.
+    An integer is either zero or a strictly positive number
+    (coded as a [positive]) or a strictly negative number
+    (whose opposite is stored as a [positive] value).
+    Numbers in [Z] can also be denoted using a decimal notation;
+    e.g. [(-6)%Z] abbreviates [Zneg (xO (xI xH))] *)
+
+Inductive Z : Set :=
+  | Z0 : Z
+  | Zpos : positive -> Z
+  | Zneg : positive -> Z.
+
+Delimit Scope Z_scope with Z.
+Bind Scope Z_scope with Z.
+Arguments Zpos _%positive.
+Arguments Zneg _%positive.
diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
index fa097802..59656eed 100644
--- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
+++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(* $Id: CyclicAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** * Signature and specification of a bounded integer structure *)
 
 (** This file specifies how to represent [Z/nZ] when [n=2^d],
@@ -26,352 +24,300 @@ Local Open Scope Z_scope.
 
 (** First, a description via an operator record and a spec record. *)
 
-Section Z_nZ_Op.
-
- Variable znz : Type.
+Module ZnZ.
 
- Record znz_op := mk_znz_op {
+ Class Ops (t:Type) := MkOps {
 
     (* Conversion functions with Z *)
-    znz_digits : positive;
-    znz_zdigits: znz;
-    znz_to_Z   : znz -> Z;
-    znz_of_pos : positive -> N * znz; (* Euclidean division by [2^digits] *)
-    znz_head0  : znz -> znz; (* number of digits 0 in front of the number *)
-    znz_tail0  : znz -> znz; (* number of digits 0 at the bottom of the number *)
+    digits : positive;
+    zdigits: t;
+    to_Z   : t -> Z;
+    of_pos : positive -> N * t; (* Euclidean division by [2^digits] *)
+    head0  : t -> t; (* number of digits 0 in front of the number *)
+    tail0  : t -> t; (* number of digits 0 at the bottom of the number *)
 
     (* Basic numbers *)
-    znz_0   : znz;
-    znz_1   : znz;
-    znz_Bm1 : znz;  (* [2^digits-1], which is equivalent to [-1] *)
+    zero : t;
+    one  : t;
+    minus_one : t;  (* [2^digits-1], which is equivalent to [-1] *)
 
     (* Comparison *)
-    znz_compare     : znz -> znz -> comparison;
-    znz_eq0         : znz -> bool;
+    compare     : t -> t -> comparison;
+    eq0         : t -> bool;
 
     (* Basic arithmetic operations *)
-    znz_opp_c       : znz -> carry znz;
-    znz_opp         : znz -> znz;
-    znz_opp_carry   : znz -> znz; (* the carry is known to be -1 *)
-
-    znz_succ_c      : znz -> carry znz;
-    znz_add_c       : znz -> znz -> carry znz;
-    znz_add_carry_c : znz -> znz -> carry znz;
-    znz_succ        : znz -> znz;
-    znz_add         : znz -> znz -> znz;
-    znz_add_carry   : znz -> znz -> znz;
-
-    znz_pred_c      : znz -> carry znz;
-    znz_sub_c       : znz -> znz -> carry znz;
-    znz_sub_carry_c : znz -> znz -> carry znz;
-    znz_pred        : znz -> znz;
-    znz_sub         : znz -> znz -> znz;
-    znz_sub_carry   : znz -> znz -> znz;
-
-    znz_mul_c       : znz -> znz -> zn2z znz;
-    znz_mul         : znz -> znz -> znz;
-    znz_square_c    : znz -> zn2z znz;
+    opp_c       : t -> carry t;
+    opp         : t -> t;
+    opp_carry   : t -> t; (* the carry is known to be -1 *)
+
+    succ_c      : t -> carry t;
+    add_c       : t -> t -> carry t;
+    add_carry_c : t -> t -> carry t;
+    succ        : t -> t;
+    add         : t -> t -> t;
+    add_carry   : t -> t -> t;
+
+    pred_c      : t -> carry t;
+    sub_c       : t -> t -> carry t;
+    sub_carry_c : t -> t -> carry t;
+    pred        : t -> t;
+    sub         : t -> t -> t;
+    sub_carry   : t -> t -> t;
+
+    mul_c       : t -> t -> zn2z t;
+    mul         : t -> t -> t;
+    square_c    : t -> zn2z t;
 
     (* Special divisions operations *)
-    znz_div21       : znz -> znz -> znz -> znz*znz;
-    znz_div_gt      : znz -> znz -> znz * znz; (* specialized version of [znz_div] *)
-    znz_div         : znz -> znz -> znz * znz;
+    div21       : t -> t -> t -> t*t;
+    div_gt      : t -> t -> t * t; (* specialized version of [div] *)
+    div         : t -> t -> t * t;
 
-    znz_mod_gt      : znz -> znz -> znz; (* specialized version of [znz_mod] *)
-    znz_mod         : znz -> znz -> znz;
+    modulo_gt   : t -> t -> t; (* specialized version of [mod] *)
+    modulo      : t -> t -> t;
 
-    znz_gcd_gt      : znz -> znz -> znz; (* specialized version of [znz_gcd] *)
-    znz_gcd         : znz -> znz -> znz;
-    (* [znz_add_mul_div p i j] is a combination of the [(digits-p)]
+    gcd_gt      : t -> t -> t; (* specialized version of [gcd] *)
+    gcd         : t -> t -> t;
+    (* [add_mul_div p i j] is a combination of the [(digits-p)]
        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] *)
-    znz_pos_mod     : znz -> znz -> znz;
+       [add_mul_div p i j = i*2^p+j/2^(digits-p)] *)
+    add_mul_div : t -> t -> t -> t;
+    (* [pos_mod p i] is [i mod 2^p] *)
+    pos_mod     : t -> t -> t;
 
-    znz_is_even     : znz -> bool;
+    is_even     : t -> bool;
     (* square root *)
-    znz_sqrt2       : znz -> znz -> znz * carry znz;
-    znz_sqrt        : znz -> znz  }.
-
-End Z_nZ_Op.
-
-Section Z_nZ_Spec.
- Variable w : Type.
- Variable w_op : znz_op w.
-
- Let w_digits      := w_op.(znz_digits).
- Let w_zdigits     := w_op.(znz_zdigits).
- Let w_to_Z        := w_op.(znz_to_Z).
- Let w_of_pos      := w_op.(znz_of_pos).
- Let w_head0       := w_op.(znz_head0).
- Let w_tail0       := w_op.(znz_tail0).
-
- Let w0            := w_op.(znz_0).
- Let w1            := w_op.(znz_1).
- Let wBm1          := w_op.(znz_Bm1).
-
- Let w_compare     := w_op.(znz_compare).
- Let w_eq0         := w_op.(znz_eq0).
-
- Let w_opp_c       := w_op.(znz_opp_c).
- Let w_opp         := w_op.(znz_opp).
- Let w_opp_carry   := w_op.(znz_opp_carry).
-
- Let w_succ_c      := w_op.(znz_succ_c).
- Let w_add_c       := w_op.(znz_add_c).
- Let w_add_carry_c := w_op.(znz_add_carry_c).
- Let w_succ        := w_op.(znz_succ).
- Let w_add         := w_op.(znz_add).
- Let w_add_carry   := w_op.(znz_add_carry).
+    sqrt2       : t -> t -> t * carry t;
+    sqrt        : t -> t  }.
 
- Let w_pred_c      := w_op.(znz_pred_c).
- Let w_sub_c       := w_op.(znz_sub_c).
- Let w_sub_carry_c := w_op.(znz_sub_carry_c).
- Let w_pred        := w_op.(znz_pred).
- Let w_sub         := w_op.(znz_sub).
- Let w_sub_carry   := w_op.(znz_sub_carry).
+ Section Specs.
+ Context {t : Type}{ops : Ops t}.
 
- 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).
+ Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
- Let w_div21       := w_op.(znz_div21).
- Let w_div_gt      := w_op.(znz_div_gt).
- Let w_div         := w_op.(znz_div).
-
- Let w_mod_gt      := w_op.(znz_mod_gt).
- Let w_mod         := w_op.(znz_mod).
-
- 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_pos_mod     := w_op.(znz_pos_mod).
-
- Let w_is_even     := w_op.(znz_is_even).
- Let w_sqrt2       := w_op.(znz_sqrt2).
- Let w_sqrt        := w_op.(znz_sqrt).
-
- Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
-
- Let wB := base w_digits.
+ Let wB := base digits.
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c)  (at level 0, x at level 99).
+   (interp_carry 1 wB to_Z c)  (at level 0, x at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c)  (at level 0, x at level 99).
+   (interp_carry (-1) wB to_Z c)  (at level 0, x at level 99).
 
  Notation "[|| x ||]" :=
-   (zn2z_to_Z wB w_to_Z x)  (at level 0, x at level 99).
+   (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).
 
- Record znz_spec := mk_znz_spec {
+ Class Specs := MkSpecs {
 
     (* Conversion functions with Z *)
     spec_to_Z   : forall x, 0 <= [| x |] < wB;
     spec_of_pos : forall p,
-           Zpos p = (Z_of_N (fst (w_of_pos p)))*wB + [|(snd (w_of_pos p))|];
-    spec_zdigits : [| w_zdigits |] = Zpos w_digits;
-    spec_more_than_1_digit: 1 < Zpos w_digits;
+           Zpos p = (Z_of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|];
+    spec_zdigits : [| zdigits |] = Zpos digits;
+    spec_more_than_1_digit: 1 < Zpos digits;
 
     (* Basic numbers *)
-    spec_0   : [|w0|] = 0;
-    spec_1   : [|w1|] = 1;
-    spec_Bm1 : [|wBm1|] = wB - 1;
+    spec_0   : [|zero|] = 0;
+    spec_1   : [|one|] = 1;
+    spec_m1 : [|minus_one|] = wB - 1;
 
     (* Comparison *)
-    spec_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end;
-    spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0;
+    spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]);
+    (* NB: the spec of [eq0] is deliberately partial,
+       see DoubleCyclic where [eq0 x = true <-> x = W0] *)
+    spec_eq0 : forall x, eq0 x = true -> [|x|] = 0;
     (* Basic arithmetic operations *)
-    spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|];
-    spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB;
-    spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1;
-
-    spec_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1;
-    spec_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|];
-    spec_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1;
-    spec_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB;
-    spec_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB;
+    spec_opp_c : forall x, [-|opp_c x|] = -[|x|];
+    spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB;
+    spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1;
+
+    spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1;
+    spec_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|];
+    spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1;
+    spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB;
+    spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB;
     spec_add_carry :
-	 forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB;
+	 forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB;
 
-    spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1;
-    spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|];
-    spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1;
-    spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB;
-    spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB;
+    spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1;
+    spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|];
+    spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1;
+    spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB;
+    spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB;
     spec_sub_carry :
-	 forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB;
+	 forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB;
 
-    spec_mul_c : forall x y, [|| w_mul_c x y ||] = [|x|] * [|y|];
-    spec_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB;
-    spec_square_c : forall x, [|| w_square_c x||] = [|x|] * [|x|];
+    spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|];
+    spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB;
+    spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|];
 
     (* Special divisions operations *)
     spec_div21 : forall a1 a2 b,
       wB/2 <= [|b|] ->
       [|a1|] < [|b|] ->
-      let (q,r) := w_div21 a1 a2 b in
+      let (q,r) := div21 a1 a2 b in
       [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|];
     spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
-      let (q,r) := w_div_gt a b in
+      let (q,r) := div_gt a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|];
     spec_div : forall a b, 0 < [|b|] ->
-      let (q,r) := w_div a b in
+      let (q,r) := div a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\
       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_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
+      [|modulo_gt a b|] = [|a|] mod [|b|];
+    spec_modulo :  forall a b, 0 < [|b|] ->
+      [|modulo 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|];
+      Zis_gcd [|a|] [|b|] [|gcd_gt a b|];
+    spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|];
 
 
     (* shift operations *)
-    spec_head00:  forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits;
+    spec_head00:  forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits;
     spec_head0  : forall x,  0 < [|x|] ->
-	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB;
-    spec_tail00:  forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits;
+	 wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB;
+    spec_tail00:  forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits;
     spec_tail0  : forall x, 0 < [|x|] ->
-         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ;
+         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ;
     spec_add_mul_div : forall x y p,
-       [|p|] <= Zpos w_digits ->
-       [| w_add_mul_div p x y |] =
+       [|p|] <= Zpos digits ->
+       [| add_mul_div p x y |] =
          ([|x|] * (2 ^ [|p|]) +
-          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB;
+          [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB;
     spec_pos_mod : forall w p,
-       [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]);
+       [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]);
     (* sqrt *)
     spec_is_even : forall x,
-      if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1;
+      if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1;
     spec_sqrt2 : forall x y,
        wB/ 4 <= [|x|] ->
-       let (s,r) := w_sqrt2 x y in
+       let (s,r) := sqrt2 x y in
           [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
           [+|r|] <= 2 * [|s|];
     spec_sqrt : forall x,
-       [|w_sqrt x|] ^ 2 <= [|x|] < ([|w_sqrt x|] + 1) ^ 2
+       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2
   }.
 
-End Z_nZ_Spec.
+ End Specs.
+
+ Arguments Specs {t} ops.
+
+ (** Generic construction of double words *)
 
-(** Generic construction of double words *)
+ Section WW.
 
-Section WW.
+ Context {t : Type}{ops : Ops t}{specs : Specs ops}.
 
- Variable w : Type.
- Variable w_op : znz_op w.
- Variable op_spec : znz_spec w_op.
+ Let wB := base digits.
 
- 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 WO' (eq0:t->bool) zero h :=
+  if eq0 h then W0 else WW h zero.
 
- Definition znz_W0 h :=
-  if w_eq0 h then W0 else WW h w_0.
+ Definition WO := Eval lazy beta delta [WO'] in
+   let eq0 := ZnZ.eq0 in
+   let zero := ZnZ.zero in
+   WO' eq0 zero.
 
- Definition znz_0W l :=
-  if w_eq0 l then W0 else WW w_0 l.
+ Definition OW' (eq0:t->bool) zero l :=
+  if eq0 l then W0 else WW zero l.
 
- Definition znz_WW h l :=
-  if w_eq0 h then znz_0W l else WW h l.
+ Definition OW := Eval lazy beta delta [OW'] in
+   let eq0 := ZnZ.eq0 in
+   let zero := ZnZ.zero in
+   OW' eq0 zero.
 
- Lemma spec_W0 : forall h,
-   zn2z_to_Z wB w_to_Z (znz_W0 h) = (w_to_Z h)*wB.
+ Definition WW'  (eq0:t->bool) zero h l :=
+  if eq0 h then OW' eq0 zero l else WW h l.
+
+ Definition WW := Eval lazy beta delta [WW' OW'] in
+   let eq0 := ZnZ.eq0 in
+   let zero := ZnZ.zero in
+   WW' eq0 zero.
+
+ Lemma spec_WO : forall h,
+   zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB.
  Proof.
- unfold zn2z_to_Z, znz_W0, w_to_Z; simpl; intros.
- case_eq (w_eq0 h); intros.
- rewrite (op_spec.(spec_eq0) _ H); auto.
- unfold w_0; rewrite op_spec.(spec_0); auto with zarith.
+ unfold zn2z_to_Z, WO; simpl; intros.
+ case_eq (eq0 h); intros.
+ rewrite (spec_eq0 _ H); auto.
+ rewrite spec_0; auto with zarith.
  Qed.
 
- Lemma spec_0W : forall l,
-   zn2z_to_Z wB w_to_Z (znz_0W l) = w_to_Z l.
+ Lemma spec_OW : forall l,
+   zn2z_to_Z wB to_Z (OW l) = to_Z l.
  Proof.
- unfold zn2z_to_Z, znz_0W, w_to_Z; simpl; intros.
- case_eq (w_eq0 l); intros.
- rewrite (op_spec.(spec_eq0) _ H); auto.
- unfold w_0; rewrite op_spec.(spec_0); auto with zarith.
+ unfold zn2z_to_Z, OW; simpl; intros.
+ case_eq (eq0 l); intros.
+ rewrite (spec_eq0 _ H); auto.
+ rewrite spec_0; auto with zarith.
  Qed.
 
  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.
+  zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l.
  Proof.
- unfold znz_WW, w_to_Z; simpl; intros.
- case_eq (w_eq0 h); intros.
- rewrite (op_spec.(spec_eq0) _ H); auto.
- rewrite spec_0W; auto.
+ unfold WW; simpl; intros.
+ case_eq (eq0 h); intros.
+ rewrite (spec_eq0 _ H); auto.
+ fold (OW l).
+ rewrite spec_OW; auto.
  simpl; auto.
  Qed.
 
-End WW.
-
-(** Injecting [Z] numbers into a cyclic structure *)
+ End WW.
 
-Section znz_of_pos.
+ (** Injecting [Z] numbers into a cyclic structure *)
 
- Variable w : Type.
- Variable w_op : znz_op w.
- Variable op_spec : znz_spec w_op.
+ Section Of_Z.
 
- Notation "[| x |]" := (znz_to_Z w_op x)  (at level 0, x at level 99).
+ Context {t : Type}{ops : Ops t}{specs : Specs ops}.
 
- Definition znz_of_Z (w:Type) (op:znz_op w) z :=
- match z with
- | Zpos p => snd (op.(znz_of_pos) p)
- | _ => op.(znz_0)
- end.
+ Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
- Theorem znz_of_pos_correct:
-   forall p, Zpos p < base (znz_digits w_op) -> [|(snd (znz_of_pos w_op p))|] = Zpos p.
+ Theorem of_pos_correct:
+   forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p.
+ Proof.
  intros p Hp.
- generalize (spec_of_pos op_spec p).
- case (znz_of_pos w_op p); intros n w1; simpl.
+ generalize (spec_of_pos p).
+ case (of_pos p); intros n w1; simpl.
  case n; simpl Npos; auto with zarith.
  intros p1 Hp1; contradict Hp; apply Zle_not_lt.
- rewrite Hp1; auto with zarith.
- match goal with |- _ <= ?X + ?Y =>
-  apply Zle_trans with X; auto with zarith
- end.
- match goal with |- ?X <= _ =>
-  pattern X at 1; rewrite <- (Zmult_1_l);
-  apply Zmult_le_compat_r; auto with zarith
- end.
+ replace (base digits) with (1 * base digits + 0) by ring.
+ rewrite Hp1.
+ apply Zplus_le_compat.
+ apply Zmult_le_compat; auto with zarith.
  case p1; simpl; intros; red; simpl; intros; discriminate.
  unfold base; auto with zarith.
- case (spec_to_Z op_spec w1); auto with zarith.
+ case (spec_to_Z w1); auto with zarith.
  Qed.
 
- Theorem znz_of_Z_correct:
-   forall p, 0 <= p < base (znz_digits w_op) -> [|znz_of_Z w_op p|] = p.
+ Definition of_Z z :=
+ match z with
+ | Zpos p => snd (of_pos p)
+ | _ => zero
+ end.
+
+ Theorem of_Z_correct:
+   forall p, 0 <= p < base digits -> [|of_Z p|] = p.
+ Proof.
  intros p; case p; simpl; try rewrite spec_0; auto.
- intros; rewrite znz_of_pos_correct; auto with zarith.
+ intros; rewrite of_pos_correct; auto with zarith.
  intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto.
  Qed.
-End znz_of_pos.
 
+ End Of_Z.
+
+End ZnZ.
 
 (** A modular specification grouping the earlier records. *)
 
 Module Type CyclicType.
- Parameter w : Type.
- Parameter w_op : znz_op w.
- Parameter w_spec : znz_spec w_op.
+ Parameter t : Type.
+ Declare Instance ops : ZnZ.Ops t.
+ Declare Instance specs : ZnZ.Specs ops.
 End CyclicType.
 
 
@@ -379,38 +325,29 @@ End CyclicType.
 
 Module CyclicRing (Import Cyclic : CyclicType).
 
-Definition t := w.
-
-Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).
+Local Notation "[| x |]" := (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)
+Local Notation "0" := ZnZ.zero.
+Local Notation "1" := ZnZ.one.
+Local Infix "+" := ZnZ.add.
+Local Infix "-" := ZnZ.sub.
+Local Notation "- x" := (ZnZ.opp x).
+Local Infix "*" := ZnZ.mul.
+Local Notation wB := (base ZnZ.digits).
+
+Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul
+ ZnZ.spec_opp ZnZ.spec_sub
  : cyclic.
 
-Ltac zify :=
- unfold eq, zero, one, add, sub, mul, opp in *; autorewrite with cyclic.
+Ltac zify := unfold eq 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).
+apply Zmod_small. apply ZnZ.spec_to_Z.
 Qed.
 
 Lemma add_comm : forall x y, x + y == y + x.
@@ -426,7 +363,7 @@ 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).
+apply Zmod_small. apply ZnZ.spec_to_Z.
 Qed.
 
 Lemma mul_comm : forall x y, x * y == y * x.
@@ -444,22 +381,22 @@ 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.
+Lemma add_opp_r : forall x y, x + - y == x-y.
 Proof.
 intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Zminus.
-destruct (Z_eq_dec ([|y|] mod !!) 0) as [EQ|NEQ].
+destruct (Z_eq_dec ([|y|] mod wB) 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.
+Lemma add_opp_diag_r : forall x, x + - 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.
+Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq.
 Proof.
 constructor.
 exact add_0_l. exact add_comm. exact add_assoc.
@@ -470,15 +407,26 @@ exact add_opp_diag_r.
 Qed.
 
 Definition eqb x y :=
- match w_op.(znz_compare) x y with Eq => true | _ => false end.
+ match 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.
+ rewrite ZnZ.spec_compare.
+ case Zcompare_spec; intuition; try discriminate.
+Qed.
 
+(* POUR HUGO:
 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.
+ intros. unfold eqb, eq. generalize (ZnZ.spec_compare x y).
+ case (ZnZ.compare x y); intuition; try discriminate.
+ (* BUG ?! using destruct instead of case won't work:
+   it gives 3 subcases, but ZnZ.compare x y is still there in them! *)
 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
+End CyclicRing.
diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
index 92215ba9..c52cbe10 100644
--- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v
+++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NZAxioms.
 Require Import BigNumPrelude.
 Require Import DoubleType.
@@ -27,21 +25,19 @@ Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig.
 
 Local Open Scope Z_scope.
 
-Definition t := w.
-
-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)).
+Local Notation wB := (base ZnZ.digits).
 
-Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).
+Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99).
 
 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).
+Definition zero := ZnZ.zero.
+Definition one := ZnZ.one.
+Definition two := ZnZ.succ ZnZ.one.
+Definition succ := ZnZ.succ.
+Definition pred := ZnZ.pred.
+Definition add := ZnZ.add.
+Definition sub := ZnZ.sub.
+Definition mul := ZnZ.mul.
 
 Local Infix "=="  := eq (at level 70).
 Local Notation "0" := zero.
@@ -51,41 +47,25 @@ Local Infix "+" := add.
 Local Infix "-" := sub.
 Local Infix "*" := mul.
 
-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.
+Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred
+ ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic.
+Ltac zify :=
+ unfold eq, zero, one, two, succ, pred, add, sub, mul in *;
+ autorewrite with cyclic.
+Ltac zcongruence := repeat red; intros; zify; congruence.
 
 Instance eq_equiv : Equivalence eq.
 Proof.
 unfold eq. firstorder.
 Qed.
 
-Instance succ_wd : Proper (eq ==> eq) succ.
-Proof.
-wcongruence.
-Qed.
-
-Instance pred_wd : Proper (eq ==> eq) pred.
-Proof.
-wcongruence.
-Qed.
-
-Instance add_wd : Proper (eq ==> eq ==> eq) add.
-Proof.
-wcongruence.
-Qed.
-
-Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
-Proof.
-wcongruence.
-Qed.
+Local Obligation Tactic := zcongruence.
 
-Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
-Proof.
-wcongruence.
-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.
 
 Theorem gt_wB_1 : 1 < wB.
 Proof.
@@ -97,39 +77,41 @@ Proof.
 pose proof gt_wB_1; auto with zarith.
 Qed.
 
+Lemma one_mod_wB : 1 mod wB = 1.
+Proof.
+rewrite Zmod_small. reflexivity. split. auto with zarith. apply gt_wB_1.
+Qed.
+
 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.
-reflexivity.
-now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
+intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod.
 Qed.
 
 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.
-reflexivity.
-now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
+intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod.
 Qed.
 
 Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |].
 Proof.
-intro n; rewrite Zmod_small. reflexivity. apply w_spec.(spec_to_Z).
+intro n; rewrite Zmod_small. reflexivity. apply ZnZ.spec_to_Z.
 Qed.
 
 Theorem pred_succ : forall n, P (S n) == n.
 Proof.
-intro n. wsimpl.
+intro n. zify.
 rewrite <- pred_mod_wB.
-replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod.
+replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod.
 Qed.
 
-Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0.
+Theorem one_succ : one == succ zero.
 Proof.
-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].
+zify; simpl. now rewrite one_mod_wB.
+Qed.
+
+Theorem two_succ : two == succ one.
+Proof.
+reflexivity.
 Qed.
 
 Section Induction.
@@ -140,21 +122,22 @@ Hypothesis A0 : A 0.
 Hypothesis AS : forall n, A n <-> A (S n).
  (* Below, we use only -> direction *)
 
-Let B (n : Z) := A (Z_to_NZ n).
+Let B (n : Z) := A (ZnZ.of_Z n).
 
 Lemma B0 : B 0.
 Proof.
-unfold B. now rewrite Z_to_NZ_0.
+unfold B.
+setoid_replace (ZnZ.of_Z 0) with zero. assumption.
+red; zify. apply ZnZ.of_Z_correct. auto using gt_wB_0 with zarith.
 Qed.
 
 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)). assumption.
-wsimpl.
-unfold NZ_to_Z, Z_to_NZ.
-do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]).
+unfold B in *. apply AS in H3.
+setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). assumption.
+zify.
+rewrite 2 ZnZ.of_Z_correct; auto with zarith.
 symmetry; apply Zmod_small; auto with zarith.
 Qed.
 
@@ -167,25 +150,23 @@ Qed.
 
 Theorem bi_induction : forall n, A n.
 Proof.
-intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)).
-apply B_holds. apply w_spec.(spec_to_Z).
-unfold eq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct.
-reflexivity.
-exact w_spec.
-apply w_spec.(spec_to_Z).
+intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)).
+apply B_holds. apply ZnZ.spec_to_Z.
+red. symmetry. apply ZnZ.of_Z_correct.
+apply ZnZ.spec_to_Z.
 Qed.
 
 End Induction.
 
 Theorem add_0_l : forall n, 0 + n == n.
 Proof.
-intro n. wsimpl.
-rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)].
+intro n. zify.
+rewrite Zplus_0_l. apply Zmod_small. apply ZnZ.spec_to_Z.
 Qed.
 
 Theorem add_succ_l : forall n m, (S n) + m == S (n + m).
 Proof.
-intros n m. wsimpl.
+intros n m. zify.
 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.
@@ -193,25 +174,27 @@ Qed.
 
 Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-intro n. wsimpl. rewrite Zminus_0_r. apply NZ_to_Z_mod.
+intro n. zify. rewrite Zminus_0_r. apply NZ_to_Z_mod.
 Qed.
 
 Theorem sub_succ_r : forall n m, n - (S m) == P (n - m).
 Proof.
-intros n m. wsimpl. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l.
+intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l.
 now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z
-     by auto with zarith.
+     by ring.
 Qed.
 
 Theorem mul_0_l : forall n, 0 * n == 0.
 Proof.
-intro n. wsimpl. now rewrite Zmult_0_l.
+intro n. now zify.
 Qed.
 
 Theorem mul_succ_l : forall n m, (S n) * m == n * m + m.
 Proof.
-intros n m. wsimpl. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
+intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
 now rewrite Zmult_plus_distr_l, Zmult_1_l.
 Qed.
 
+Definition t := t.
+
 End NZCyclicAxiomsMod.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
index 305d77a9..deb216dd 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
index 3d44f96b..e6c5a0e0 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,16 +8,16 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
-Require Import ZArith.
+Require Import ZArith Ndigits.
 Require Import BigNumPrelude.
 Require Import DoubleType.
 
 Local Open Scope Z_scope.
 
+Local Infix "<<" := Pos.shiftl_nat (at level 30).
+
 Section DoubleBase.
  Variable w : Type.
  Variable w_0   : w.
@@ -70,13 +70,7 @@ Section DoubleBase.
      end
   end.
 
- Fixpoint double_digits (n:nat) : positive :=
-  match n with
-  | O => w_digits
-  | S n => xO (double_digits n)
-  end.
-
- Definition double_wB n := base (double_digits n).
+ Definition double_wB n := base (w_digits << n).
 
  Fixpoint double_to_Z (n:nat) : word w n -> Z :=
   match n return word w n -> Z with
@@ -167,11 +161,7 @@ Section DoubleBase.
   Variable spec_w_0W  : forall l, [[w_0W l]] = [|l|].
   Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
   Variable spec_w_compare : forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+     w_compare x y = Zcompare [|x|] [|y|].
 
   Lemma wwB_wBwB : wwB = wB^2.
   Proof.
@@ -297,11 +287,10 @@ Section DoubleBase.
   Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n).
   Proof.
    intros n;unfold double_wB;simpl.
-   unfold base;rewrite (Zpos_xO (double_digits n)).
-   replace  (2 * Zpos (double_digits n)) with
-     (Zpos (double_digits n) + Zpos (double_digits n)).
+   unfold base. rewrite Pshiftl_nat_S, (Zpos_xO (_ << _)).
+   replace  (2 * Zpos (w_digits << n)) with
+     (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring.
    symmetry; apply Zpower_exp;intro;discriminate.
-   ring.
   Qed.
 
   Lemma double_wB_pos:
@@ -315,7 +304,7 @@ Section DoubleBase.
   Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
   intros n; elim n; clear n; auto.
-    unfold double_wB, double_digits; auto with zarith.
+    unfold double_wB, "<<"; auto with zarith.
   intros n H1; rewrite <- double_wB_wwB.
   apply Zle_trans with (wB * 1).
     rewrite Zmult_1_r; apply Zle_refl.
@@ -408,35 +397,40 @@ Section DoubleBase.
    intros a b c d H1; apply beta_lex_inv with (1 := H1); auto.
   Qed.
 
+  Ltac comp2ord := match goal with
+   | |- Lt = (?x ?= ?y) => symmetry; change (x < y)
+   | |- Gt = (?x ?= ?y) => symmetry; change (x > y); apply Zlt_gt
+  end.
+
   Lemma spec_ww_compare : forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+    ww_compare x y = Zcompare [[x]] [[y]].
   Proof.
    destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial.
-   generalize (spec_w_compare w_0 yh);destruct (w_compare w_0 yh);
-    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.
+   (* 1st case *)
+   rewrite 2 spec_w_compare, spec_w_0.
+   destruct (Zcompare_spec 0 [|yh|]) as [H|H|H].
+   rewrite <- H;simpl. reflexivity.
+   symmetry. change (0 < [|yh|]*wB+[|yl|]).
+   change 0 with (0*wB+0). rewrite <- spec_w_0 at 2.
    apply wB_lex_inv;trivial.
-   absurd (0 <= [|yh|]). apply Zgt_not_le;trivial.
+   absurd (0 <= [|yh|]). apply Zlt_not_le; trivial.
    destruct (spec_to_Z yh);trivial.
-   generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0);
-    intros H;rewrite spec_w_0 in H.
-   rewrite H;simpl;rewrite <- spec_w_0;apply spec_w_compare.
-   absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial.
+   (* 2nd case *)
+   rewrite 2 spec_w_compare, spec_w_0.
+   destruct (Zcompare_spec [|xh|] 0) as [H|H|H].
+   rewrite H;simpl;reflexivity.
+   absurd (0 <= [|xh|]). apply Zlt_not_le; 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.
-
-   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];
-   trivial.
+   comp2ord.
+   change 0 with (0*wB+0). rewrite <- spec_w_0 at 2.
    apply wB_lex_inv;trivial.
-   apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial.
+   (* 3rd case *)
+   rewrite 2 spec_w_compare.
+   destruct (Zcompare_spec [|xh|] [|yh|]) as [H|H|H].
+   rewrite H.
+   symmetry. apply Zcompare_plus_compat.
+   comp2ord. apply wB_lex_inv;trivial.
+   comp2ord. apply wB_lex_inv;trivial.
   Qed.
 
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
index 006da1b3..00a84052 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -30,65 +28,65 @@ Local Open Scope Z_scope.
 
 Section Z_2nZ.
 
- Variable w : Type.
- Variable w_op : znz_op w.
- Let w_digits      := w_op.(znz_digits).
- Let w_zdigits      := w_op.(znz_zdigits).
+ Context {t : Type}{ops : ZnZ.Ops t}.
+
+ Let w_digits      := ZnZ.digits.
+ Let w_zdigits      := ZnZ.zdigits.
 
- Let w_to_Z        := w_op.(znz_to_Z).
- Let w_of_pos      := w_op.(znz_of_pos).
- Let w_head0       := w_op.(znz_head0).
- Let w_tail0       := w_op.(znz_tail0).
+ Let w_to_Z        := ZnZ.to_Z.
+ Let w_of_pos      := ZnZ.of_pos.
+ Let w_head0       := ZnZ.head0.
+ Let w_tail0       := ZnZ.tail0.
 
- Let w_0            := w_op.(znz_0).
- Let w_1            := w_op.(znz_1).
- Let w_Bm1          := w_op.(znz_Bm1).
+ Let w_0            := ZnZ.zero.
+ Let w_1            := ZnZ.one.
+ Let w_Bm1          := ZnZ.minus_one.
 
- Let w_compare     := w_op.(znz_compare).
- Let w_eq0         := w_op.(znz_eq0).
+ Let w_compare     := ZnZ.compare.
+ Let w_eq0         := ZnZ.eq0.
 
- Let w_opp_c       := w_op.(znz_opp_c).
- Let w_opp         := w_op.(znz_opp).
- Let w_opp_carry   := w_op.(znz_opp_carry).
+ Let w_opp_c       := ZnZ.opp_c.
+ Let w_opp         := ZnZ.opp.
+ Let w_opp_carry   := ZnZ.opp_carry.
 
- Let w_succ_c      := w_op.(znz_succ_c).
- Let w_add_c       := w_op.(znz_add_c).
- Let w_add_carry_c := w_op.(znz_add_carry_c).
- Let w_succ        := w_op.(znz_succ).
- Let w_add         := w_op.(znz_add).
- Let w_add_carry   := w_op.(znz_add_carry).
+ Let w_succ_c      := ZnZ.succ_c.
+ Let w_add_c       := ZnZ.add_c.
+ Let w_add_carry_c := ZnZ.add_carry_c.
+ Let w_succ        := ZnZ.succ.
+ Let w_add         := ZnZ.add.
+ Let w_add_carry   := ZnZ.add_carry.
 
- Let w_pred_c      := w_op.(znz_pred_c).
- Let w_sub_c       := w_op.(znz_sub_c).
- Let w_sub_carry_c := w_op.(znz_sub_carry_c).
- Let w_pred        := w_op.(znz_pred).
- Let w_sub         := w_op.(znz_sub).
- Let w_sub_carry   := w_op.(znz_sub_carry).
+ Let w_pred_c      := ZnZ.pred_c.
+ Let w_sub_c       := ZnZ.sub_c.
+ Let w_sub_carry_c := ZnZ.sub_carry_c.
+ Let w_pred        := ZnZ.pred.
+ Let w_sub         := ZnZ.sub.
+ Let w_sub_carry   := ZnZ.sub_carry.
 
 
- 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_mul_c       := ZnZ.mul_c.
+ Let w_mul         := ZnZ.mul.
+ Let w_square_c    := 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).
+ Let w_div21       := ZnZ.div21.
+ Let w_div_gt      := ZnZ.div_gt.
+ Let w_div         := ZnZ.div.
 
- Let w_mod_gt      := w_op.(znz_mod_gt).
- Let w_mod         := w_op.(znz_mod).
+ Let w_mod_gt      := ZnZ.modulo_gt.
+ Let w_mod         := ZnZ.modulo.
 
- Let w_gcd_gt      := w_op.(znz_gcd_gt).
- Let w_gcd         := w_op.(znz_gcd).
+ Let w_gcd_gt      := ZnZ.gcd_gt.
+ Let w_gcd         := ZnZ.gcd.
 
- Let w_add_mul_div := w_op.(znz_add_mul_div).
+ Let w_add_mul_div := ZnZ.add_mul_div.
 
- Let w_pos_mod := w_op.(znz_pos_mod).
+ Let w_pos_mod := ZnZ.pos_mod.
 
- Let w_is_even     := w_op.(znz_is_even).
- Let w_sqrt2       := w_op.(znz_sqrt2).
- Let w_sqrt        := w_op.(znz_sqrt).
+ Let w_is_even     := ZnZ.is_even.
+ Let w_sqrt2       := ZnZ.sqrt2.
+ Let w_sqrt        := ZnZ.sqrt.
 
- Let _zn2z := zn2z w.
+ Let _zn2z := zn2z t.
 
  Let wB := base w_digits.
 
@@ -105,9 +103,9 @@ Section Z_2nZ.
 
  Let to_Z := zn2z_to_Z wB w_to_Z.
 
- Let w_W0 := znz_W0 w_op.
- Let w_0W := znz_0W w_op.
- Let w_WW := znz_WW w_op.
+ Let w_W0 := ZnZ.WO.
+ Let w_0W := ZnZ.OW.
+ Let w_WW := ZnZ.WW.
 
  Let ww_of_pos p :=
   match w_of_pos p with
@@ -124,15 +122,15 @@ Section Z_2nZ.
   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).
- Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W w).
- Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 w).
+ Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t).
+ Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t).
+ Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t).
 
  (* ** Comparison ** *)
  Let compare :=
   Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare.
 
- Let eq0 (x:zn2z w) :=
+ Let eq0 (x:zn2z t) :=
   match x with
   | W0 => true
   | _ => false
@@ -226,7 +224,7 @@ Section Z_2nZ.
   Eval lazy beta iota delta [ww_div21] in
    ww_div21 w_0 w_0W div32 ww_1 compare sub.
 
- Let low (p: zn2z w) := match p with WW _ p1 => p1 | _ => w_0 end.
+ Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end.
 
  Let add_mul_div :=
   Eval lazy beta delta [ww_add_mul_div] in
@@ -287,8 +285,8 @@ Section Z_2nZ.
 
  (* ** Record of operators on 2 words *)
 
- Definition mk_zn2z_op :=
-  mk_znz_op _ww_digits _ww_zdigits
+ Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 :=
+  ZnZ.MkOps _ww_digits _ww_zdigits
     to_Z ww_of_pos head0 tail0
     W0 ww_1 ww_Bm1
     compare eq0
@@ -307,8 +305,8 @@ Section Z_2nZ.
     sqrt2
     sqrt.
 
- Definition mk_zn2z_op_karatsuba :=
-   mk_znz_op _ww_digits _ww_zdigits
+ Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 :=
+   ZnZ.MkOps _ww_digits _ww_zdigits
     to_Z ww_of_pos head0 tail0
     W0 ww_1 ww_Bm1
     compare eq0
@@ -328,51 +326,51 @@ Section Z_2nZ.
     sqrt.
 
  (* Proof *)
- Variable op_spec : znz_spec w_op.
+ Context {specs : ZnZ.Specs ops}.
 
  Hint Resolve
-    (spec_to_Z op_spec)
-    (spec_of_pos op_spec)
-    (spec_0 op_spec)
-    (spec_1 op_spec)
-    (spec_Bm1 op_spec)
-    (spec_compare op_spec)
-    (spec_eq0 op_spec)
-    (spec_opp_c op_spec)
-    (spec_opp op_spec)
-    (spec_opp_carry op_spec)
-    (spec_succ_c op_spec)
-    (spec_add_c op_spec)
-    (spec_add_carry_c op_spec)
-    (spec_succ op_spec)
-    (spec_add op_spec)
-    (spec_add_carry op_spec)
-    (spec_pred_c op_spec)
-    (spec_sub_c op_spec)
-    (spec_sub_carry_c op_spec)
-    (spec_pred op_spec)
-    (spec_sub op_spec)
-    (spec_sub_carry op_spec)
-    (spec_mul_c op_spec)
-    (spec_mul op_spec)
-    (spec_square_c op_spec)
-    (spec_div21 op_spec)
-    (spec_div_gt op_spec)
-    (spec_div op_spec)
-    (spec_mod_gt op_spec)
-    (spec_mod op_spec)
-    (spec_gcd_gt 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)
-    (spec_sqrt2)
-    (spec_sqrt)
-    (spec_W0 op_spec)
-    (spec_0W op_spec)
-    (spec_WW op_spec).
+    ZnZ.spec_to_Z
+    ZnZ.spec_of_pos
+    ZnZ.spec_0
+    ZnZ.spec_1
+    ZnZ.spec_m1
+    ZnZ.spec_compare
+    ZnZ.spec_eq0
+    ZnZ.spec_opp_c
+    ZnZ.spec_opp
+    ZnZ.spec_opp_carry
+    ZnZ.spec_succ_c
+    ZnZ.spec_add_c
+    ZnZ.spec_add_carry_c
+    ZnZ.spec_succ
+    ZnZ.spec_add
+    ZnZ.spec_add_carry
+    ZnZ.spec_pred_c
+    ZnZ.spec_sub_c
+    ZnZ.spec_sub_carry_c
+    ZnZ.spec_pred
+    ZnZ.spec_sub
+    ZnZ.spec_sub_carry
+    ZnZ.spec_mul_c
+    ZnZ.spec_mul
+    ZnZ.spec_square_c
+    ZnZ.spec_div21
+    ZnZ.spec_div_gt
+    ZnZ.spec_div
+    ZnZ.spec_modulo_gt
+    ZnZ.spec_modulo
+    ZnZ.spec_gcd_gt
+    ZnZ.spec_gcd
+    ZnZ.spec_head0
+    ZnZ.spec_tail0
+    ZnZ.spec_add_mul_div
+    ZnZ.spec_pos_mod
+    ZnZ.spec_is_even
+    ZnZ.spec_sqrt2
+    ZnZ.spec_sqrt
+    ZnZ.spec_WO
+    ZnZ.spec_OW
+    ZnZ.spec_WW.
 
  Ltac wwauto := unfold ww_to_Z; auto.
 
@@ -395,16 +393,17 @@ Section Z_2nZ.
      Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
  Proof.
   unfold ww_of_pos;intros.
-  assert (H:= spec_of_pos op_spec p);unfold w_of_pos;
-   destruct (znz_of_pos w_op p). simpl in H.
-  rewrite H;clear H;destruct n;simpl to_Z.
-  simpl;unfold w_to_Z,w_0;rewrite (spec_0 op_spec);trivial.
-  unfold Z_of_N; assert (H:= spec_of_pos op_spec p0);
-  destruct (znz_of_pos w_op p0). simpl in H.
-  rewrite H;unfold fst, snd,Z_of_N, to_Z.
-  rewrite (spec_WW op_spec).
+  rewrite (ZnZ.spec_of_pos p). unfold w_of_pos.
+  case (ZnZ.of_pos p); intros. simpl.
+  destruct n; simpl ZnZ.to_Z.
+  simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial.
+  unfold Z_of_N.
+  rewrite (ZnZ.spec_of_pos p0).
+  case (ZnZ.of_pos p0); intros. simpl.
+  unfold fst, snd,Z_of_N, to_Z, wB, w_digits, w_to_Z, w_WW.
+  rewrite ZnZ.spec_WW.
   replace wwB with (wB*wB).
-  unfold wB,w_to_Z,w_digits;clear H;destruct n;ring.
+  unfold wB,w_to_Z,w_digits;destruct n;ring.
   symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits).
  Qed.
 
@@ -418,15 +417,9 @@ Section Z_2nZ.
  Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.
 
  Let spec_ww_compare :
-     forall x y,
-       match compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+  forall x y, compare x y = Zcompare [|x|] [|y|].
  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.
@@ -531,8 +524,7 @@ Section Z_2nZ.
  Proof.
  refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
           _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
-  unfold w_digits; apply spec_more_than_1_digit; auto.
-  exact (spec_compare op_spec).
+  unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto.
  Qed.
 
  Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB.
@@ -559,11 +551,10 @@ Section Z_2nZ.
    w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z
    _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
   unfold w_Bm2, w_to_Z, w_pred, w_Bm1.
-  rewrite (spec_pred op_spec);rewrite (spec_Bm1 op_spec).
+  rewrite ZnZ.spec_pred, ZnZ.spec_m1.
   unfold w_digits;rewrite Zmod_small. ring.
-  assert (H:= wB_pos(znz_digits w_op)). omega.
-  exact (spec_compare op_spec).
-  exact (spec_div21 op_spec).
+  assert (H:= wB_pos(ZnZ.digits)). omega.
+  exact ZnZ.spec_div21.
  Qed.
 
  Let spec_ww_div21 : forall a1 a2 b,
@@ -580,22 +571,19 @@ Section Z_2nZ.
  Let spec_add2: forall x y,
   [|w_add2 x y|] = w_to_Z x + w_to_Z y.
   unfold w_add2.
-  intros xh xl; generalize (spec_add_c op_spec xh xl).
-  unfold w_add_c; case znz_add_c; unfold interp_carry; simpl ww_to_Z.
+  intros xh xl; generalize (ZnZ.spec_add_c xh xl).
+  unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z.
     intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0.
-  unfold w_0; rewrite spec_0; simpl; auto with zarith.
+  unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith.
   intros w0; rewrite Zmult_1_l; simpl.
-  unfold w_to_Z, w_1; rewrite spec_1; auto with zarith.
+  unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith.
   rewrite Zmult_1_l; auto.
  Qed.
 
  Let spec_low: forall x,
   w_to_Z (low x) = [|x|] mod wB.
   intros x; case x; simpl low.
-    unfold ww_to_Z, w_to_Z, w_0; rewrite (spec_0 op_spec); simpl.
-    rewrite Zmod_small; auto with zarith.
-    split; auto with zarith.
-    unfold wB, base; auto with zarith.
+    unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; auto.
   intros xh xl; simpl.
   rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith.
   rewrite Zmod_small; auto with zarith.
@@ -608,7 +596,7 @@ Section Z_2nZ.
  unfold w_to_Z, _ww_zdigits.
  rewrite spec_add2.
  unfold w_to_Z, w_zdigits, w_digits.
- rewrite spec_zdigits; auto.
+ rewrite ZnZ.spec_zdigits; auto.
  rewrite Zpos_xO; auto with zarith.
  Qed.
 
@@ -618,9 +606,8 @@ Section Z_2nZ.
  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).
- exact (spec_head00 op_spec).
- exact (spec_zdigits op_spec).
+ exact ZnZ.spec_head00.
+ exact ZnZ.spec_zdigits.
  Qed.
 
  Let spec_ww_head0  : forall x,  0 < [|x|] ->
@@ -629,8 +616,7 @@ Section Z_2nZ.
   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).
+  exact ZnZ.spec_zdigits.
  Qed.
 
  Let spec_ww_tail00  : forall x,  [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits.
@@ -638,9 +624,8 @@ Section Z_2nZ.
  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).
- exact (spec_tail00 op_spec).
- exact (spec_zdigits op_spec).
+ exact ZnZ.spec_tail00.
+ exact ZnZ.spec_zdigits.
  Qed.
 
 
@@ -649,8 +634,7 @@ Section Z_2nZ.
  Proof.
   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).
+  exact ZnZ.spec_zdigits.
  Qed.
 
  Lemma spec_ww_add_mul_div : forall x y p,
@@ -659,10 +643,10 @@ 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 t 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).
+  exact ZnZ.spec_zdigits.
  Qed.
 
  Let spec_ww_div_gt : forall a b,
@@ -671,29 +655,29 @@ Section Z_2nZ.
       [|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
+(@spec_ww_div_gt t 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
  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
 ).
-  exact (spec_0 op_spec).
-  exact (spec_to_Z op_spec).
+  exact ZnZ.spec_0.
+  exact ZnZ.spec_to_Z.
   wwauto.
   wwauto.
-  exact (spec_compare op_spec).
-  exact (spec_eq0 op_spec).
-  exact (spec_opp_c op_spec).
-  exact (spec_opp op_spec).
-  exact (spec_opp_carry op_spec).
-  exact (spec_sub_c op_spec).
-  exact (spec_sub op_spec).
-  exact (spec_sub_carry op_spec).
-  exact (spec_div_gt op_spec).
-  exact (spec_add_mul_div op_spec).
-  exact (spec_head0 op_spec).
-  exact (spec_div21 op_spec).
+  exact ZnZ.spec_compare.
+  exact ZnZ.spec_eq0.
+  exact ZnZ.spec_opp_c.
+  exact ZnZ.spec_opp.
+  exact ZnZ.spec_opp_carry.
+  exact ZnZ.spec_sub_c.
+  exact ZnZ.spec_sub.
+  exact ZnZ.spec_sub_carry.
+  exact ZnZ.spec_div_gt.
+  exact ZnZ.spec_add_mul_div.
+  exact ZnZ.spec_head0.
+  exact ZnZ.spec_div21.
   exact spec_w_div32.
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_zdigits.
   exact spec_ww_digits.
   exact spec_ww_1.
   exact spec_ww_add_mul_div.
@@ -711,15 +695,14 @@ refine
       [|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 t 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
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _ _ _);wwauto.
-  exact (spec_compare op_spec).
-  exact (spec_div_gt op_spec).
-  exact (spec_div21 op_spec).
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_div_gt.
+  exact ZnZ.spec_div21.
+  exact ZnZ.spec_zdigits.
   exact spec_ww_add_mul_div.
  Qed.
 
@@ -731,37 +714,33 @@ 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 t 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
+  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
    w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
-  exact (spec_compare op_spec).
-  exact (spec_div21 op_spec).
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_div21.
+  exact ZnZ.spec_zdigits.
   exact spec_ww_add_mul_div.
-  refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
+  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
    _ _);auto.
- exact (spec_compare op_spec).
  Qed.
 
  Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
  Proof.
-  refine (@spec_ww_gcd w w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt
+  refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt
   _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
-  refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
+  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
    w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
-  exact (spec_compare op_spec).
-  exact (spec_div21 op_spec).
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_div21.
+  exact ZnZ.spec_zdigits.
   exact spec_ww_add_mul_div.
-  refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
+  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
    _ _);auto.
-  exact (spec_compare op_spec).
  Qed.
 
  Let spec_ww_is_even : forall x,
@@ -770,8 +749,8 @@ refine
       | false => [|x|] mod 2 = 1
       end.
  Proof.
- refine (@spec_ww_is_even w w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto.
- exact (spec_is_even op_spec).
+ refine (@spec_ww_is_even t w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto.
+ exact ZnZ.spec_is_even.
  Qed.
 
  Let spec_ww_sqrt2 : forall x y,
@@ -781,60 +760,57 @@ refine
           [+|r|] <= 2 * [|s|].
  Proof.
  intros x y H.
- refine (@spec_ww_sqrt2 w w_is_even w_compare w_0 w_1 w_Bm1
+ refine (@spec_ww_sqrt2 t 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_digits w_zdigits
                _ww_zdigits
                w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div
                 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
- exact (spec_zdigits op_spec).
- exact (spec_more_than_1_digit op_spec).
- exact (spec_is_even op_spec).
- exact (spec_compare op_spec).
- exact (spec_div21 op_spec).
- exact (spec_ww_add_mul_div).
- exact (spec_sqrt2 op_spec).
+ exact ZnZ.spec_zdigits.
+ exact ZnZ.spec_more_than_1_digit.
+ exact ZnZ.spec_is_even.
+ exact ZnZ.spec_div21.
+ exact spec_ww_add_mul_div.
+ exact ZnZ.spec_sqrt2.
  Qed.
 
  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 t w_is_even w_0 w_1 w_Bm1
            w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
                w_sqrt2 pred add_mul_div head0 compare
             _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
- exact (spec_zdigits op_spec).
- exact (spec_more_than_1_digit op_spec).
- exact (spec_is_even op_spec).
- exact (spec_ww_add_mul_div).
- exact (spec_sqrt2 op_spec).
+ exact ZnZ.spec_zdigits.
+ exact ZnZ.spec_more_than_1_digit.
+ exact ZnZ.spec_is_even.
+ exact spec_ww_add_mul_div.
+ exact ZnZ.spec_sqrt2.
  Qed.
 
- Lemma mk_znz2_spec : znz_spec mk_zn2z_op.
+ Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops.
  Proof.
-  apply mk_znz_spec;auto.
+  apply ZnZ.MkSpecs; 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 t 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).
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_zdigits.
   unfold w_to_Z, w_zdigits.
-  rewrite (spec_zdigits op_spec).
+  rewrite ZnZ.spec_zdigits.
   rewrite <- Zpos_xO; exact spec_ww_digits.
  Qed.
 
- Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba.
+ Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba.
  Proof.
-  apply mk_znz_spec;auto.
+  apply ZnZ.MkSpecs; 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 t 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).
-  exact (spec_zdigits op_spec).
+  exact ZnZ.spec_zdigits.
   unfold w_to_Z, w_zdigits.
-  rewrite (spec_zdigits op_spec).
+  rewrite ZnZ.spec_zdigits.
   rewrite <- Zpos_xO; exact spec_ww_digits.
  Qed.
 
@@ -842,17 +818,14 @@ End Z_2nZ.
 
 Section MulAdd.
 
-  Variable w: Type.
-  Variable op: znz_op w.
-  Variable sop: znz_spec op.
+  Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}.
 
-  Definition mul_add:= w_mul_add (znz_0 op) (znz_succ op) (znz_add_c op) (znz_mul_c op).
+  Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c.
 
-  Notation "[| x |]" := (znz_to_Z op x)  (at level 0, x at level 99).
+  Notation "[| x |]" := (ZnZ.to_Z x)  (at level 0, x at level 99).
 
   Notation "[|| x ||]" :=
-   (zn2z_to_Z (base (znz_digits op)) (znz_to_Z op) x)  (at level 0, x at level 99).
-
+   (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x)  (at level 0, x at level 99).
 
   Lemma spec_mul_add: forall x y z,
      let (zh, zl) := mul_add x y z in
@@ -860,11 +833,11 @@ Section MulAdd.
   Proof.
   intros x y z.
    refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto.
-  exact (spec_0 sop).
-  exact (spec_to_Z sop).
-  exact (spec_succ sop).
-  exact (spec_add_c sop).
-  exact (spec_mul_c sop).
+  exact ZnZ.spec_0.
+  exact ZnZ.spec_to_Z.
+  exact ZnZ.spec_succ.
+  exact ZnZ.spec_add_c.
+  exact ZnZ.spec_mul_c.
   Qed.
 
 End MulAdd.
@@ -873,13 +846,13 @@ End MulAdd.
 (** Modular versions of DoubleCyclic *)
 
 Module DoubleCyclic (C:CyclicType) <: CyclicType.
- Definition w := zn2z C.w.
- Definition w_op := mk_zn2z_op C.w_op.
- Definition w_spec := mk_znz2_spec C.w_spec.
+ Definition t := zn2z C.t.
+ Instance ops : ZnZ.Ops t := mk_zn2z_ops.
+ Instance specs : ZnZ.Specs ops := mk_zn2z_specs.
 End DoubleCyclic.
 
 Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType.
- Definition w := zn2z C.w.
- Definition w_op := mk_zn2z_op_karatsuba C.w_op.
- Definition w_spec := mk_znz2_karatsuba_spec C.w_spec.
+ Definition t := zn2z C.t.
+ Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba.
+ Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba.
 End DoubleCyclicKaratsuba.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
index 4e6eccea..0cb6848e 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*         Benjamin Gregoire, Laurent Thery, INRIA, 2007                *)
 (************************************************************************)
 
-(*i $Id: DoubleDiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -82,11 +80,7 @@ Section POS_MOD.
 
   Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
   Variable spec_ww_compare : forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+    ww_compare x y = Zcompare [[x]] [[y]].
  Variable spec_ww_sub: forall x y,
    [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
 
@@ -105,8 +99,8 @@ Section POS_MOD.
  intros w1 p; case (spec_to_w_Z p); intros HH1 HH2.
  unfold ww_pos_mod; case w1.
  simpl; rewrite Zmod_small; split; auto with zarith.
- intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits));
-    case ww_compare;
+ intros xh xl; rewrite spec_ww_compare.
+    case Zcompare_spec;
     rewrite spec_w_0W; rewrite spec_zdigits; fold wB;
     intros H1.
    rewrite H1; simpl ww_to_Z.
@@ -134,8 +128,8 @@ Section POS_MOD.
    rewrite Z_mod_mult; auto with zarith.
    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;
+  rewrite spec_ww_compare.
+    case Zcompare_spec; rewrite spec_ww_zdigits;
                      rewrite spec_zdigits; intros H2.
   replace (2^[[p]]) with wwB.
     rewrite Zmod_small; auto with zarith.
@@ -266,12 +260,7 @@ Section DoubleDiv32.
 
   Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
   Variable spec_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+     forall x y, w_compare x y = Zcompare [|x|] [|y|].
   Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
   Variable spec_w_add_carry_c :
          forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1.
@@ -343,7 +332,7 @@ Section DoubleDiv32.
      (WW (w_sub a2 b2) a3) (WW b1 b2)
     | Gt => (w_0, W0) (* cas absurde *)
     end.
-   assert (Hcmp:=spec_compare a1 b1);destruct (w_compare a1 b1).
+   rewrite spec_compare. case Zcompare_spec; intro Hcmp.
    simpl in Hlt.
    rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega.
    assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB).
@@ -545,11 +534,7 @@ Section DoubleDiv21.
      0 <= [[r]] < [|b1|] * wB + [|b2|].
   Variable spec_ww_1 : [[ww_1]] = 1.
   Variable spec_ww_compare :  forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+    ww_compare x y = Zcompare [[x]] [[y]].
   Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
 
   Theorem wwB_div: wwB  = 2 * (wwB / 2).
@@ -576,10 +561,9 @@ Section DoubleDiv21.
    intros a1 a2 b H Hlt; unfold ww_div21.
    Spec_ww_to_Z b; assert (Eq: 0 < [[b]]).    Spec_ww_to_Z a1;omega.
    generalize Hlt H ;clear Hlt H;case a1.
-   intros H1 H2;simpl in H1;Spec_ww_to_Z a2;
-   match goal with |-context [ww_compare ?Y ?Z] =>
-     generalize (spec_ww_compare Y Z); case (ww_compare Y Z)
-   end; simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith.
+   intros H1 H2;simpl in H1;Spec_ww_to_Z a2.
+   rewrite spec_ww_compare. case Zcompare_spec;
+   simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith.
    rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith.
    split. ring.
    assert (wwB <= 2*[[b]]);zarith.
@@ -809,12 +793,7 @@ Section DoubleDivGt.
   Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
   Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
   Variable spec_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+     forall x y, w_compare x y = Zcompare [|x|] [|y|].
   Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.
 
   Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
@@ -914,7 +893,7 @@ Section DoubleDivGt.
     end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]).
    assert (Hh := spec_head0 Hpos).
    lazy zeta.
-   generalize (spec_compare (w_head0 bh) w_0); case w_compare;
+   rewrite spec_compare; case Zcompare_spec;
     rewrite spec_w_0; intros HH.
    generalize Hh; rewrite HH; simpl Zpower;
         rewrite Zmult_1_l; intros (HH1, HH2); clear HH.
@@ -1058,14 +1037,13 @@ Section DoubleDivGt.
    assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl).
    repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial.
    clear H.
-   assert (Hcmp := spec_compare w_0 bh); destruct (w_compare w_0 bh).
+   rewrite spec_compare; case Zcompare_spec; intros Hcmp.
    rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]).
    rewrite <- Hcmp;rewrite Zmult_0_l;rewrite Zplus_0_l.
    simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos.
    assert (H2:= @spec_double_divn1 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 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
               w_compare w_sub 1
              (WW ah al) bl).
@@ -1154,7 +1132,7 @@ Section DoubleDivGt.
    rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial.
    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_compare; case Zcompare_spec; intros H2.
    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
@@ -1227,13 +1205,14 @@ Section DoubleDivGt.
       end
     | Gt => W0 (* absurde *)
     end).
-   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 spec_compare, spec_w_0.
+   case Zcompare_spec; intros Hbh.
+   simpl ww_to_Z in *. rewrite <- Hbh.
    rewrite Zmult_0_l;rewrite Zplus_0_l.
-   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.
+   rewrite spec_compare, spec_w_0.
+   case Zcompare_spec; intros 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.
    apply Zis_gcd_mod;zarith.
    change ([|ah|] * wB + [|al|]) with (double_to_Z w_digits w_to_Z 1 (WW ah al)).
    rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
@@ -1243,20 +1222,20 @@ Section DoubleDivGt.
    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;exfalso;omega.
-   rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh).
+   Spec_w_to_Z bl;exfalso;omega.
+   assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh).
    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;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl.
-   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.
-   rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith.
+   rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hmh.
+   simpl;rewrite <- Hmh;simpl.
+   rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hml.
+   rewrite <- Hml;simpl;apply Zis_gcd_0.
+   simpl; rewrite spec_w_0; simpl.
+   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
@@ -1265,8 +1244,8 @@ Section DoubleDivGt.
    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;exfalso;omega.
-   rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]).
+   Spec_w_to_Z ml;exfalso;omega.
+   assert ([[WW bh bl]] > [[WW mh ml]]).
    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).
@@ -1300,8 +1279,8 @@ 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;exfalso;zarith.
-   rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;exfalso;zarith.
+   Spec_w_to_Z mh;exfalso;zarith.
+   Spec_w_to_Z bh;exfalso;zarith.
   Qed.
 
   Lemma spec_ww_gcd_gt_aux :
@@ -1374,11 +1353,7 @@ Section DoubleDiv.
   Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
   Variable spec_ww_1 : [[ww_1]] = 1.
   Variable spec_ww_compare :  forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+    ww_compare x y = Zcompare [[x]] [[y]].
   Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
       let (q,r) := ww_div_gt a b in
       [[a]] = [[q]] * [[b]] + [[r]] /\
@@ -1400,20 +1375,20 @@ Section DoubleDiv.
       0 <= [[r]] < [[b]].
   Proof.
    intros a b Hpos;unfold ww_div.
-   assert (H:=spec_ww_compare a b);destruct (ww_compare a b).
+   rewrite spec_ww_compare; case Zcompare_spec; intros.
    simpl;rewrite spec_ww_1;split;zarith.
    simpl;split;[ring|Spec_ww_to_Z a;zarith].
-   apply spec_ww_div_gt;trivial.
+   apply spec_ww_div_gt;auto with zarith.
   Qed.
 
   Lemma  spec_ww_mod :  forall a b, 0 < [[b]] ->
       [[ww_mod a b]] = [[a]] mod [[b]].
   Proof.
    intros a b Hpos;unfold ww_mod.
-   assert (H := spec_ww_compare a b);destruct (ww_compare a b).
+   rewrite spec_ww_compare; case Zcompare_spec; intros.
    simpl;apply Zmod_unique with 1;try rewrite H;zarith.
    Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith.
-   apply spec_ww_mod_gt;trivial.
+   apply spec_ww_mod_gt;auto with zarith.
   Qed.
 
 
@@ -1431,12 +1406,7 @@ Section DoubleDiv.
   Variable spec_w_0   : [|w_0|] = 0.
   Variable spec_w_1   : [|w_1|] = 1.
   Variable spec_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+    forall x y, w_compare x y = Zcompare [|x|] [|y|].
   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|].
@@ -1468,14 +1438,14 @@ Section DoubleDiv.
     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.
-   unfold gcd_cont;assert (Hcmpy:=spec_compare w_1 yl);
-   rewrite spec_w_1 in Hcmpy.
-   simpl;rewrite H;simpl;destruct (w_compare w_1 yl).
+   unfold gcd_cont; rewrite spec_compare, spec_w_1.
+   case Zcompare_spec; intros Hcmpy.
+   simpl;rewrite H;simpl;
    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; exfalso;zarith.
-   assert ([|yl|] = 0). Spec_w_to_Z yl;zarith.
-   rewrite H0;simpl;apply Zis_gcd_0;trivial.
+   assert (H0 : [|yl|] = 0) by (Spec_w_to_Z yl;zarith).
+   simpl. rewrite H0, H;simpl;apply Zis_gcd_0;trivial.
   Qed.
 
 
@@ -1528,7 +1498,7 @@ Section DoubleDiv.
      | Eq => a
      | Lt => ww_gcd_gt b a
      end).
-   assert (Hcmp := spec_ww_compare a b);destruct (ww_compare a b).
+   rewrite spec_ww_compare; case Zcompare_spec; intros Hcmp.
    Spec_ww_to_Z b;rewrite Hcmp.
    apply Zis_gcd_for_euclid with 1;zarith.
    ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
index 4bdb75d6..062282f2 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,17 +8,17 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleDivn1.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
-Require Import ZArith.
+Require Import ZArith Ndigits.
 Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
 Local Open Scope Z_scope.
 
+Local Infix "<<" := Pos.shiftl_nat (at level 30).
+
 Section GENDIVN1.
 
  Variable w             : Type.
@@ -62,12 +62,7 @@ Section GENDIVN1.
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
  Variable spec_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+   forall x y, w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_sub: forall x y,
    [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
 
@@ -162,14 +157,10 @@ Section GENDIVN1.
    | 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).
+  Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (w_digits << n).
   Proof.
-(*
-   induction n;simpl. destruct p_bounded;trivial.
-   case (spec_to_Z p); rewrite Zpos_xO;auto with zarith.
-*)
    induction n;simpl. trivial.
-   case (spec_to_Z p); rewrite Zpos_xO;auto with zarith.
+   case (spec_to_Z p); rewrite Pshiftl_nat_S, Zpos_xO;auto with zarith.
   Qed.
 
   Lemma spec_double_divn1_p : forall n r h l,
@@ -177,14 +168,14 @@ Section GENDIVN1.
     let (q,r') := double_divn1_p n r h l in
     [|r|] * double_wB w_digits n +
       ([!n|h!]*2^[|p|] +
-        [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|])))
+        [!n|l!] / (2^(Zpos(w_digits << n) - [|p|])))
         mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\
     0 <= [|r'|] < [|b2p|].
   Proof.
    case (spec_to_Z p); intros HH0 HH1.
    induction n;intros.
    simpl (double_divn1_p 0 r h l).
-   unfold double_to_Z, double_wB, double_digits.
+   unfold double_to_Z, double_wB, "<<".
    rewrite <- spec_add_mul_divp.
    exact (spec_div21 (w_add_mul_div p h l) b2p_le H).
    simpl (double_divn1_p (S n) r h l).
@@ -196,24 +187,24 @@ Section GENDIVN1.
    replace ([|r|] * (double_wB w_digits n * double_wB w_digits n) +
     (([!n|hh!] * double_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] +
     ([!n|lh!] * double_wB w_digits n + [!n|ll!]) /
-     2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod
+     2^(Zpos (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|] +
-      [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod
+      [!n|hl!] / 2^(Zpos (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|lh!] / 2^(Zpos (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.
    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
+      [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod
       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
+       [!n|lh!] / 2 ^ (Zpos (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.
@@ -229,52 +220,52 @@ Section GENDIVN1.
    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)))
-     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)).
+   2:change (Zpos (w_digits << (S n)))
+     with (2*Zpos (w_digits << n));auto with zarith.
+   replace (2 ^ (Zpos (w_digits << (S n)) - [|p|])) with
+    (2^(Zpos (w_digits << n) - [|p|])*2^Zpos (w_digits << n)).
    rewrite Zdiv_mult_cancel_r;auto with zarith.
    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!]));
+   rewrite (shift_unshift_mod (Zpos(w_digits << n))([|p|])([!n|hl!]));
     auto with zarith.
    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)))
+    ([!n|hh!] * 2^Zpos (w_digits << n)* 2^[|p|] +
+      ([!n|hl!] / 2^(Zpos (w_digits << n)-[|p|])*
+       2^Zpos(w_digits << n)))
    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).
+       2^(Zpos (w_digits << n)-[|p|]))
+      * 2^Zpos(w_digits << n));try (ring;fail).
    rewrite <- Zplus_assoc.
    rewrite <- (Zmod_shift_r ([|p|]));auto with zarith.
    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)).
+     (2 ^ Zpos (w_digits << n) * 2 ^ Zpos (w_digits << n)) with
+     (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))).
+   rewrite (Zmod_shift_r (Zpos (w_digits << n)));auto with zarith.
+   replace (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n)))
+   with (2^Zpos(w_digits << n) *2^Zpos(w_digits << n)).
    rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] +
-      [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))).
+      [!n|hl!] / 2 ^ (Zpos (w_digits << n) - [|p|])))).
    rewrite  Zmult_mod_distr_l;auto with zarith.
    ring.
    rewrite Zpower_exp;auto with zarith.
-   assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity.
+   assert (0 < Zpos (w_digits << n)). unfold Zlt;reflexivity.
    auto with zarith.
    apply Z_mod_lt;auto with zarith.
    rewrite Zpower_exp;auto with zarith.
    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
-     (Zpos(double_digits w_digits n));auto with zarith.
+   replace ([|p|] + (Zpos (w_digits << n) - [|p|])) with
+     (Zpos(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|] +
-         Zpos (double_digits w_digits n));trivial.
-   change (Zpos (double_digits w_digits (S n))) with
-    (2*Zpos (double_digits w_digits n)). ring.
+   replace (Zpos (w_digits << (S n)) - [|p|]) with
+       (Zpos (w_digits << n) - [|p|] +
+         Zpos (w_digits << n));trivial.
+   change (Zpos (w_digits << (S n))) with
+    (2*Zpos (w_digits << n)). ring.
   Qed.
 
   Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:=
@@ -311,20 +302,21 @@ Section GENDIVN1.
      end
   end.
 
- Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n).
+ Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (w_digits << n).
  Proof.
   induction n;simpl;auto with zarith.
-  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).
+  rewrite Pshiftl_nat_S.
+  change (Zpos (xO (w_digits << n))) with
+    (2*Zpos (w_digits << n)).
+  assert (0 < Zpos w_digits) by reflexivity.
+  auto with zarith.
  Qed.
 
  Lemma spec_high : forall n (x:word w n),
-   [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits).
+   [|high n x|] = [!n|x!] / 2^(Zpos (w_digits << n) - Zpos w_digits).
  Proof.
   induction n;intros.
-  unfold high,double_digits,double_to_Z.
+  unfold high,double_to_Z. rewrite Pshiftl_nat_0.
   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).
@@ -336,18 +328,18 @@ Section GENDIVN1.
    assert (U1 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w1).
   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)).
+  replace (2 ^ (Zpos (w_digits << (S n)) - Zpos w_digits)) with
+   (2^(Zpos (w_digits << n) - Zpos w_digits) *
+        2^Zpos (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 +
-    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
-     (2*Zpos (double_digits w_digits n));ring.
-  change (Zpos (double_digits w_digits (S n))) with
-  (2*Zpos (double_digits w_digits n)); auto with zarith.
+  replace (Zpos (w_digits << n) - Zpos w_digits +
+    Zpos (w_digits << n)) with
+   (Zpos (w_digits << (S n)) - Zpos w_digits);trivial.
+  change (Zpos (w_digits << (S n))) with
+     (2*Zpos (w_digits << n));ring.
+  change (Zpos (w_digits << (S n))) with
+  (2*Zpos (w_digits << n)); auto with zarith.
  Qed.
 
  Definition double_divn1 (n:nat) (a:word w n) (b:w) :=
@@ -373,7 +365,7 @@ Section GENDIVN1.
    intros n a b H. unfold double_divn1.
    case (spec_head0 H); intros H0 H1.
    case (spec_to_Z (w_head0 b)); intros HH1 HH2.
-   generalize (spec_compare (w_head0 b) w_0); case w_compare;
+   rewrite spec_compare; case Zcompare_spec;
      rewrite spec_0; intros H2; auto with zarith.
    assert (Hv1: wB/2 <= [|b|]).
      generalize H0; rewrite H2; rewrite Zpower_0_r;
@@ -432,13 +424,13 @@ Section GENDIVN1.
    rewrite spec_add_mul_div in H7;auto with zarith.
    rewrite spec_0 in H7;rewrite Zmult_0_l in H7;rewrite Zplus_0_l in H7.
    assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB
-     = [!n|a!] / 2^(Zpos (double_digits w_digits n) - [|w_head0 b|])).
+     = [!n|a!] / 2^(Zpos (w_digits << n) - [|w_head0 b|])).
    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 (w_digits << n) - Zpos w_digits +
                        (Zpos w_digits - [|w_head0 b|]))
-    with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring.
+    with (Zpos (w_digits << n) - [|w_head0 b|]);trivial;ring.
    assert (H8 := Zpower_gt_0 2  (Zpos w_digits - [|w_head0 b|]));auto with zarith.
    split;auto with zarith.
    apply Zle_lt_trans with ([|high n a|]);auto with zarith.
@@ -506,7 +498,7 @@ Section GENDIVN1.
     double_modn1 n a b = snd (double_divn1 n a b).
  Proof.
   intros n a b;unfold double_divn1,double_modn1.
-  generalize (spec_compare (w_head0 b) w_0); case w_compare;
+  rewrite spec_compare; case Zcompare_spec;
      rewrite spec_0; intros H2; auto with zarith.
   apply spec_double_modn1_0.
   apply spec_double_modn1_0.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
index 36e3da9b..a6a0fc8e 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleLift.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -106,17 +104,9 @@ Section DoubleLift.
   Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
   Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
   Variable spec_compare : forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+   w_compare x y = Zcompare [|x|] [|y|].
   Variable spec_ww_compare : forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+   ww_compare x y = Zcompare [[x]] [[y]].
   Variable spec_ww_digits : ww_Digits = xO w_digits.
   Variable spec_w_head00  : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits.
   Variable spec_w_head0  : forall x,  0 < [|x|] ->
@@ -159,7 +149,7 @@ Section DoubleLift.
     absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
     rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith.
     apply Zmult_lt_0_compat; auto with zarith.
-  generalize (spec_compare w_0 xh); case w_compare.
+  rewrite spec_compare. case Zcompare_spec.
     intros H; simpl.
     rewrite spec_w_add; rewrite spec_w_head00.
     rewrite spec_zdigits; rewrite spec_ww_digits.
@@ -176,9 +166,8 @@ Section DoubleLift.
    rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB.
    assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H.
    unfold Zlt in H;discriminate H.
-   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.
+   rewrite spec_compare, spec_w_0. case Zcompare_spec; intros H0.
+   rewrite <- H0 in *. simpl Zplus. simpl in H.
    case (spec_to_Z w_zdigits);
      case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4.
    rewrite spec_w_add.
@@ -233,7 +222,7 @@ Section DoubleLift.
     apply Zmult_lt_0_compat; auto with zarith.
   assert (F2: [|xl|] = 0).
     rewrite F1 in Hx; auto with zarith.
-  generalize (spec_compare w_0 xl); case w_compare.
+  rewrite spec_compare; case Zcompare_spec.
     intros H; simpl.
     rewrite spec_w_add; rewrite spec_w_tail00; auto.
     rewrite spec_zdigits; rewrite spec_ww_digits.
@@ -248,8 +237,7 @@ Section DoubleLift.
    clear spec_ww_zdigits.
    destruct x as [ |xh xl];simpl ww_to_Z;intros H.
    unfold Zlt in H;discriminate H.
-   assert (H0 := spec_compare w_0 xl);rewrite spec_w_0 in H0.
-   destruct (w_compare w_0 xl).
+   rewrite spec_compare, spec_w_0. case Zcompare_spec; intros H0.
    rewrite <- H0; rewrite Zplus_0_r.
    case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
    generalize H; rewrite <- H0; rewrite Zplus_0_r; clear H; intros H.
@@ -323,7 +311,7 @@ Section DoubleLift.
    assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
    simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl);
    assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy.
-   generalize (spec_ww_compare p zdigits); case ww_compare; intros H1.
+   rewrite spec_ww_compare; case Zcompare_spec; intros H1.
    rewrite H1; unfold zdigits; rewrite spec_w_0W.
    rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r.
    simpl ww_to_Z; w_rewrite;zarith.
@@ -365,7 +353,7 @@ Section DoubleLift.
    ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith.
    assert (Hv: [[p]] > Zpos w_digits).
      generalize H1; clear H1.
-     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto.
+     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith.
    clear H1.
    assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits).
      rewrite spec_low.
@@ -446,8 +434,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));
-     case ww_compare; intros H1; w_rewrite.
+   rewrite spec_ww_compare. case Zcompare_spec; 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.
    assert (HH0: [|low p|] = [[p]]).
@@ -464,7 +451,8 @@ Section DoubleLift.
    rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
    rewrite Zpos_xO in H;zarith.
    assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits).
-     generalize H1; clear H1.
+     symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1.
+     revert H1.
      rewrite spec_low.
      rewrite spec_ww_sub; w_rewrite; intros H1.
      rewrite <- Zmod_div_mod; auto with zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
index 834e85d2..0032d2c3 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -248,12 +246,7 @@ Section DoubleMul.
   Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
   Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
   Variable spec_w_compare :
-     forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+     forall x y, w_compare x y = Zcompare [|x|] [|y|].
   Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB.
   Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
   Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
@@ -408,9 +401,9 @@ Section DoubleMul.
      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)).
-   generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh;
+   rewrite spec_w_compare; case Zcompare_spec; intros Hxlh;
     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 spec_w_compare; case Zcompare_spec; intros Hylh.
    rewrite Hylh; 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).
@@ -430,7 +423,7 @@ Section DoubleMul.
    rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2;
      repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
-   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh.
+   rewrite spec_w_compare; case Zcompare_spec; intros Hylh.
    rewrite Hylh; rewrite spec_w_0; try (ring; fail).
    match goal with |- context[ww_add_c ?x ?y] =>
      generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0;
@@ -455,9 +448,9 @@ Section DoubleMul.
    apply Zmult_le_0_compat; auto with zarith.
    (** there is a carry in hh + ll **)
    rewrite Zmult_1_l.
-   generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh;
+   rewrite spec_w_compare; case Zcompare_spec; intros Hxlh;
     try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail).
-   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh;
+   rewrite spec_w_compare; case Zcompare_spec; intros Hylh;
      try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
    match goal with |- context[ww_sub_c ?x ?y] =>
      generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1;
@@ -480,7 +473,7 @@ Section DoubleMul.
    ring.
    rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
-   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh;
+   rewrite spec_w_compare; case Zcompare_spec; intros Hylh;
      try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
    match goal with |- context[ww_add_c ?x ?y] =>
      generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1;
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
index 4394178f..b073d6be 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleSqrt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -220,12 +218,8 @@ Section DoubleSqrt.
   Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
   Variable spec_w_is_even : forall x,
       if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
-   Variable spec_w_compare : forall x y,
-       match w_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
+  Variable spec_w_compare : forall x y,
+       w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
  Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|].
  Variable spec_w_div21 : forall a1 a2 b,
@@ -257,11 +251,7 @@ Section DoubleSqrt.
  Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB.
  Variable spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
  Variable spec_ww_compare : forall x y,
-       match ww_compare x y with
-       | Eq => [[x]] = [[y]]
-       | Lt => [[x]] < [[y]]
-       | Gt => [[x]] > [[y]]
-       end.
+    ww_compare x y = Zcompare [[x]] [[y]].
  Variable spec_ww_head0  : forall x,  0 < [[x]] ->
 	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
  Variable spec_low: forall x, [|low x|] = [[x]] mod wB.
@@ -299,10 +289,7 @@ intros x; case x; simpl ww_is_even.
  apply Zlt_le_trans with (2 := Hb); auto with zarith.
  apply Zlt_le_trans with 1; auto with zarith.
  apply Zdiv_le_lower_bound; auto with zarith.
- repeat match goal with |- context[w_compare ?y ?z] =>
-   generalize (spec_w_compare y z);
-   case (w_compare y z)
- end.
+ rewrite !spec_w_compare. repeat case Zcompare_spec.
  intros H1 H2; split.
  unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith.
  rewrite H1; rewrite H2; ring.
@@ -1108,12 +1095,12 @@ intros x; case x; simpl ww_is_even.
  rewrite wwB_wBwB; rewrite Zpower_2.
  apply Zmult_le_compat_r; auto with zarith.
  case (spec_to_Z w4);auto with zarith.
- Qed.
+Qed.
 
  Lemma spec_ww_is_zero: forall x,
    if ww_is_zero x then [[x]] = 0 else 0 < [[x]].
   intro x; unfold ww_is_zero.
-  generalize (spec_ww_compare W0 x); case (ww_compare W0 x);
+  rewrite spec_ww_compare. case Zcompare_spec;
    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.
@@ -1198,7 +1185,7 @@ intros x; case x; simpl ww_is_even.
   simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl;
     auto with zarith.
   intros H1.
-  generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare;
+  rewrite spec_ww_compare. case Zcompare_spec;
     simpl ww_to_Z; autorewrite with rm10.
   generalize H1; case x.
   intros HH; contradict HH; simpl ww_to_Z; auto with zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
index 3167f4c7..e63e20c6 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleSub.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
index eb1132d4..a274b839 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleType.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Set Implicit Arguments.
 
 Require Import ZArith.
@@ -55,7 +53,7 @@ Section Zn2Z.
 
 End Zn2Z.
 
-Implicit Arguments W0 [znz].
+Arguments W0 [znz].
 
 (** From a cyclic representation [w], we iterate the [zn2z] construct
     [n] times, gaining the type of binary trees of depth at most [n],
diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v
index 36a1157d..2dd1c3ee 100644
--- a/theories/Numbers/Cyclic/Int31/Cyclic31.v
+++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Cyclic31.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *)
 
 (**
@@ -907,9 +905,11 @@ Section Basics.
  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) +
-             phi (snd (p2ibis n p)))%Z.
+ Local Open Scope Z_scope.
+
+ Lemma p2ibis_spec : forall n p, (n<=size)%nat ->
+    Zpos p = (Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) +
+             phi (snd (p2ibis n p)).
  Proof.
  induction n; intros.
  simpl; rewrite Pmult_1_r; auto.
@@ -917,7 +917,7 @@ Section Basics.
   (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat;
    auto with zarith).
  rewrite (Zmult_comm 2).
- assert (n<=size) by omega.
+ assert (n<=size)%nat by omega.
  destruct p; simpl; [ | | auto];
   specialize (IHn p H0);
   generalize (p2ibis_bounded n p);
@@ -973,7 +973,8 @@ Section Basics.
  (** Moreover, [p2ibis] is also related with [p2i] and hence with
     [positive_to_int31]. *)
 
- Lemma double_twice_firstl : forall x, firstl x = D0 -> Twon*x = twice x.
+ Lemma double_twice_firstl : forall x, firstl x = D0 ->
+  (Twon*x = twice x)%int31.
  Proof.
  intros.
  unfold mul31.
@@ -981,7 +982,7 @@ Section Basics.
  Qed.
 
  Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 ->
-  Twon*x+In = twice_plus_one x.
+  (Twon*x+In = twice_plus_one x)%int31.
  Proof.
  intros.
  rewrite double_twice_firstl; auto.
@@ -1015,8 +1016,8 @@ Section Basics.
  Qed.
 
  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.
+    Zpos p = (Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) +
+               phi (snd (positive_to_int31 p)).
  Proof.
  unfold positive_to_int31.
  intros; rewrite p2i_p2ibis; auto.
@@ -1033,7 +1034,7 @@ Section Basics.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_double.
- assert (0 <= Zdouble (phi x))%Z.
+ assert (0 <= Zdouble (phi x)).
   rewrite Zdouble_mult; generalize (phi_bounded x); omega.
  destruct (Zdouble (phi x)).
  simpl; auto.
@@ -1047,7 +1048,7 @@ Section Basics.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_double_plus_one.
- assert (0 <= Zdouble_plus_one (phi x))%Z.
+ assert (0 <= Zdouble_plus_one (phi x)).
   rewrite Zdouble_plus_one_mult; generalize (phi_bounded x); omega.
  destruct (Zdouble_plus_one (phi x)).
  simpl; auto.
@@ -1061,7 +1062,7 @@ Section Basics.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_incr.
- assert (0 <= Zsucc (phi x))%Z.
+ assert (0 <= Zsucc (phi x)).
   change (Zsucc (phi x)) with ((phi x)+1)%Z;
    generalize (phi_bounded x); omega.
  destruct (Zsucc (phi x)).
@@ -1083,7 +1084,7 @@ Section Basics.
  rewrite incr_twice, phi_twice_plus_one.
  remember (phi (complement_negative p)) as q.
  rewrite Zdouble_plus_one_mult.
- replace (2*q+1)%Z with (2*(Zsucc q)-1)%Z by omega.
+ replace (2*q+1) with (2*(Zsucc q)-1) by omega.
  rewrite <- Zminus_mod_idemp_l, <- Zmult_mod_idemp_r, IHp.
  rewrite Zmult_mod_idemp_r, Zminus_mod_idemp_l; auto with zarith.
 
@@ -1106,81 +1107,61 @@ Section Basics.
 
 End Basics.
 
-
-Section Int31_Op.
-
-(** Nullity test *)
-Let w_iszero i := match i ?= 0 with Eq => true | _ => false end.
-
-(** Modulo [2^p] *)
-Let w_pos_mod p i :=
-  match compare31 p 31 with
+Instance int31_ops : ZnZ.Ops int31 :=
+{
+ digits      := 31%positive; (* number of digits *)
+ zdigits     := 31; (* number of digits *)
+ to_Z        := phi; (* conversion to Z *)
+ of_pos      := positive_to_int31; (* positive -> N*int31 :  p => N,i
+                                      where p = N*2^31+phi i *)
+ head0       := head031;  (* number of head 0 *)
+ tail0       := tail031;  (* number of tail 0 *)
+ zero        := 0;
+ one         := 1;
+ minus_one   := Tn; (* 2^31 - 1 *)
+ compare     := compare31;
+ eq0         := fun i => match i ?= 0 with Eq => true | _ => false end;
+ opp_c       := fun i => 0 -c i;
+ opp         := opp31;
+ opp_carry   := fun i => 0-i-1;
+ succ_c      := fun i => i +c 1;
+ add_c       := add31c;
+ add_carry_c := add31carryc;
+ succ        := fun i => i + 1;
+ add         := add31;
+ add_carry   := fun i j => i + j + 1;
+ pred_c      := fun i => i -c 1;
+ sub_c       := sub31c;
+ sub_carry_c := sub31carryc;
+ pred        := fun i => i - 1;
+ sub         := sub31;
+ sub_carry   := fun i j => i - j - 1;
+ mul_c       := mul31c;
+ mul         := mul31;
+ square_c    := fun x => x *c x;
+ div21       := div3121;
+ div_gt      := div31; (* this is supposed to be the special case of
+                         division a/b where a > b *)
+ div         := div31;
+ modulo_gt   := fun i j => let (_,r) := i/j in r;
+ modulo      := fun i j => let (_,r) := i/j in r;
+ gcd_gt      := gcd31;
+ gcd         := gcd31;
+ add_mul_div := addmuldiv31;
+ pos_mod     := (* modulo 2^p *)
+  fun p i =>
+  match p ?= 31 with
     | Lt => addmuldiv31 p 0 (addmuldiv31 (31-p) i 0)
     | _ => i
-  end.
+  end;
+ is_even      :=
+  fun i => let (_,r) := i/2 in
+  match r ?= 0 with Eq => true | _ => false end;
+ sqrt2       := sqrt312;
+ sqrt        := sqrt31
+}.
 
-(** Parity test *)
-Let w_iseven i :=
- let (_,r) := i/2 in
- match r ?= 0 with Eq => true | _ => false end.
-
-Definition int31_op := (mk_znz_op
- 31%positive (* number of digits *)
- 31 (* number of digits *)
- phi (* conversion to Z *)
- positive_to_int31 (* positive -> N*int31 :  p => N,i where p = N*2^31+phi i *)
- head031  (* number of head 0 *)
- tail031  (* number of tail 0 *)
- (* Basic constructors *)
- 0
- 1
- Tn (* 2^31 - 1 *)
- (* Comparison *)
- compare31
- w_iszero
- (* Basic arithmetic operations *)
- (fun i => 0 -c i)
- opp31
- (fun i => 0-i-1)
- (fun i => i +c 1)
- add31c
- add31carryc
- (fun i => i + 1)
- add31
- (fun i j => i + j + 1)
- (fun i => i -c 1)
- sub31c
- sub31carryc
- (fun i => i - 1)
- sub31
- (fun i j => i - j - 1)
- mul31c
- mul31
- (fun x => x *c x)
- (* special (euclidian) division operations *)
- div3121
- div31 (* this is supposed to be the special case of division a/b where a > b *)
- div31
- (* euclidian division remainder *)
- (* again special case for a > b *)
- (fun i j => let (_,r) := i/j in r)
- (fun i j => let (_,r) := i/j in r)
- gcd31 (*gcd_gt*)
- gcd31 (*gcd*)
- (* shift operations *)
- addmuldiv31 (*add_mul_div  *)
- (* modulo 2^p *)
- w_pos_mod
- (* is i even ? *)
- w_iseven
- (* square root operations *)
- sqrt312 (* sqrt2 *)
- sqrt31 (* sqrt *)
-).
-
-End Int31_Op.
-
-Section Int31_Spec.
+Section Int31_Specs.
 
  Local Open Scope Z_scope.
 
@@ -1222,22 +1203,14 @@ Section Int31_Spec.
   reflexivity.
  Qed.
 
- Lemma spec_Bm1 : [| Tn |] = wB - 1.
+ Lemma spec_m1 : [| Tn |] = wB - 1.
  Proof.
   reflexivity.
  Qed.
 
  Lemma spec_compare : forall x y,
-   match (x ?= y)%int31 with
-     | Eq => [|x|] = [|y|]
-     | Lt => [|x|] < [|y|]
-     | Gt => [|x|] > [|y|]
-   end.
- Proof.
- clear; unfold compare31; simpl; intros.
- case_eq ([|x|] ?= [|y|]); auto.
- intros; apply Zcompare_Eq_eq; auto.
- Qed.
+   (x ?= y)%int31 = ([|x|] ?= [|y|]).
+ Proof. reflexivity. Qed.
 
  (** Addition *)
 
@@ -1654,12 +1627,10 @@ Section Int31_Spec.
  rewrite Zmult_comm, Z_div_mult; auto with zarith.
  Qed.
 
- Let w_pos_mod     := int31_op.(znz_pos_mod).
-
  Lemma spec_pos_mod : forall w p,
-       [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
+       [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
  Proof.
- unfold w_pos_mod, znz_pos_mod, int31_op, compare31.
+ unfold ZnZ.pos_mod, int31_ops, compare31.
  change [|31|] with 31%Z.
  assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p).
   intros.
@@ -1721,7 +1692,7 @@ Section Int31_Spec.
  unfold head031, recl.
  change On with (phi_inv (Z_of_nat (31-size))).
  replace (head031_alt size x) with
-   (head031_alt size x + (31 - size))%nat by (apply plus_0_r; auto).
+   (head031_alt size x + (31 - size))%nat by auto.
  assert (size <= 31)%nat by auto with arith.
 
  revert x H; induction size; intros.
@@ -1829,7 +1800,7 @@ Section Int31_Spec.
  unfold tail031, recr.
  change On with (phi_inv (Z_of_nat (31-size))).
  replace (tail031_alt size x) with
-   (tail031_alt size x + (31 - size))%nat by (apply plus_0_r; auto).
+   (tail031_alt size x + (31 - size))%nat by auto.
  assert (size <= 31)%nat by auto with arith.
 
  revert x H; induction size; intros.
@@ -2018,8 +1989,8 @@ Section Int31_Spec.
  Proof.
  assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt).
  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;
+ rewrite spec_compare, div31_phi; auto.
+   case Zcompare_spec; 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|]).
@@ -2072,7 +2043,7 @@ Section Int31_Spec.
        [|sqrt31 x|] ^ 2 <= [|x|] < ([|sqrt31 x|] + 1) ^ 2.
  Proof.
  intros i; unfold sqrt31.
- generalize (spec_compare 1 i); case compare31; change [|1|] with 1;
+ rewrite spec_compare. case Zcompare_spec; change [|1|] with 1;
    intros Hi; auto with zarith.
  repeat rewrite Zpower_2; auto with zarith.
  apply iter31_sqrt_correct; auto with zarith.
@@ -2157,7 +2128,7 @@ Section Int31_Spec.
  unfold phi2; apply Zlt_le_trans with ([|ih|] * base)%Z; auto with zarith.
  apply Zmult_lt_0_compat; auto with zarith.
  apply Zlt_le_trans with (2:= Hih); auto with zarith.
- generalize (spec_compare ih j); case compare31; intros Hc1.
+ rewrite spec_compare. case Zcompare_spec; intros Hc1.
  split; auto.
  apply sqrt_test_true; auto.
  unfold phi2, base; auto with zarith.
@@ -2166,7 +2137,7 @@ Section Int31_Spec.
  rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith.
  unfold Zpower, Zpower_pos in Hj1; simpl in Hj1; auto with zarith.
  case (Zle_or_lt (2 ^ 30) [|j|]); intros Hjj.
- generalize (spec_compare (fst (div3121 ih il j)) j); case compare31;
+ rewrite spec_compare; case Zcompare_spec;
   rewrite div312_phi; auto; intros Hc;
   try (split; auto; apply sqrt_test_true; auto with zarith; fail).
  apply Hrec.
@@ -2274,7 +2245,7 @@ Section Int31_Spec.
   2: simpl; unfold Zpower_pos; simpl; auto with zarith.
   case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4.
   unfold base, Zpower, Zpower_pos in H2,H4; simpl in H2,H4.
-  unfold phi2,Zpower, Zpower_pos; simpl iter_pos; auto with zarith.
+  unfold phi2,Zpower, Zpower_pos. simpl Pos.iter; auto with zarith.
  case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith.
  change [|Tn|] with 2147483647; auto with zarith.
  intros j1 _ HH; contradict HH.
@@ -2300,7 +2271,7 @@ Section Int31_Spec.
  generalize (spec_sub_c il il1).
  case sub31c; intros il2 Hil2.
  simpl interp_carry in Hil2.
- generalize (spec_compare ih ih1); case compare31.
+ rewrite spec_compare; case Zcompare_spec.
  unfold interp_carry.
  intros H1; split.
  rewrite Zpower_2, <- Hihl1.
@@ -2347,7 +2318,7 @@ Section Int31_Spec.
   case (phi_bounded ih); intros H1 H2.
   generalize Hih; change (2 ^ Z_of_nat size / 4) with 536870912.
   split; auto with zarith.
- generalize (spec_compare (ih - 1) ih1); case compare31.
+ rewrite spec_compare; case Zcompare_spec.
  rewrite Hsih.
  intros H1; split.
  rewrite Zpower_2, <- Hihl1.
@@ -2414,15 +2385,13 @@ Section Int31_Spec.
  replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring.
  rewrite <-Hil2.
  change (-1 * 2 ^ Z_of_nat size) with (-base); ring.
- Qed.
+Qed.
 
  (** [iszero] *)
 
- Let w_eq0         := int31_op.(znz_eq0).
-
- Lemma spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.
+ Lemma spec_eq0 : forall x, ZnZ.eq0 x = true -> [|x|] = 0.
  Proof.
- clear; unfold w_eq0, znz_eq0; simpl.
+ clear; unfold ZnZ.eq0; simpl.
  unfold compare31; simpl; intros.
  change [|0|] with 0 in H.
  apply Zcompare_Eq_eq.
@@ -2431,12 +2400,10 @@ Section Int31_Spec.
 
  (* Even *)
 
- Let w_is_even     := int31_op.(znz_is_even).
-
  Lemma spec_is_even : forall x,
-      if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
+      if ZnZ.is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
  Proof.
- unfold w_is_even; simpl; intros.
+ unfold ZnZ.is_even; simpl; intros.
  generalize (spec_div x 2).
  destruct (x/2)%int31 as (q,r); intros.
  unfold compare31.
@@ -2445,77 +2412,60 @@ Section Int31_Spec.
  destruct H; auto with zarith.
  replace ([|x|] mod 2) with [|r|].
  destruct H; auto with zarith.
- case_eq ([|r|] ?= 0)%Z; intros.
- apply Zcompare_Eq_eq; auto.
- change ([|r|] < 0)%Z in H; auto with zarith.
- change ([|r|] > 0)%Z in H; auto with zarith.
+ case Zcompare_spec; auto with zarith.
  apply Zmod_unique with [|q|]; auto with zarith.
  Qed.
 
- Definition int31_spec : znz_spec int31_op.
-  split.
-  exact phi_bounded.
-  exact positive_to_int31_spec.
-  exact spec_zdigits.
-  exact spec_more_than_1_digit.
-
-  exact spec_0.
-  exact spec_1.
-  exact spec_Bm1.
-
-  exact spec_compare.
-  exact spec_eq0.
-
-  exact spec_opp_c.
-  exact spec_opp.
-  exact spec_opp_carry.
-
-  exact spec_succ_c.
-  exact spec_add_c.
-  exact spec_add_carry_c.
-  exact spec_succ.
-  exact spec_add.
-  exact spec_add_carry.
-
-  exact spec_pred_c.
-  exact spec_sub_c.
-  exact spec_sub_carry_c.
-  exact spec_pred.
-  exact spec_sub.
-  exact spec_sub_carry.
-
-  exact spec_mul_c.
-  exact spec_mul.
-  exact spec_square_c.
-
-  exact spec_div21.
-  intros; apply spec_div; auto.
-  exact spec_div.
-
-  intros; unfold int31_op; simpl; apply spec_mod; auto.
-  exact spec_mod.
-
-  intros; apply spec_gcd; auto.
-  exact spec_gcd.
-
-  exact spec_head00.
-  exact spec_head0.
-  exact spec_tail00.
-  exact spec_tail0.
-
-  exact spec_add_mul_div.
-  exact spec_pos_mod.
-
-  exact spec_is_even.
-  exact spec_sqrt2.
-  exact spec_sqrt.
- Qed.
-
-End Int31_Spec.
+ Global Instance int31_specs : ZnZ.Specs int31_ops := {
+    spec_to_Z   := phi_bounded;
+    spec_of_pos := positive_to_int31_spec;
+    spec_zdigits := spec_zdigits;
+    spec_more_than_1_digit := spec_more_than_1_digit;
+    spec_0   := spec_0;
+    spec_1   := spec_1;
+    spec_m1  := spec_m1;
+    spec_compare := spec_compare;
+    spec_eq0 := spec_eq0;
+    spec_opp_c := spec_opp_c;
+    spec_opp := spec_opp;
+    spec_opp_carry := spec_opp_carry;
+    spec_succ_c := spec_succ_c;
+    spec_add_c := spec_add_c;
+    spec_add_carry_c := spec_add_carry_c;
+    spec_succ := spec_succ;
+    spec_add := spec_add;
+    spec_add_carry := spec_add_carry;
+    spec_pred_c := spec_pred_c;
+    spec_sub_c := spec_sub_c;
+    spec_sub_carry_c := spec_sub_carry_c;
+    spec_pred := spec_pred;
+    spec_sub := spec_sub;
+    spec_sub_carry := spec_sub_carry;
+    spec_mul_c := spec_mul_c;
+    spec_mul := spec_mul;
+    spec_square_c := spec_square_c;
+    spec_div21 := spec_div21;
+    spec_div_gt := fun a b _ => spec_div a b;
+    spec_div := spec_div;
+    spec_modulo_gt := fun a b _ => spec_mod a b;
+    spec_modulo := spec_mod;
+    spec_gcd_gt := fun a b _ => spec_gcd a b;
+    spec_gcd := spec_gcd;
+    spec_head00 := spec_head00;
+    spec_head0 := spec_head0;
+    spec_tail00 := spec_tail00;
+    spec_tail0 := spec_tail0;
+    spec_add_mul_div := spec_add_mul_div;
+    spec_pos_mod := spec_pos_mod;
+    spec_is_even := spec_is_even;
+    spec_sqrt2 := spec_sqrt2;
+    spec_sqrt := spec_sqrt }.
+
+End Int31_Specs.
 
 
 Module Int31Cyclic <: CyclicType.
-  Definition w := int31.
-  Definition w_op := int31_op.
-  Definition w_spec := int31_spec.
+  Definition t := int31.
+  Definition ops := int31_ops.
+  Definition specs := int31_specs.
 End Int31Cyclic.
diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v
index 5e1cd0e1..20f750f6 100644
--- a/theories/Numbers/Cyclic/Int31/Int31.v
+++ b/theories/Numbers/Cyclic/Int31/Int31.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,15 +8,11 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: Int31.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NaryFunctions.
 Require Import Wf_nat.
 Require Export ZArith.
 Require Export DoubleType.
 
-Unset Boxed Definitions.
-
 (** * 31-bit integers *)
 
 (** This file contains basic definitions of a 31-bit integer
@@ -353,16 +349,16 @@ Register div31 as int31 div in "coq_int31" by True.
 Register compare31 as int31 compare in "coq_int31" by True.
 Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True.
 
-Definition gcd31 (i j:int31) :=
-  (fix euler (guard:nat) (i j:int31) {struct guard} :=
-   match guard with
-   | O => In
-   | S p => match j ?= On with
-            | Eq => i
-            | _ => euler p j (let (_, r ) := i/j in r)
-            end
-   end)
-  (2*size)%nat i j.
+Fixpoint euler (guard:nat) (i j:int31) {struct guard} :=
+  match guard with
+    | O => In
+    | S p => match j ?= On with
+               | Eq => i
+               | _ => euler p j (let (_, r ) := i/j in r)
+             end
+  end.
+
+Definition gcd31 (i j:int31) := euler (2*size)%nat i j.
 
 (** Square root functions using newton iteration
     we use a very naive upper-bound on the iteration
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
index 37dc0871..23e8bd33 100644
--- a/theories/Numbers/Cyclic/Int31/Ring31.v
+++ b/theories/Numbers/Cyclic/Int31/Ring31.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ring31.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped
       with a ring structure and a ring tactic *)
 
@@ -83,9 +81,10 @@ 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.
+rewrite Cyclic31.spec_compare. case Zcompare_spec.
+intuition. apply Int31_canonic; auto.
+intuition; subst; auto with zarith; try discriminate.
+intuition; subst; auto with zarith; try discriminate.
 Qed.
 
 Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y.
diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
index aef729bf..d039fdcb 100644
--- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v
+++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZModulo.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ]
       as defined abstractly in CyclicAxioms. *)
 
@@ -33,25 +31,23 @@ Section ZModulo.
 
  Definition wB := base digits.
 
- Definition znz := Z.
- Definition znz_digits := digits.
- Definition znz_zdigits := Zpos digits.
- Definition znz_to_Z x := x mod wB.
+ Definition t := Z.
+ Definition zdigits := Zpos digits.
+ Definition to_Z x := x mod wB.
 
- Notation "[| x |]" := (znz_to_Z x)  (at level 0, x at level 99).
+ Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wB znz_to_Z c)  (at level 0, x at level 99).
+   (interp_carry 1 wB to_Z c)  (at level 0, x at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wB znz_to_Z c)  (at level 0, x at level 99).
+   (interp_carry (-1) wB to_Z c)  (at level 0, x at level 99).
 
  Notation "[|| x ||]" :=
-   (zn2z_to_Z wB znz_to_Z x)  (at level 0, x at level 99).
+   (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).
 
  Lemma spec_more_than_1_digit: 1 < Zpos digits.
  Proof.
-  unfold znz_digits.
   generalize digits_ne_1; destruct digits; auto.
   destruct 1; auto.
  Qed.
@@ -65,12 +61,12 @@ Section ZModulo.
 
  Lemma spec_to_Z_1 : forall x, 0 <= [|x|].
  Proof.
-  unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
+  unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
  Qed.
 
  Lemma spec_to_Z_2 : forall x, [|x|] < wB.
  Proof.
-  unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
+  unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
  Qed.
  Hint Resolve spec_to_Z_1 spec_to_Z_2.
 
@@ -79,16 +75,16 @@ Section ZModulo.
   auto.
  Qed.
 
- Definition znz_of_pos x :=
+ Definition of_pos x :=
    let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r).
 
  Lemma spec_of_pos : forall p,
-   Zpos p = (Z_of_N (fst (znz_of_pos p)))*wB + [|(snd (znz_of_pos p))|].
+   Zpos p = (Z_of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|].
  Proof.
-  intros; unfold znz_of_pos; simpl.
+  intros; unfold of_pos; simpl.
   generalize (Z_div_mod_POS wB wB_pos p).
   destruct (Zdiv_eucl_POS p wB); simpl; destruct 1.
-  unfold znz_to_Z; rewrite Zmod_small; auto.
+  unfold to_Z; rewrite Zmod_small; auto.
   assert (0 <= z).
    replace z with (Zpos p / wB) by
     (symmetry; apply Zdiv_unique with z0; auto).
@@ -98,37 +94,37 @@ Section ZModulo.
   rewrite Zmult_comm; auto.
  Qed.
 
- Lemma spec_zdigits : [|znz_zdigits|] = Zpos znz_digits.
+ Lemma spec_zdigits : [|zdigits|] = Zpos digits.
  Proof.
-  unfold znz_to_Z, znz_zdigits, znz_digits.
+  unfold to_Z, zdigits.
   apply Zmod_small.
   unfold wB, base.
   split; auto with zarith.
   apply Zpower2_lt_lin; auto with zarith.
  Qed.
 
- Definition znz_0 := 0.
- Definition znz_1 := 1.
- Definition znz_Bm1 := wB - 1.
+ Definition zero := 0.
+ Definition one := 1.
+ Definition minus_one := wB - 1.
 
- Lemma spec_0 : [|znz_0|] = 0.
+ Lemma spec_0 : [|zero|] = 0.
  Proof.
-  unfold znz_to_Z, znz_0.
+  unfold to_Z, zero.
   apply Zmod_small; generalize wB_pos; auto with zarith.
  Qed.
 
- Lemma spec_1 : [|znz_1|] = 1.
+ Lemma spec_1 : [|one|] = 1.
  Proof.
-  unfold znz_to_Z, znz_1.
+  unfold to_Z, one.
   apply Zmod_small; split; auto with zarith.
   unfold wB, base.
   apply Zlt_trans with (Zpos digits); auto.
   apply Zpower2_lt_lin; auto with zarith.
  Qed.
 
- Lemma spec_Bm1 : [|znz_Bm1|] = wB - 1.
+ Lemma spec_Bm1 : [|minus_one|] = wB - 1.
  Proof.
-  unfold znz_to_Z, znz_Bm1.
+  unfold to_Z, minus_one.
   apply Zmod_small; split; auto with zarith.
   unfold wB, base.
   cut (1 <= 2 ^ Zpos digits); auto with zarith.
@@ -136,54 +132,46 @@ Section ZModulo.
   apply Zpower2_le_lin; auto with zarith.
  Qed.
 
- Definition znz_compare x y := Zcompare [|x|] [|y|].
+ Definition compare x y := Zcompare [|x|] [|y|].
 
  Lemma spec_compare : forall x y,
-       match znz_compare x y with
-       | Eq => [|x|] = [|y|]
-       | Lt => [|x|] < [|y|]
-       | Gt => [|x|] > [|y|]
-       end.
- Proof.
-  intros; unfold znz_compare, Zlt, Zgt.
-  case_eq (Zcompare [|x|] [|y|]); auto.
-  intros; apply Zcompare_Eq_eq; auto.
- Qed.
+   compare x y = Zcompare [|x|] [|y|].
+ Proof. reflexivity. Qed.
 
- Definition znz_eq0 x :=
+ Definition eq0 x :=
    match [|x|] with Z0 => true | _ => false end.
 
- Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0.
+ Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0.
  Proof.
-  unfold znz_eq0; intros; now destruct [|x|].
+  unfold eq0; intros; now destruct [|x|].
  Qed.
 
- 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.
+ Definition opp_c x :=
+   if eq0 x then C0 0 else C1 (- x).
+ Definition opp x := - x.
+ Definition opp_carry x := - x - 1.
 
- Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|].
+ Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|].
  Proof.
- intros; unfold znz_opp_c, znz_to_Z; auto.
- case_eq (znz_eq0 x); intros; unfold interp_carry.
+ intros; unfold opp_c, to_Z; auto.
+ case_eq (eq0 x); intros; unfold interp_carry.
  fold [|x|]; rewrite (spec_eq0 x H); auto.
  assert (x mod wB <> 0).
-  unfold znz_eq0, znz_to_Z in H.
+  unfold eq0, to_Z in H.
   intro H0; rewrite H0 in H; discriminate.
  rewrite Z_mod_nz_opp_full; auto with zarith.
  Qed.
 
- Lemma spec_opp : forall x, [|znz_opp x|] = (-[|x|]) mod wB.
+ Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB.
  Proof.
- intros; unfold znz_opp, znz_to_Z; auto.
+ intros; unfold opp, to_Z; auto.
  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.
+ Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1.
  Proof.
- intros; unfold znz_opp_carry, znz_to_Z; auto.
+ intros; unfold opp_carry, to_Z; auto.
  replace (- x - 1) with (- 1 - x) by omega.
  rewrite <- Zminus_mod_idemp_r.
  replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega.
@@ -194,21 +182,21 @@ Section ZModulo.
  generalize (Z_mod_lt x wB wB_pos); omega.
  Qed.
 
- Definition znz_succ_c x :=
+ Definition succ_c x :=
   let y := Zsucc x in
-  if znz_eq0 y then C1 0 else C0 y.
+  if eq0 y then C1 0 else C0 y.
 
- Definition znz_add_c x y :=
+ Definition 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 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).
 
- Definition znz_succ := Zsucc.
- Definition znz_add := Zplus.
- Definition znz_add_carry x y := x + y + 1.
+ Definition succ := Zsucc.
+ Definition add := Zplus.
+ Definition add_carry x y := x + y + 1.
 
  Lemma Zmod_equal :
   forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z.
@@ -221,10 +209,10 @@ Section ZModulo.
  rewrite Zplus_comm, Zmult_comm, Z_mod_plus; auto.
  Qed.
 
- Lemma spec_succ_c : forall x, [+|znz_succ_c x|] = [|x|] + 1.
+ Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
  Proof.
- intros; unfold znz_succ_c, znz_to_Z, Zsucc.
- case_eq (znz_eq0 (x+1)); intros; unfold interp_carry.
+ intros; unfold succ_c, to_Z, Zsucc.
+ case_eq (eq0 (x+1)); intros; unfold interp_carry.
 
  rewrite Zmult_1_l.
  replace (wB + 0 mod wB) with wB by auto with zarith.
@@ -236,7 +224,7 @@ Section ZModulo.
  apply Zmod_equal; auto.
 
  assert ((x+1) mod wB <> 0).
-  unfold znz_eq0, znz_to_Z in *; now destruct ((x+1) mod wB).
+  unfold eq0, to_Z in *; now destruct ((x+1) mod wB).
  assert (x mod wB + 1 <> wB).
   contradict H0.
   rewrite Zeq_plus_swap in H0; simpl in H0.
@@ -247,9 +235,9 @@ Section ZModulo.
  generalize (Z_mod_lt x wB wB_pos); omega.
  Qed.
 
- Lemma spec_add_c : forall x y, [+|znz_add_c x y|] = [|x|] + [|y|].
+ Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|].
  Proof.
- intros; unfold znz_add_c, znz_to_Z, interp_carry.
+ intros; unfold add_c, to_Z, interp_carry.
  destruct Z_lt_le_dec.
  apply Zmod_small;
   generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
@@ -258,9 +246,9 @@ Section ZModulo.
   generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
  Qed.
 
- Lemma spec_add_carry_c : forall x y, [+|znz_add_carry_c x y|] = [|x|] + [|y|] + 1.
+ Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1.
  Proof.
- intros; unfold znz_add_carry_c, znz_to_Z, interp_carry.
+ intros; unfold add_carry_c, to_Z, interp_carry.
  destruct Z_lt_le_dec.
  apply Zmod_small;
   generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
@@ -269,59 +257,59 @@ Section ZModulo.
   generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
  Qed.
 
- Lemma spec_succ : forall x, [|znz_succ x|] = ([|x|] + 1) mod wB.
+ Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB.
  Proof.
- intros; unfold znz_succ, znz_to_Z, Zsucc.
+ intros; unfold succ, to_Z, Zsucc.
  symmetry; apply Zplus_mod_idemp_l.
  Qed.
 
- Lemma spec_add : forall x y, [|znz_add x y|] = ([|x|] + [|y|]) mod wB.
+ Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB.
  Proof.
- intros; unfold znz_add, znz_to_Z; apply Zplus_mod.
+ intros; unfold add, to_Z; apply Zplus_mod.
  Qed.
 
  Lemma spec_add_carry :
-	 forall x y, [|znz_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.
+	 forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.
  Proof.
- intros; unfold znz_add_carry, znz_to_Z.
+ intros; unfold add_carry, to_Z.
  rewrite <- Zplus_mod_idemp_l.
  rewrite (Zplus_mod x y).
  rewrite Zplus_mod_idemp_l; auto.
  Qed.
 
- Definition znz_pred_c x :=
-  if znz_eq0 x then C1 (wB-1) else C0 (x-1).
+ Definition pred_c x :=
+  if eq0 x then C1 (wB-1) else C0 (x-1).
 
- Definition znz_sub_c x y :=
+ Definition 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 :=
+ Definition 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.
- Definition znz_sub := Zminus.
- Definition znz_sub_carry x y := x - y - 1.
+ Definition pred := Zpred.
+ Definition sub := Zminus.
+ Definition sub_carry x y := x - y - 1.
 
- Lemma spec_pred_c : forall x, [-|znz_pred_c x|] = [|x|] - 1.
+ Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
  Proof.
- intros; unfold znz_pred_c, znz_to_Z, interp_carry.
- case_eq (znz_eq0 x); intros.
+ intros; unfold pred_c, to_Z, interp_carry.
+ case_eq (eq0 x); intros.
  fold [|x|]; rewrite spec_eq0; auto.
  replace ((wB-1) mod wB) with (wB-1); auto with zarith.
  symmetry; apply Zmod_small; generalize wB_pos; omega.
 
  assert (x mod wB <> 0).
-  unfold znz_eq0, znz_to_Z in *; now destruct (x mod wB).
+  unfold eq0, to_Z in *; now destruct (x mod wB).
  rewrite <- Zminus_mod_idemp_l.
  apply Zmod_small.
  generalize (Z_mod_lt x wB wB_pos); omega.
  Qed.
 
- Lemma spec_sub_c : forall x y, [-|znz_sub_c x y|] = [|x|] - [|y|].
+ Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
  Proof.
- intros; unfold znz_sub_c, znz_to_Z, interp_carry.
+ intros; unfold sub_c, to_Z, interp_carry.
  destruct Z_lt_le_dec.
  replace ((wB + (x mod wB - y mod wB)) mod wB) with
    (wB + (x mod wB - y mod wB)).
@@ -333,9 +321,9 @@ Section ZModulo.
  generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
  Qed.
 
- Lemma spec_sub_carry_c : forall x y, [-|znz_sub_carry_c x y|] = [|x|] - [|y|] - 1.
+ Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1.
  Proof.
- intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry.
+ intros; unfold sub_carry_c, to_Z, interp_carry.
  destruct Z_lt_le_dec.
  replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with
    (wB + (x mod wB - y mod wB -1)).
@@ -347,38 +335,38 @@ Section ZModulo.
  generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
  Qed.
 
- Lemma spec_pred : forall x, [|znz_pred x|] = ([|x|] - 1) mod wB.
+ Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB.
  Proof.
- intros; unfold znz_pred, znz_to_Z, Zpred.
+ intros; unfold pred, to_Z, Zpred.
  rewrite <- Zplus_mod_idemp_l; auto.
  Qed.
 
- Lemma spec_sub : forall x y, [|znz_sub x y|] = ([|x|] - [|y|]) mod wB.
+ Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB.
  Proof.
- intros; unfold znz_sub, znz_to_Z; apply Zminus_mod.
+ intros; unfold sub, to_Z; apply Zminus_mod.
  Qed.
 
  Lemma spec_sub_carry :
-  forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
+  forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
  Proof.
- intros; unfold znz_sub_carry, znz_to_Z.
+ intros; unfold sub_carry, to_Z.
  rewrite <- Zminus_mod_idemp_l.
  rewrite (Zminus_mod x y).
  rewrite Zminus_mod_idemp_l.
  auto.
  Qed.
 
- Definition znz_mul_c x y :=
+ Definition 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.
+  if eq0 h then if eq0 l then W0 else WW h l else WW h l.
 
- Definition znz_mul := Zmult.
+ Definition mul := Zmult.
 
- Definition znz_square_c x := znz_mul_c x x.
+ Definition square_c x := mul_c x x.
 
- Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|].
+ Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|].
  Proof.
- intros; unfold znz_mul_c, zn2z_to_Z.
+ intros; unfold mul_c, zn2z_to_Z.
  assert (Zdiv_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
   unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
  generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Zdiv_eucl as (h,l).
@@ -394,31 +382,31 @@ Section ZModulo.
   apply Zdiv_lt_upper_bound; auto with zarith.
   apply Zmult_lt_compat; auto with zarith.
  clear H H0 H1 H2.
- case_eq (znz_eq0 h); simpl; intros.
- case_eq (znz_eq0 l); simpl; intros.
+ case_eq (eq0 h); simpl; intros.
+ case_eq (eq0 l); simpl; intros.
  rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith.
  rewrite H3, H4; auto with zarith.
  rewrite H3, H4; auto with zarith.
  Qed.
 
- Lemma spec_mul : forall x y, [|znz_mul x y|] = ([|x|] * [|y|]) mod wB.
+ Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB.
  Proof.
- intros; unfold znz_mul, znz_to_Z; apply Zmult_mod.
+ intros; unfold mul, to_Z; apply Zmult_mod.
  Qed.
 
- Lemma spec_square_c : forall x, [|| znz_square_c x||] = [|x|] * [|x|].
+ Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|].
  Proof.
  intros x; exact (spec_mul_c x x).
  Qed.
 
- Definition znz_div x y := Zdiv_eucl [|x|] [|y|].
+ Definition div x y := Zdiv_eucl [|x|] [|y|].
 
  Lemma spec_div : forall a b, 0 < [|b|] ->
-      let (q,r) := znz_div a b in
+      let (q,r) := div a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|].
  Proof.
- intros; unfold znz_div.
+ intros; unfold div.
  assert ([|b|]>0) by auto with zarith.
  assert (Zdiv_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])).
   unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
@@ -440,10 +428,10 @@ Section ZModulo.
  rewrite H5, H6; rewrite Zmult_comm; auto with zarith.
  Qed.
 
- Definition znz_div_gt := znz_div.
+ Definition div_gt := div.
 
  Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
-      let (q,r) := znz_div_gt a b in
+      let (q,r) := div_gt a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|].
  Proof.
@@ -451,34 +439,34 @@ Section ZModulo.
  apply spec_div; auto.
  Qed.
 
- Definition znz_mod x y := [|x|] mod [|y|].
- Definition znz_mod_gt x y := [|x|] mod [|y|].
+ Definition modulo x y := [|x|] mod [|y|].
+ Definition modulo_gt x y := [|x|] mod [|y|].
 
- Lemma spec_mod :  forall a b, 0 < [|b|] ->
-      [|znz_mod a b|] = [|a|] mod [|b|].
+ Lemma spec_modulo :  forall a b, 0 < [|b|] ->
+      [|modulo a b|] = [|a|] mod [|b|].
  Proof.
- intros; unfold znz_mod.
+ intros; unfold modulo.
  apply Zmod_small.
  assert ([|b|]>0) by auto with zarith.
  generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos).
  fold [|b|]; omega.
  Qed.
 
- Lemma spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
-      [|znz_mod_gt a b|] = [|a|] mod [|b|].
+ Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
+      [|modulo_gt a b|] = [|a|] mod [|b|].
  Proof.
- intros; apply spec_mod; auto.
+ intros; apply spec_modulo; auto.
  Qed.
 
- Definition znz_gcd x y := Zgcd [|x|] [|y|].
- Definition znz_gcd_gt x y := Zgcd [|x|] [|y|].
+ Definition gcd x y := Zgcd [|x|] [|y|].
+ Definition gcd_gt x y := Zgcd [|x|] [|y|].
 
  Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Zgcd a b <= Zmax a b.
  Proof.
  intros.
  generalize (Zgcd_is_gcd a b); inversion_clear 1.
- destruct H2; destruct H3; clear H4.
- assert (H3:=Zgcd_is_pos a b).
+ destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4.
+ assert (H4:=Zgcd_is_pos a b).
  destruct (Z_eq_dec (Zgcd a b) 0).
  rewrite e; generalize (Zmax_spec a b); omega.
  assert (0 <= q).
@@ -489,15 +477,15 @@ Section ZModulo.
  generalize (Zmax_spec 0 b) (Zabs_spec b); omega.
 
  apply Zle_trans with a.
- rewrite H1 at 2.
+ rewrite H2 at 2.
  rewrite <- (Zmult_1_l (Zgcd a b)) at 1.
  apply Zmult_le_compat; auto with zarith.
  generalize (Zmax_spec a b); omega.
  Qed.
 
- Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|znz_gcd a b|].
+ Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
  Proof.
- intros; unfold znz_gcd.
+ intros; unfold gcd.
  generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros.
  fold [|a|] in *; fold [|b|] in *.
  replace ([|Zgcd [|a|] [|b|]|]) with (Zgcd [|a|] [|b|]).
@@ -511,22 +499,22 @@ Section ZModulo.
  Qed.
 
  Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] ->
-      Zis_gcd [|a|] [|b|] [|znz_gcd_gt a b|].
+      Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
  Proof.
   intros. apply spec_gcd; auto.
  Qed.
 
- Definition znz_div21 a1 a2 b :=
+ Definition div21 a1 a2 b :=
   Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|].
 
  Lemma spec_div21 : forall a1 a2 b,
       wB/2 <= [|b|] ->
       [|a1|] < [|b|] ->
-      let (q,r) := znz_div21 a1 a2 b in
+      let (q,r) := div21 a1 a2 b in
       [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|].
  Proof.
- intros; unfold znz_div21.
+ intros; unfold div21.
  generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros.
  generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros.
  assert ([|b|]>0) by auto with zarith.
@@ -552,22 +540,22 @@ Section ZModulo.
  rewrite H8, H9; rewrite Zmult_comm; auto with zarith.
  Qed.
 
- Definition znz_add_mul_div p x y :=
-   ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))).
+ Definition add_mul_div p x y :=
+   ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))).
  Lemma spec_add_mul_div : forall x y p,
-       [|p|] <= Zpos znz_digits ->
-       [| znz_add_mul_div p x y |] =
+       [|p|] <= Zpos digits ->
+       [| add_mul_div p x y |] =
          ([|x|] * (2 ^ [|p|]) +
-          [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))) mod wB.
+          [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB.
  Proof.
- intros; unfold znz_add_mul_div; auto.
+ intros; unfold add_mul_div; auto.
  Qed.
 
- Definition znz_pos_mod p w := [|w|] mod (2 ^ [|p|]).
+ Definition pos_mod p w := [|w|] mod (2 ^ [|p|]).
  Lemma spec_pos_mod : forall w p,
-       [|znz_pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
+       [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
  Proof.
- intros; unfold znz_pos_mod.
+ intros; unfold pos_mod.
  apply Zmod_small.
  generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros.
  split.
@@ -576,65 +564,58 @@ Section ZModulo.
  apply Zmod_le; auto with zarith.
  Qed.
 
- Definition znz_is_even x :=
+ Definition is_even x :=
    if Z_eq_dec ([|x|] mod 2) 0 then true else false.
 
  Lemma spec_is_even : forall x,
-      if znz_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
+      if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
  Proof.
- intros; unfold znz_is_even; destruct Z_eq_dec; auto.
+ intros; unfold is_even; destruct Z_eq_dec; auto.
  generalize (Z_mod_lt [|x|] 2); omega.
  Qed.
 
- Definition znz_sqrt x := Zsqrt_plain [|x|].
+ Definition sqrt x := Z.sqrt [|x|].
  Lemma spec_sqrt : forall x,
-       [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2.
+       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
  Proof.
  intros.
- unfold znz_sqrt.
+ unfold sqrt.
  repeat rewrite Zpower_2.
- replace [|Zsqrt_plain [|x|]|] with (Zsqrt_plain [|x|]).
- apply Zsqrt_interval; auto with zarith.
+ replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]).
+ apply Z.sqrt_spec; auto with zarith.
  symmetry; apply Zmod_small.
- split.
- apply Zsqrt_plain_is_pos; auto with zarith.
-
- cut (Zsqrt_plain [|x|] <= (wB-1)); try omega.
- rewrite <- (Zsqrt_square_id (wB-1)).
- apply Zsqrt_le.
- split; auto.
- apply Zle_trans with (wB-1); auto with zarith.
- generalize (spec_to_Z x); auto with zarith.
- apply Zsquare_le.
- generalize wB_pos; auto with zarith.
+ split. apply Z.sqrt_nonneg; auto.
+ apply Zle_lt_trans with [|x|]; auto.
+ apply Z.sqrt_le_lin; auto.
  Qed.
 
- Definition znz_sqrt2 x y :=
+ Definition sqrt2 x y :=
   let z := [|x|]*wB+[|y|] in
   match z with
    | Z0 => (0, C0 0)
    | Zpos p =>
-      let (s,r,_,_) := sqrtrempos p in
+      let (s,r) := Z.sqrtrem (Zpos p) in
       (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB))
    | Zneg _ => (0, C0 0)
   end.
 
  Lemma spec_sqrt2 : forall x y,
        wB/ 4 <= [|x|] ->
-       let (s,r) := znz_sqrt2 x y in
+       let (s,r) := sqrt2 x y in
           [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
           [+|r|] <= 2 * [|s|].
  Proof.
- intros; unfold znz_sqrt2.
+ intros; unfold sqrt2.
  simpl zn2z_to_Z.
  remember ([|x|]*wB+[|y|]) as z.
  destruct z.
  auto with zarith.
- destruct sqrtrempos; intros.
+ generalize (Z.sqrtrem_spec (Zpos p)).
+ destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith.
  assert (s < wB).
   destruct (Z_lt_le_dec s wB); auto.
   assert (wB * wB <= Zpos p).
-   rewrite e.
+   rewrite U.
    apply Zle_trans with (s*s); try omega.
    apply Zmult_le_compat; generalize wB_pos; auto with zarith.
   assert (Zpos p < wB*wB).
@@ -665,15 +646,15 @@ Section ZModulo.
  apply two_power_pos_correct.
  Qed.
 
- Definition znz_head0 x := match [|x|] with
-   | Z0 => znz_zdigits
-   | Zpos p => znz_zdigits - log_inf p - 1
+ Definition head0 x := match [|x|] with
+   | Z0 => zdigits
+   | Zpos p => zdigits - log_inf p - 1
    | _ => 0
   end.
 
- Lemma spec_head00:  forall x, [|x|] = 0 -> [|znz_head0 x|] = Zpos znz_digits.
+ Lemma spec_head00:  forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits.
  Proof.
-  unfold znz_head0; intros.
+  unfold head0; intros.
   rewrite H; simpl.
   apply spec_zdigits.
  Qed.
@@ -701,43 +682,43 @@ Section ZModulo.
 
 
  Lemma spec_head0  : forall x,  0 < [|x|] ->
-	 wB/ 2 <= 2 ^ ([|znz_head0 x|]) * [|x|] < wB.
+	 wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB.
  Proof.
- intros; unfold znz_head0.
+ intros; unfold head0.
  generalize (spec_to_Z x).
  destruct [|x|]; try discriminate.
  intros.
  destruct (log_inf_correct p).
  rewrite 2 two_p_power2 in H2; auto with zarith.
- assert (0 <= znz_zdigits - log_inf p - 1 < wB).
+ assert (0 <= zdigits - log_inf p - 1 < wB).
   split.
-  cut (log_inf p < znz_zdigits); try omega.
-  unfold znz_zdigits.
+  cut (log_inf p < zdigits); try omega.
+  unfold zdigits.
   unfold wB, base in *.
   apply log_inf_bounded; auto with zarith.
-  apply Zlt_trans with znz_zdigits.
+  apply Zlt_trans with zdigits.
   omega.
-  unfold znz_zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith.
+  unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith.
 
- unfold znz_to_Z; rewrite (Zmod_small _ _ H3).
+ unfold to_Z; rewrite (Zmod_small _ _ H3).
  destruct H2.
  split.
- apply Zle_trans with (2^(znz_zdigits - log_inf p - 1)*(2^log_inf p)).
+ apply Zle_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)).
  apply Zdiv_le_upper_bound; auto with zarith.
  rewrite <- Zpower_exp; auto with zarith.
  rewrite Zmult_comm; rewrite <- Zpower_Zsucc; auto with zarith.
- replace (Zsucc (znz_zdigits - log_inf p -1 +log_inf p)) with znz_zdigits
+ replace (Zsucc (zdigits - log_inf p -1 +log_inf p)) with zdigits
    by ring.
- unfold wB, base, znz_zdigits; auto with zarith.
+ unfold wB, base, zdigits; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
 
  apply Zlt_le_trans
-   with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))).
+   with (2^(zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))).
  apply Zmult_lt_compat_l; auto with zarith.
  rewrite <- Zpower_exp; auto with zarith.
- replace (znz_zdigits - log_inf p -1 +Zsucc (log_inf p)) with znz_zdigits
+ replace (zdigits - log_inf p -1 +Zsucc (log_inf p)) with zdigits
    by ring.
- unfold wB, base, znz_zdigits; auto with zarith.
+ unfold wB, base, zdigits; auto with zarith.
  Qed.
 
  Fixpoint Ptail p := match p with
@@ -774,24 +755,24 @@ Section ZModulo.
  rewrite <- H1; omega.
  Qed.
 
- Definition znz_tail0 x :=
+ Definition tail0 x :=
   match [|x|] with
-   | Z0 => znz_zdigits
+   | Z0 => zdigits
    | Zpos p => Ptail p
    | Zneg _ => 0
   end.
 
- Lemma spec_tail00:  forall x, [|x|] = 0 -> [|znz_tail0 x|] = Zpos znz_digits.
+ Lemma spec_tail00:  forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits.
  Proof.
-  unfold znz_tail0; intros.
+  unfold tail0; intros.
   rewrite H; simpl.
   apply spec_zdigits.
  Qed.
 
  Lemma spec_tail0  : forall x, 0 < [|x|] ->
-         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]).
+         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]).
  Proof.
- intros; unfold znz_tail0.
+ intros; unfold tail0.
  generalize (spec_to_Z x).
  destruct [|x|]; try discriminate; intros.
  assert ([|Ptail p|] = Ptail p).
@@ -818,60 +799,60 @@ Section ZModulo.
 
  (** Let's now group everything in two records *)
 
- Definition zmod_op := mk_znz_op
-    (znz_digits : positive)
-    (znz_zdigits: znz)
-    (znz_to_Z   : znz -> Z)
-    (znz_of_pos : positive -> N * znz)
-    (znz_head0  : znz -> znz)
-    (znz_tail0  : znz -> znz)
-
-    (znz_0   : znz)
-    (znz_1   : znz)
-    (znz_Bm1 : znz)
-
-    (znz_compare     : znz -> znz -> comparison)
-    (znz_eq0         : znz -> bool)
-
-    (znz_opp_c       : znz -> carry znz)
-    (znz_opp         : znz -> znz)
-    (znz_opp_carry   : znz -> znz)
-
-    (znz_succ_c      : znz -> carry znz)
-    (znz_add_c       : znz -> znz -> carry znz)
-    (znz_add_carry_c : znz -> znz -> carry znz)
-    (znz_succ        : znz -> znz)
-    (znz_add         : znz -> znz -> znz)
-    (znz_add_carry   : znz -> znz -> znz)
-
-    (znz_pred_c      : znz -> carry znz)
-    (znz_sub_c       : znz -> znz -> carry znz)
-    (znz_sub_carry_c : znz -> znz -> carry znz)
-    (znz_pred        : znz -> znz)
-    (znz_sub         : znz -> znz -> znz)
-    (znz_sub_carry   : znz -> znz -> znz)
-
-    (znz_mul_c       : znz -> znz -> zn2z znz)
-    (znz_mul         : znz -> znz -> znz)
-    (znz_square_c    : znz -> zn2z znz)
-
-    (znz_div21       : znz -> znz -> znz -> znz*znz)
-    (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_gcd_gt      : znz -> znz -> znz)
-    (znz_gcd         : znz -> znz -> znz)
-    (znz_add_mul_div : znz -> znz -> znz -> znz)
-    (znz_pos_mod     : znz -> znz -> znz)
-
-    (znz_is_even     : znz -> bool)
-    (znz_sqrt2       : znz -> znz -> znz * carry znz)
-    (znz_sqrt        : znz -> znz).
-
- Definition zmod_spec := mk_znz_spec zmod_op
+ Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps
+    (digits : positive)
+    (zdigits: t)
+    (to_Z   : t -> Z)
+    (of_pos : positive -> N * t)
+    (head0  : t -> t)
+    (tail0  : t -> t)
+
+    (zero   : t)
+    (one    : t)
+    (minus_one : t)
+
+    (compare     : t -> t -> comparison)
+    (eq0         : t -> bool)
+
+    (opp_c       : t -> carry t)
+    (opp         : t -> t)
+    (opp_carry   : t -> t)
+
+    (succ_c      : t -> carry t)
+    (add_c       : t -> t -> carry t)
+    (add_carry_c : t -> t -> carry t)
+    (succ        : t -> t)
+    (add         : t -> t -> t)
+    (add_carry   : t -> t -> t)
+
+    (pred_c      : t -> carry t)
+    (sub_c       : t -> t -> carry t)
+    (sub_carry_c : t -> t -> carry t)
+    (pred        : t -> t)
+    (sub         : t -> t -> t)
+    (sub_carry   : t -> t -> t)
+
+    (mul_c       : t -> t -> zn2z t)
+    (mul         : t -> t -> t)
+    (square_c    : t -> zn2z t)
+
+    (div21       : t -> t -> t -> t*t)
+    (div_gt      : t -> t -> t * t)
+    (div         : t -> t -> t * t)
+
+    (modulo_gt      : t -> t -> t)
+    (modulo         : t -> t -> t)
+
+    (gcd_gt      : t -> t -> t)
+    (gcd         : t -> t -> t)
+    (add_mul_div : t -> t -> t -> t)
+    (pos_mod     : t -> t -> t)
+
+    (is_even     : t -> bool)
+    (sqrt2       : t -> t -> t * carry t)
+    (sqrt        : t -> t).
+
+ Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs
     spec_to_Z
     spec_of_pos
     spec_zdigits
@@ -910,8 +891,8 @@ Section ZModulo.
     spec_div_gt
     spec_div
 
-    spec_mod_gt
-    spec_mod
+    spec_modulo_gt
+    spec_modulo
 
     spec_gcd_gt
     spec_gcd
@@ -934,12 +915,12 @@ 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.
- Definition w := Z.
- Definition w_op := zmod_op P.p.
- Definition w_spec := zmod_spec P.not_one.
+ Definition t := Z.
+ Instance ops : ZnZ.Ops t := zmod_ops P.p.
+ Instance specs : ZnZ.Specs ops := zmod_specs P.not_one.
 End ZModuloCyclicType.
 
diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v
index d9624ea3..647ab0ac 100644
--- a/theories/Numbers/Integer/Abstract/ZAdd.v
+++ b/theories/Numbers/Integer/Abstract/ZAdd.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,34 +8,33 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZBase.
 
-Module ZAddPropFunct (Import Z : ZAxiomsSig').
-Include ZBasePropFunct Z.
+Module ZAddProp (Import Z : ZAxiomsMiniSig').
+Include ZBaseProp Z.
 
 (** Theorems that are either not valid on N or have different proofs
     on N and Z *)
 
+Hint Rewrite opp_0 : nz.
+
 Theorem add_pred_l : forall n m, P n + m == P (n + m).
 Proof.
 intros n m.
 rewrite <- (succ_pred n) at 2.
-rewrite add_succ_l. now rewrite pred_succ.
+now rewrite add_succ_l, pred_succ.
 Qed.
 
 Theorem add_pred_r : forall n m, n + P m == P (n + m).
 Proof.
-intros n m; rewrite (add_comm n (P m)), (add_comm n m);
-apply add_pred_l.
+intros n m; rewrite 2 (add_comm n); apply add_pred_l.
 Qed.
 
 Theorem add_opp_r : forall n m, n + (- m) == n - m.
 Proof.
 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.
+now nzsimpl.
+intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd.
 Qed.
 
 Theorem sub_0_l : forall n, 0 - n == - n.
@@ -45,7 +44,7 @@ Qed.
 
 Theorem sub_succ_l : forall n m, S n - m == S (n - m).
 Proof.
-intros n m; do 2 rewrite <- add_opp_r; now rewrite add_succ_l.
+intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l.
 Qed.
 
 Theorem sub_pred_l : forall n m, P n - m == P (n - m).
@@ -69,7 +68,7 @@ Qed.
 Theorem sub_diag : forall n, n - n == 0.
 Proof.
 nzinduct n.
-now rewrite sub_0_r.
+now nzsimpl.
 intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ.
 Qed.
 
@@ -90,20 +89,20 @@ Qed.
 
 Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p.
 Proof.
-intros n m p; do 2 rewrite <- add_opp_r; now rewrite add_assoc.
+intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc.
 Qed.
 
 Theorem opp_involutive : forall n, - (- n) == n.
 Proof.
 nzinduct n.
-now do 2 rewrite opp_0.
-intro n. rewrite opp_succ, opp_pred; now rewrite succ_inj_wd.
+now nzsimpl.
+intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd.
 Qed.
 
 Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m).
 Proof.
 intros n m; nzinduct n.
-rewrite opp_0; now do 2 rewrite add_0_l.
+now nzsimpl.
 intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l.
 now rewrite pred_inj_wd.
 Qed.
@@ -116,12 +115,12 @@ Qed.
 
 Theorem opp_inj : forall n m, - n == - m -> n == m.
 Proof.
-intros n m H. apply opp_wd in H. now do 2 rewrite opp_involutive in H.
+intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H.
 Qed.
 
 Theorem opp_inj_wd : forall n m, - n == - m <-> n == m.
 Proof.
-intros n m; split; [apply opp_inj | apply opp_wd].
+intros n m; split; [apply opp_inj | intros; now f_equiv].
 Qed.
 
 Theorem eq_opp_l : forall n m, - n == m <-> n == - m.
@@ -137,7 +136,7 @@ Qed.
 Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p.
 Proof.
 intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc.
-now do 2 rewrite add_opp_r.
+now rewrite 2 add_opp_r.
 Qed.
 
 Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p.
@@ -148,7 +147,7 @@ Qed.
 
 Theorem sub_opp_l : forall n m, - n - m == - m - n.
 Proof.
-intros n m. do 2 rewrite <- add_opp_r. now rewrite add_comm.
+intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm.
 Qed.
 
 Theorem sub_opp_r : forall n m, n - (- m) == n + m.
@@ -165,7 +164,7 @@ Qed.
 Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p.
 Proof.
 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.
+rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l.
 apply opp_inj_wd.
 Qed.
 
@@ -252,6 +251,11 @@ Proof.
 intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r.
 Qed.
 
+Theorem sub_add : forall n m, m - n + n == m.
+Proof.
+ intros. now rewrite <- add_sub_swap, add_simpl_r.
+Qed.
+
 (** Now we have two sums or differences; the name includes the two
     operators and the position of the terms being canceled *)
 
@@ -289,5 +293,5 @@ Qed.
 
 (** Of course, there are many other variants *)
 
-End ZAddPropFunct.
+End ZAddProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v
index 6ce54f88..423cdf58 100644
--- a/theories/Numbers/Integer/Abstract/ZAddOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,180 +8,173 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZLt.
 
-Module ZAddOrderPropFunct (Import Z : ZAxiomsSig').
-Include ZOrderPropFunct Z.
+Module ZAddOrderProp (Import Z : ZAxiomsMiniSig').
+Include ZOrderProp Z.
 
 (** Theorems that are either not valid on N or have different proofs
     on N and Z *)
 
 Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
+intros. rewrite <- (add_0_l 0). now apply add_lt_mono.
 Qed.
 
 Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
+intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
 Qed.
 
 Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
+intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
 Qed.
 
 Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0.
 Proof.
-intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
+intros. rewrite <- (add_0_l 0). now apply add_le_mono.
 Qed.
 
 (** Sub and order *)
 
 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 add_lt_mono_r.
-rewrite add_0_l; now rewrite sub_simpl_r.
+intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r.
 Qed.
 
 Notation sub_pos := lt_0_sub (only parsing).
 
 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 add_le_mono_r.
-rewrite add_0_l; now rewrite sub_simpl_r.
+intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r.
 Qed.
 
 Notation sub_nonneg := le_0_sub (only parsing).
 
 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 add_lt_mono_r.
-rewrite add_0_l; now rewrite sub_simpl_r.
+intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r.
 Qed.
 
 Notation sub_neg := lt_sub_0 (only parsing).
 
 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 add_le_mono_r.
-rewrite add_0_l; now rewrite sub_simpl_r.
+intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r.
 Qed.
 
 Notation sub_nonpos := le_sub_0 (only parsing).
 
 Theorem opp_lt_mono : forall n m, n < m <-> - m < - n.
 Proof.
-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.
+intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub.
 Qed.
 
 Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n.
 Proof.
-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.
+intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub.
 Qed.
 
 Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0.
 Proof.
-intro n; rewrite (opp_lt_mono n 0); now rewrite opp_0.
+intro n; now rewrite (opp_lt_mono n 0), opp_0.
 Qed.
 
 Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n.
 Proof.
-intro n. rewrite (opp_lt_mono 0 n). now rewrite opp_0.
+intro n. now rewrite (opp_lt_mono 0 n), opp_0.
 Qed.
 
 Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0.
 Proof.
-intro n; rewrite (opp_le_mono n 0); now rewrite opp_0.
+intro n; now rewrite (opp_le_mono n 0), opp_0.
 Qed.
 
 Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n.
 Proof.
-intro n. rewrite (opp_le_mono 0 n). now rewrite opp_0.
+intro n. now rewrite (opp_le_mono 0 n), opp_0.
+Qed.
+
+Theorem lt_m1_0 : -1 < 0.
+Proof.
+apply opp_neg_pos, lt_0_1.
 Qed.
 
 Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n.
 Proof.
-intros n m p. do 2 rewrite <- add_opp_r. rewrite <- add_lt_mono_l.
-apply opp_lt_mono.
+intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono.
 Qed.
 
 Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p.
 Proof.
-intros n m p; do 2 rewrite <- add_opp_r; apply add_lt_mono_r.
+intros. now rewrite <- 2 add_opp_r, add_lt_mono_r.
 Qed.
 
 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 lt_trans with (m - p);
-[now apply -> sub_lt_mono_r | now apply -> sub_lt_mono_l].
+[now apply sub_lt_mono_r | now apply sub_lt_mono_l].
 Qed.
 
 Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n.
 Proof.
-intros n m p; do 2 rewrite <- add_opp_r; rewrite <- add_le_mono_l;
-apply opp_le_mono.
+intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono.
 Qed.
 
 Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p.
 Proof.
-intros n m p; do 2 rewrite <- add_opp_r; apply add_le_mono_r.
+intros. now rewrite <- 2 add_opp_r, add_le_mono_r.
 Qed.
 
 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 le_trans with (m - p);
-[now apply -> sub_le_mono_r | now apply -> sub_le_mono_l].
+[now apply sub_le_mono_r | now apply sub_le_mono_l].
 Qed.
 
 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 lt_le_trans with (m - p);
-[now apply -> sub_lt_mono_r | now apply -> sub_le_mono_l].
+[now apply sub_lt_mono_r | now apply sub_le_mono_l].
 Qed.
 
 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 le_lt_trans with (m - p);
-[now apply -> sub_le_mono_r | now apply -> sub_lt_mono_l].
+[now apply sub_le_mono_r | now apply sub_lt_mono_l].
 Qed.
 
 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 (le_lt_add_lt (- m) (- n));
-[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
+[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
 Qed.
 
 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 (lt_le_add_lt (- m) (- n));
-[now apply -> opp_lt_mono | now do 2 rewrite add_opp_r].
+[now apply -> opp_lt_mono | now rewrite 2 add_opp_r].
 Qed.
 
 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 (le_le_add_le (- m) (- n));
-[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
+[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
 Qed.
 
 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 sub_lt_mono_r.
-now rewrite add_simpl_r.
+intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r.
 Qed.
 
 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 sub_le_mono_r.
-now rewrite add_simpl_r.
+intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r.
 Qed.
 
 Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
@@ -196,14 +189,12 @@ Qed.
 
 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 add_lt_mono_r.
-now rewrite sub_simpl_r.
+intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r.
 Qed.
 
 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 add_le_mono_r.
-now rewrite sub_simpl_r.
+intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r.
 Qed.
 
 Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p.
@@ -218,74 +209,68 @@ Qed.
 
 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 lt_sub_lt_add_l. rewrite add_sub_assoc.
-now rewrite <- lt_add_lt_sub_r.
+intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r.
 Qed.
 
 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 le_sub_le_add_l. rewrite add_sub_assoc.
-now rewrite <- le_add_le_sub_r.
+intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r.
 Qed.
 
 Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n.
 Proof.
-intros n m. stepr (n - m < n - 0) by now rewrite sub_0_r. apply sub_lt_mono_l.
+intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r.
 Qed.
 
 Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n.
 Proof.
-intros n m. stepr (n - m <= n - 0) by now rewrite sub_0_r. apply sub_le_mono_l.
+intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r.
 Qed.
 
 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 lt_sub_lt_add in H. now apply add_lt_cases.
+intros. now apply add_lt_cases, lt_sub_lt_add.
 Qed.
 
 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 le_sub_le_add in H. now apply add_le_cases.
+intros. now apply add_le_cases, le_sub_le_add.
 Qed.
 
 Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m.
 Proof.
-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.
+intros.
+rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r.
 Qed.
 
 Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0.
 Proof.
-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.
+intros.
+rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r.
 Qed.
 
 Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m.
 Proof.
-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.
+intros.
+rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r.
 Qed.
 
 Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0.
 Proof.
-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.
+intros.
+rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r.
 Qed.
 
 Section PosNeg.
 
 Variable P : Z.t -> Prop.
-Hypothesis P_wd : Proper (Z.eq ==> iff) P.
+Hypothesis P_wd : Proper (eq ==> iff) P.
 
 Theorem zero_pos_neg :
   P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n.
 Proof.
 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].
+apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3].
 now rewrite opp_involutive in H3.
 now rewrite H3.
 apply H2 in H3; now destruct H3.
@@ -295,6 +280,6 @@ End PosNeg.
 
 Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg).
 
-End ZAddOrderPropFunct.
+End ZAddOrderProp.
 
 
diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v
index fd14cff0..fd20ce72 100644
--- a/theories/Numbers/Integer/Abstract/ZAxioms.v
+++ b/theories/Numbers/Integer/Abstract/ZAxioms.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,19 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NZAxioms.
+Require Import Bool NZParity NZPow NZSqrt NZLog NZGcd NZDiv NZBits.
+
+(** We obtain integers by postulating that successor of predecessor
+    is identity. *)
+
+Module Type ZAxiom (Import Z : NZAxiomsSig').
+ Axiom succ_pred : forall n, S (P n) == n.
+End ZAxiom.
 
-Set Implicit Arguments.
+(** For historical reasons, ZAxiomsMiniSig isn't just NZ + ZAxiom,
+    we also add an [opp] function, that can be seen as a shortcut
+    for [sub 0]. *)
 
 Module Type Opp (Import T:Typ).
  Parameter Inline opp : t -> t.
@@ -24,15 +32,91 @@ End OppNotation.
 
 Module Type Opp' (T:Typ) := Opp T <+ OppNotation T.
 
-(** We obtain integers by postulating that every number has a predecessor. *)
-
 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.
 
-Module Type ZAxiomsSig := NZOrdAxiomsSig <+ Opp <+ IsOpp.
-Module Type ZAxiomsSig' := NZOrdAxiomsSig' <+ Opp' <+ IsOpp.
+Module Type OppCstNotation (Import A : NZAxiomsSig)(Import B : Opp A).
+ Notation "- 1" := (opp one).
+ Notation "- 2" := (opp two).
+End OppCstNotation.
+
+Module Type ZAxiomsMiniSig := NZOrdAxiomsSig <+ ZAxiom <+ Opp <+ IsOpp.
+Module Type ZAxiomsMiniSig' := NZOrdAxiomsSig' <+ ZAxiom <+ Opp' <+ IsOpp
+ <+ OppCstNotation.
+
+
+(** Other functions and their specifications *)
+
+(** Absolute value *)
+
+Module Type HasAbs(Import Z : ZAxiomsMiniSig').
+ 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.
+
+(** A sign function *)
+
+Module Type HasSgn (Import Z : ZAxiomsMiniSig').
+ 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.
+
+(** Divisions *)
+
+(** First, the usual Coq convention of Truncated-Toward-Bottom
+    (a.k.a Floor). We simply extend the NZ signature. *)
+
+Module Type ZDivSpecific (Import A:ZAxiomsMiniSig')(Import B : DivMod' A).
+ 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:ZAxiomsMiniSig) := NZDiv.NZDiv Z <+ ZDivSpecific Z.
+Module Type ZDiv' (Z:ZAxiomsMiniSig) := NZDiv.NZDiv' Z <+ ZDivSpecific Z.
+
+(** Then, the Truncated-Toward-Zero convention.
+    For not colliding with Floor operations, we use different names
+*)
+
+Module Type QuotRem (Import A : Typ).
+ Parameters Inline quot rem : t -> t -> t.
+End QuotRem.
+
+Module Type QuotRemNotation (A : Typ)(Import B : QuotRem A).
+ Infix "÷" := quot (at level 40, left associativity).
+ Infix "rem" := rem (at level 40, no associativity).
+End QuotRemNotation.
+
+Module Type QuotRem' (A : Typ) := QuotRem A <+ QuotRemNotation A.
+
+Module Type QuotRemSpec (Import A : ZAxiomsMiniSig')(Import B : QuotRem' A).
+ Declare Instance quot_wd : Proper (eq==>eq==>eq) quot.
+ Declare Instance rem_wd : Proper (eq==>eq==>eq) B.rem.
+ Axiom quot_rem : forall a b, b ~= 0 -> a == b*(a÷b) + (a rem b).
+ Axiom rem_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a rem b < b.
+ Axiom rem_opp_l : forall a b, b ~= 0 -> (-a) rem b == - (a rem b).
+ Axiom rem_opp_r : forall a b, b ~= 0 -> a rem (-b) == a rem b.
+End QuotRemSpec.
+
+Module Type ZQuot (Z:ZAxiomsMiniSig) := QuotRem Z <+ QuotRemSpec Z.
+Module Type ZQuot' (Z:ZAxiomsMiniSig) := QuotRem' Z <+ QuotRemSpec Z.
+
+(** For all other functions, the NZ axiomatizations are enough. *)
+
+(** Let's group everything *)
+
+Module Type ZAxiomsSig := ZAxiomsMiniSig <+ OrderFunctions
+   <+ HasAbs <+ HasSgn <+ NZParity.NZParity
+   <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 <+ NZGcd.NZGcd
+   <+ ZDiv <+ ZQuot <+ NZBits.NZBits <+ NZSquare.
 
+Module Type ZAxiomsSig' := ZAxiomsMiniSig' <+ OrderFunctions'
+   <+ HasAbs <+ HasSgn <+ NZParity.NZParity
+   <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 <+ NZGcd.NZGcd'
+   <+ ZDiv' <+ ZQuot' <+ NZBits.NZBits' <+ NZSquare.
diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v
index aa7979ae..51054852 100644
--- a/theories/Numbers/Integer/Abstract/ZBase.v
+++ b/theories/Numbers/Integer/Abstract/ZBase.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,26 +8,29 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Decidable.
 Require Export ZAxioms.
 Require Import NZProperties.
 
-Module ZBasePropFunct (Import Z : ZAxiomsSig').
-Include NZPropFunct Z.
+Module ZBaseProp (Import Z : ZAxiomsMiniSig').
+Include NZProp Z.
 
 (* Theorems that are true for integers but not for natural numbers *)
 
 Theorem pred_inj : forall n m, P n == P m -> n == m.
 Proof.
-intros n m H. apply succ_wd in H. now do 2 rewrite succ_pred in H.
+intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H.
 Qed.
 
 Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2.
 Proof.
-intros n1 n2; split; [apply pred_inj | apply pred_wd].
+intros n1 n2; split; [apply pred_inj | intros; now f_equiv].
+Qed.
+
+Lemma succ_m1 : S (-1) == 0.
+Proof.
+ now rewrite one_succ, opp_succ, opp_0, succ_pred.
 Qed.
 
-End ZBasePropFunct.
+End ZBaseProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v
new file mode 100644
index 00000000..92afbcb5
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZBits.v
@@ -0,0 +1,1947 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import
+ Bool ZAxioms ZMulOrder ZPow ZDivFloor ZSgnAbs ZParity NZLog.
+
+(** Derived properties of bitwise operations *)
+
+Module Type ZBitsProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZParityProp A B)
+ (Import D : ZSgnAbsProp A B)
+ (Import E : ZPowProp A B C D)
+ (Import F : ZDivProp A B D)
+ (Import G : NZLog2Prop A A A B E).
+
+Include BoolEqualityFacts A.
+
+Ltac order_nz := try apply pow_nonzero; order'.
+Ltac order_pos' := try apply abs_nonneg; order_pos.
+Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz.
+
+(** Some properties of power and division *)
+
+Lemma pow_sub_r : forall a b c, a~=0 -> 0<=c<=b -> a^(b-c) == a^b / a^c.
+Proof.
+ intros a b c Ha (H,H'). rewrite <- (sub_simpl_r b c) at 2.
+ rewrite pow_add_r; trivial.
+ rewrite div_mul. reflexivity.
+ now apply pow_nonzero.
+ now apply le_0_sub.
+Qed.
+
+Lemma pow_div_l : forall a b c, b~=0 -> 0<=c -> a mod b == 0 ->
+ (a/b)^c == a^c / b^c.
+Proof.
+ intros a b c Hb Hc H. rewrite (div_mod a b Hb) at 2.
+ rewrite H, add_0_r, pow_mul_l, mul_comm, div_mul. reflexivity.
+ now apply pow_nonzero.
+Qed.
+
+(** An injection from bits [true] and [false] to numbers 1 and 0.
+    We declare it as a (local) coercion for shorter statements. *)
+
+Definition b2z (b:bool) := if b then 1 else 0.
+Local Coercion b2z : bool >-> t.
+
+Instance b2z_wd : Proper (Logic.eq ==> eq) b2z := _.
+
+Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b.
+Proof.
+ elim (Even_or_Odd a); [intros (a',H)| intros (a',H)].
+ exists a'. exists false. now nzsimpl.
+ exists a'. exists true. now simpl.
+Qed.
+
+(** We can compact [testbit_odd_0] [testbit_even_0]
+    [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *)
+
+Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b.
+Proof.
+ destruct b; simpl; rewrite ?add_0_r.
+ apply testbit_odd_0.
+ apply testbit_even_0.
+Qed.
+
+Lemma testbit_succ_r a (b:bool) n : 0<=n ->
+ testbit (2*a+b) (succ n) = testbit a n.
+Proof.
+ destruct b; simpl; rewrite ?add_0_r.
+ now apply testbit_odd_succ.
+ now apply testbit_even_succ.
+Qed.
+
+(** Alternative caracterisations of [testbit] *)
+
+(** This concise equation could have been taken as specification
+   for testbit in the interface, but it would have been hard to
+   implement with little initial knowledge about div and mod *)
+
+Lemma testbit_spec' a n : 0<=n -> a.[n] == (a / 2^n) mod 2.
+Proof.
+ intro Hn. revert a. apply le_ind with (4:=Hn). 
+   solve_proper.
+ intros a. nzsimpl.
+ destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
+ rewrite testbit_0_r. apply mod_unique with a'; trivial.
+ left. destruct b; split; simpl; order'.
+ clear n Hn. intros n Hn IH a.
+ destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
+ rewrite testbit_succ_r, IH by trivial. f_equiv.
+ rewrite pow_succ_r, <- div_div by order_pos. f_equiv.
+ apply div_unique with b; trivial.
+ left. destruct b; split; simpl; order'.
+Qed.
+
+(** This caracterisation that uses only basic operations and
+   power was initially taken as specification for testbit.
+   We describe [a] as having a low part and a high part, with
+   the corresponding bit in the middle. This caracterisation
+   is moderatly complex to implement, but also moderately
+   usable... *)
+
+Lemma testbit_spec a n : 0<=n ->
+  exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n.
+Proof.
+ intro Hn. exists (a mod 2^n). exists (a / 2^n / 2). split.
+ apply mod_pos_bound; order_pos.
+ rewrite add_comm, mul_comm, (add_comm a.[n]).
+ rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv.
+ rewrite testbit_spec' by trivial. apply div_mod. order'.
+Qed.
+
+Lemma testbit_true : forall a n, 0<=n ->
+ (a.[n] = true <-> (a / 2^n) mod 2 == 1).
+Proof.
+ intros a n Hn.
+ rewrite <- testbit_spec' by trivial.
+ destruct a.[n]; split; simpl; now try order'.
+Qed.
+
+Lemma testbit_false : forall a n, 0<=n ->
+ (a.[n] = false <-> (a / 2^n) mod 2 == 0).
+Proof.
+ intros a n Hn.
+ rewrite <- testbit_spec' by trivial.
+ destruct a.[n]; split; simpl; now try order'.
+Qed.
+
+Lemma testbit_eqb : forall a n, 0<=n ->
+ a.[n] = eqb ((a / 2^n) mod 2) 1.
+Proof.
+ intros a n Hn.
+ apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq.
+Qed.
+
+(** Results about the injection [b2z] *)
+
+Lemma b2z_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0.
+Proof.
+ intros [|] [|]; simpl; trivial; order'.
+Qed.
+
+Lemma add_b2z_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a.
+Proof.
+ intros a0 a. rewrite mul_comm, div_add by order'.
+ now rewrite div_small, add_0_l by (destruct a0; split; simpl; order').
+Qed.
+
+Lemma add_b2z_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0.
+Proof.
+ intros a0 a. apply b2z_inj.
+ rewrite testbit_spec' by order.
+ nzsimpl. rewrite mul_comm, mod_add by order'.
+ now rewrite mod_small by (destruct a0; split; simpl; order').
+Qed.
+
+Lemma b2z_div2 : forall (a0:bool), a0/2 == 0.
+Proof.
+ intros a0. rewrite <- (add_b2z_double_div2 a0 0). now nzsimpl.
+Qed.
+
+Lemma b2z_bit0 : forall (a0:bool), a0.[0] = a0.
+Proof.
+ intros a0. rewrite <- (add_b2z_double_bit0 a0 0) at 2. now nzsimpl.
+Qed.
+
+(** The specification of testbit by low and high parts is complete *)
+
+Lemma testbit_unique : forall a n (a0:bool) l h,
+ 0<=l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0.
+Proof.
+ intros a n a0 l h Hl EQ.
+ assert (0<=n).
+  destruct (le_gt_cases 0 n) as [Hn|Hn]; trivial.
+  rewrite pow_neg_r in Hl by trivial. destruct Hl; order.
+ apply b2z_inj. rewrite testbit_spec' by trivial.
+ symmetry. apply mod_unique with h.
+ left; destruct a0; simpl; split; order'.
+ symmetry. apply div_unique with l.
+ now left.
+ now rewrite add_comm, (add_comm _ a0), mul_comm.
+Qed.
+
+(** All bits of number 0 are 0 *)
+
+Lemma bits_0 : forall n, 0.[n] = false.
+Proof.
+ intros n.
+ destruct (le_gt_cases 0 n).
+ apply testbit_false; trivial. nzsimpl; order_nz.
+ now apply testbit_neg_r.
+Qed.
+
+(** For negative numbers, we are actually doing two's complement *)
+
+Lemma bits_opp : forall a n, 0<=n -> (-a).[n] = negb (P a).[n].
+Proof.
+ intros a n Hn.
+ destruct (testbit_spec (-a) n Hn) as (l & h & Hl & EQ).
+ fold (b2z (-a).[n]) in EQ.
+ apply negb_sym.
+ apply testbit_unique with (2^n-l-1) (-h-1).
+ split.
+ apply lt_succ_r. rewrite sub_1_r, succ_pred. now apply lt_0_sub.
+ apply le_succ_l. rewrite sub_1_r, succ_pred. apply le_sub_le_add_r.
+ rewrite <- (add_0_r (2^n)) at 1. now apply add_le_mono_l.
+ rewrite <- add_sub_swap, sub_1_r. f_equiv.
+ apply opp_inj. rewrite opp_add_distr, opp_sub_distr.
+ rewrite (add_comm _ l), <- add_assoc.
+ rewrite EQ at 1. apply add_cancel_l.
+ rewrite <- opp_add_distr.
+ rewrite <- (mul_1_l (2^n)) at 2. rewrite <- mul_add_distr_r.
+ rewrite <- mul_opp_l.
+ f_equiv.
+ rewrite !opp_add_distr.
+ rewrite <- mul_opp_r.
+ rewrite opp_sub_distr, opp_involutive.
+ rewrite (add_comm h).
+ rewrite mul_add_distr_l.
+ rewrite !add_assoc.
+ apply add_cancel_r.
+ rewrite mul_1_r.
+ rewrite add_comm, add_assoc, !add_opp_r, sub_1_r, two_succ, pred_succ.
+ destruct (-a).[n]; simpl. now rewrite sub_0_r. now nzsimpl'.
+Qed.
+
+(** All bits of number (-1) are 1 *)
+
+Lemma bits_m1 : forall n, 0<=n -> (-1).[n] = true.
+Proof.
+ intros. now rewrite bits_opp, one_succ, pred_succ, bits_0.
+Qed.
+
+(** Various ways to refer to the lowest bit of a number *)
+
+Lemma bit0_odd : forall a, a.[0] = odd a.
+Proof.
+ intros. symmetry.
+ destruct (exists_div2 a) as (a' & b & EQ).
+ rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2.
+ destruct b; simpl; apply odd_1 || apply odd_0.
+Qed.
+
+Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1.
+Proof.
+ intros a. rewrite testbit_eqb by order. now nzsimpl.
+Qed.
+
+Lemma bit0_mod : forall a, a.[0] == a mod 2.
+Proof.
+ intros a. rewrite testbit_spec' by order. now nzsimpl.
+Qed.
+
+(** Hence testing a bit is equivalent to shifting and testing parity *)
+
+Lemma testbit_odd : forall a n, a.[n] = odd (a>>n).
+Proof.
+ intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l.
+Qed.
+
+(** [log2] gives the highest nonzero bit of positive numbers *)
+
+Lemma bit_log2 : forall a, 0<a -> a.[log2 a] = true.
+Proof.
+ intros a Ha.
+ assert (Ha' := log2_nonneg a).
+ destruct (log2_spec_alt a Ha) as (r & EQ & Hr).
+ rewrite EQ at 1.
+ rewrite testbit_true, add_comm by trivial.
+ rewrite <- (mul_1_l (2^log2 a)) at 1.
+ rewrite div_add by order_nz.
+ rewrite div_small; trivial.
+ rewrite add_0_l. apply mod_small. split; order'.
+Qed.
+
+Lemma bits_above_log2 : forall a n, 0<=a -> log2 a < n ->
+ a.[n] = false.
+Proof.
+ intros a n Ha H.
+ assert (Hn : 0<=n).
+  transitivity (log2 a). apply log2_nonneg. order'.
+ rewrite testbit_false by trivial.
+ rewrite div_small. nzsimpl; order'.
+ split. order. apply log2_lt_cancel. now rewrite log2_pow2.
+Qed.
+
+(** Hence the number of bits of [a] is [1+log2 a]
+    (see [Psize] and [Psize_pos]).
+*)
+
+(** For negative numbers, things are the other ways around:
+    log2 gives the highest zero bit (for numbers below -1).
+*)
+
+Lemma bit_log2_neg : forall a, a < -1 -> a.[log2 (P (-a))] = false.
+Proof.
+ intros a Ha.
+ rewrite <- (opp_involutive a) at 1.
+ rewrite bits_opp.
+ apply negb_false_iff.
+ apply bit_log2.
+ apply opp_lt_mono in Ha. rewrite opp_involutive in Ha.
+ apply lt_succ_lt_pred. now rewrite <- one_succ.
+ apply log2_nonneg.
+Qed.
+
+Lemma bits_above_log2_neg : forall a n, a < 0 -> log2 (P (-a)) < n ->
+ a.[n] = true.
+Proof.
+ intros a n Ha H.
+ assert (Hn : 0<=n).
+  transitivity (log2 (P (-a))). apply log2_nonneg. order'.
+ rewrite <- (opp_involutive a), bits_opp, negb_true_iff by trivial.
+ apply bits_above_log2; trivial.
+ now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l.
+Qed.
+
+(** Accesing a high enough bit of a number gives its sign *)
+
+Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n ->
+ (0<=a <-> a.[n] = false).
+Proof.
+ intros a n Hn. split; intros H.
+ rewrite abs_eq in Hn; trivial. now apply bits_above_log2.
+ destruct (le_gt_cases 0 a); trivial.
+ rewrite abs_neq in Hn by order.
+ rewrite bits_above_log2_neg in H; try easy.
+ apply le_lt_trans with (log2 (-a)); trivial.
+ apply log2_le_mono. apply le_pred_l.
+Qed.
+
+Lemma bits_iff_nonneg' : forall a,
+ 0<=a <-> a.[S (log2 (abs a))] = false.
+Proof.
+ intros. apply bits_iff_nonneg. apply lt_succ_diag_r.
+Qed.
+
+Lemma bits_iff_nonneg_ex : forall a,
+ 0<=a <-> (exists k, forall m, k<m -> a.[m] = false).
+Proof.
+ intros a. split.
+ intros Ha. exists (log2 a). intros m Hm. now apply bits_above_log2.
+ intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))).
+ now apply bits_iff_nonneg', Hk, lt_succ_r.
+ apply (bits_iff_nonneg a (S k)).
+ now apply lt_succ_r, lt_le_incl.
+ apply Hk. apply lt_succ_diag_r.
+Qed.
+
+Lemma bits_iff_neg : forall a n, log2 (abs a) < n ->
+ (a<0 <-> a.[n] = true).
+Proof.
+ intros a n Hn.
+ now rewrite lt_nge, <- not_false_iff_true, (bits_iff_nonneg a n).
+Qed.
+
+Lemma bits_iff_neg' : forall a, a<0 <-> a.[S (log2 (abs a))] = true.
+Proof.
+ intros. apply bits_iff_neg. apply lt_succ_diag_r.
+Qed.
+
+Lemma bits_iff_neg_ex : forall a,
+ a<0 <-> (exists k, forall m, k<m -> a.[m] = true).
+Proof.
+ intros a. split.
+ intros Ha. exists (log2 (P (-a))). intros m Hm. now apply bits_above_log2_neg.
+ intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))).
+ now apply bits_iff_neg', Hk, lt_succ_r.
+ apply (bits_iff_neg a (S k)).
+ now apply lt_succ_r, lt_le_incl.
+ apply Hk. apply lt_succ_diag_r.
+Qed.
+
+(** Testing bits after division or multiplication by a power of two *)
+
+Lemma div2_bits : forall a n, 0<=n -> (a/2).[n] = a.[S n].
+Proof.
+ intros a n Hn.
+ apply eq_true_iff_eq. rewrite 2 testbit_true by order_pos.
+ rewrite pow_succ_r by trivial.
+ now rewrite div_div by order_pos.
+Qed.
+
+Lemma div_pow2_bits : forall a n m, 0<=n -> 0<=m -> (a/2^n).[m] = a.[m+n].
+Proof.
+ intros a n m Hn. revert a m. apply le_ind with (4:=Hn).
+ solve_proper.
+ intros a m Hm. now nzsimpl.
+ clear n Hn. intros n Hn IH a m Hm. nzsimpl; trivial.
+ rewrite <- div_div by order_pos.
+ now rewrite IH, div2_bits by order_pos.
+Qed.
+
+Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n].
+Proof.
+ intros a n.
+ destruct (le_gt_cases 0 n) as [Hn|Hn].
+ now rewrite <- div2_bits, mul_comm, div_mul by order'.
+ rewrite (testbit_neg_r a n Hn).
+ apply le_succ_l in Hn. le_elim Hn.
+ now rewrite testbit_neg_r.
+ now rewrite Hn, bit0_odd, odd_mul, odd_2.
+Qed.
+
+Lemma double_bits : forall a n, (2*a).[n] = a.[P n].
+Proof.
+ intros a n. rewrite <- (succ_pred n) at 1. apply double_bits_succ.
+Qed.
+
+Lemma mul_pow2_bits_add : forall a n m, 0<=n -> (a*2^n).[n+m] = a.[m].
+Proof.
+ intros a n m Hn. revert a m. apply le_ind with (4:=Hn).
+ solve_proper.
+ intros a m. now nzsimpl.
+ clear n Hn. intros n Hn IH a m. nzsimpl; trivial.
+ rewrite mul_assoc, (mul_comm _ 2), <- mul_assoc.
+ now rewrite double_bits_succ.
+Qed.
+
+Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n].
+Proof.
+ intros.
+ rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm.
+ now apply mul_pow2_bits_add.
+Qed.
+
+Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false.
+Proof.
+ intros.
+ destruct (le_gt_cases 0 n).
+ rewrite mul_pow2_bits by trivial.
+ apply testbit_neg_r. now apply lt_sub_0.
+ now rewrite pow_neg_r, mul_0_r, bits_0.
+Qed.
+
+(** Selecting the low part of a number can be done by a modulo *)
+
+Lemma mod_pow2_bits_high : forall a n m, 0<=n<=m ->
+ (a mod 2^n).[m] = false.
+Proof.
+ intros a n m (Hn,H).
+ destruct (mod_pos_bound a (2^n)) as [LE LT]. order_pos.
+ le_elim LE.
+ apply bits_above_log2; try order.
+ apply lt_le_trans with n; trivial.
+ apply log2_lt_pow2; trivial.
+ now rewrite <- LE, bits_0.
+Qed.
+
+Lemma mod_pow2_bits_low : forall a n m, m<n ->
+ (a mod 2^n).[m] = a.[m].
+Proof.
+ intros a n m H.
+ destruct (le_gt_cases 0 m) as [Hm|Hm]; [|now rewrite !testbit_neg_r].
+ rewrite testbit_eqb; trivial.
+ rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'.
+ rewrite <- div_add by order_nz.
+ rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r, succ_pred.
+ rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add; trivial.
+ rewrite add_comm, <- div_mod by order_nz.
+ symmetry. apply testbit_eqb; trivial.
+ apply le_0_sub; order.
+ now apply lt_le_pred, lt_0_sub.
+Qed.
+
+(** We now prove that having the same bits implies equality.
+    For that we use a notion of equality over functional
+    streams of bits. *)
+
+Definition eqf (f g:t -> bool) := forall n:t, f n = g n.
+
+Instance eqf_equiv : Equivalence eqf.
+Proof.
+ split; congruence.
+Qed.
+
+Local Infix "===" := eqf (at level 70, no associativity).
+
+Instance testbit_eqf : Proper (eq==>eqf) testbit.
+Proof.
+ intros a a' Ha n. now rewrite Ha.
+Qed.
+
+(** Only zero corresponds to the always-false stream. *)
+
+Lemma bits_inj_0 :
+ forall a, (forall n, a.[n] = false) -> a == 0.
+Proof.
+ intros a H. destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]; trivial.
+ apply (bits_above_log2_neg a (S (log2 (P (-a))))) in Ha.
+ now rewrite H in Ha.
+ apply lt_succ_diag_r.
+ apply bit_log2 in Ha. now rewrite H in Ha.
+Qed.
+
+(** If two numbers produce the same stream of bits, they are equal. *)
+
+Lemma bits_inj : forall a b, testbit a === testbit b -> a == b.
+Proof.
+ assert (AUX : forall n, 0<=n -> forall a b,
+                0<=a<2^n -> testbit a === testbit b -> a == b).
+  intros n Hn. apply le_ind with (4:=Hn).
+  solve_proper.
+  intros a b Ha H. rewrite pow_0_r, one_succ, lt_succ_r in Ha.
+  assert (Ha' : a == 0) by (destruct Ha; order).
+  rewrite Ha' in *.
+  symmetry. apply bits_inj_0.
+   intros m. now rewrite <- H, bits_0.
+  clear n Hn. intros n Hn IH a b (Ha,Ha') H.
+  rewrite (div_mod a 2), (div_mod b 2) by order'.
+  f_equiv; [ | now rewrite <- 2 bit0_mod, H].
+  f_equiv.
+  apply IH.
+  split. apply div_pos; order'.
+  apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r.
+   intros m.
+   destruct (le_gt_cases 0 m).
+   rewrite 2 div2_bits by trivial. apply H.
+   now rewrite 2 testbit_neg_r.
+ intros a b H.
+ destruct (le_gt_cases 0 a) as [Ha|Ha].
+ apply (AUX a); trivial. split; trivial.
+ apply pow_gt_lin_r; order'.
+ apply succ_inj, opp_inj.
+ assert (0 <= - S a).
+  apply opp_le_mono. now rewrite opp_involutive, opp_0, le_succ_l.
+ apply (AUX (-(S a))); trivial. split; trivial.
+ apply pow_gt_lin_r; order'.
+  intros m. destruct (le_gt_cases 0 m).
+  now rewrite 2 bits_opp, 2 pred_succ, H.
+  now rewrite 2 testbit_neg_r.
+Qed.
+
+Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b.
+Proof.
+ split. apply bits_inj. intros EQ; now rewrite EQ.
+Qed.
+
+(** In fact, checking the bits at positive indexes is enough. *)
+
+Lemma bits_inj' : forall a b,
+ (forall n, 0<=n -> a.[n] = b.[n]) -> a == b.
+Proof.
+ intros a b H. apply bits_inj.
+ intros n. destruct (le_gt_cases 0 n).
+ now apply H.
+ now rewrite 2 testbit_neg_r.
+Qed.
+
+Lemma bits_inj_iff' : forall a b, (forall n, 0<=n -> a.[n] = b.[n]) <-> a == b.
+Proof.
+ split. apply bits_inj'. intros EQ n Hn; now rewrite EQ.
+Qed.
+
+Ltac bitwise := apply bits_inj'; intros ?m ?Hm; autorewrite with bitwise.
+
+Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise.
+
+(** The streams of bits that correspond to a numbers are
+  exactly the ones which are stationary after some point. *)
+
+Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f ->
+ ((exists n, forall m, 0<=m -> f m = n.[m]) <->
+  (exists k, forall m, k<=m -> f m = f k)).
+Proof.
+ intros f Hf. split.
+ intros (a,H).
+  destruct (le_gt_cases 0 a).
+  exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm.
+  rewrite 2 H, 2 bits_above_log2; trivial using lt_succ_diag_r.
+  order_pos. apply le_trans with (log2 a); order_pos.
+  exists (S (log2 (P (-a)))). intros m Hm. apply le_succ_l in Hm.
+  rewrite 2 H, 2 bits_above_log2_neg; trivial using lt_succ_diag_r.
+  order_pos. apply le_trans with (log2 (P (-a))); order_pos.
+ intros (k,Hk).
+  destruct (lt_ge_cases k 0) as [LT|LE].
+  case_eq (f 0); intros H0.
+  exists (-1). intros m Hm. rewrite bits_m1, Hk by order.
+  symmetry; rewrite <- H0. apply Hk; order.
+  exists 0. intros m Hm. rewrite bits_0, Hk by order.
+  symmetry; rewrite <- H0. apply Hk; order.
+  revert f Hf Hk. apply le_ind with (4:=LE).
+  (* compat : solve_proper fails here *)
+  apply proper_sym_impl_iff. exact eq_sym.
+  clear k LE. intros k k' Hk IH f Hf H. apply IH; trivial.
+  now setoid_rewrite Hk.
+  (* /compat *)
+  intros f Hf H0. destruct (f 0).
+  exists (-1). intros m Hm. now rewrite bits_m1, H0.
+  exists 0. intros m Hm. now rewrite bits_0, H0.
+  clear k LE. intros k LE IH f Hf Hk.
+  destruct (IH (fun m => f (S m))) as (n, Hn).
+  solve_proper.
+  intros m Hm. apply Hk. now rewrite <- succ_le_mono.
+  exists (f 0 + 2*n). intros m Hm.
+  le_elim Hm.
+  rewrite <- (succ_pred m), Hn, <- div2_bits.
+  rewrite mul_comm, div_add, b2z_div2, add_0_l; trivial. order'.
+  now rewrite <- lt_succ_r, succ_pred.
+  now rewrite <- lt_succ_r, succ_pred.
+  rewrite <- Hm.
+  symmetry. apply add_b2z_double_bit0.
+Qed.
+
+(** * Properties of shifts *)
+
+(** First, a unified specification for [shiftl] : the [shiftl_spec]
+   below (combined with [testbit_neg_r]) is equivalent to
+   [shiftl_spec_low] and [shiftl_spec_high]. *)
+
+Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n].
+Proof.
+ intros.
+ destruct (le_gt_cases n m).
+ now apply shiftl_spec_high.
+ rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0.
+Qed.
+
+(** A shiftl by a negative number is a shiftr, and vice-versa *)
+
+Lemma shiftr_opp_r : forall a n, a >> (-n) == a << n.
+Proof.
+ intros. bitwise. now rewrite shiftr_spec, shiftl_spec, add_opp_r.
+Qed.
+
+Lemma shiftl_opp_r : forall a n, a << (-n) == a >> n.
+Proof.
+ intros. bitwise. now rewrite shiftr_spec, shiftl_spec, sub_opp_r.
+Qed.
+
+(** Shifts correspond to multiplication or division by a power of two *)
+
+Lemma shiftr_div_pow2 : forall a n, 0<=n -> a >> n == a / 2^n.
+Proof.
+ intros. bitwise. now rewrite shiftr_spec, div_pow2_bits.
+Qed.
+
+Lemma shiftr_mul_pow2 : forall a n, n<=0 -> a >> n == a * 2^(-n).
+Proof.
+ intros. bitwise. rewrite shiftr_spec, mul_pow2_bits; trivial.
+ now rewrite sub_opp_r.
+ now apply opp_nonneg_nonpos.
+Qed.
+
+Lemma shiftl_mul_pow2 : forall a n, 0<=n -> a << n == a * 2^n.
+Proof.
+ intros. bitwise. now rewrite shiftl_spec, mul_pow2_bits.
+Qed.
+
+Lemma shiftl_div_pow2 : forall a n, n<=0 -> a << n == a / 2^(-n).
+Proof.
+ intros. bitwise. rewrite shiftl_spec, div_pow2_bits; trivial.
+ now rewrite add_opp_r.
+ now apply opp_nonneg_nonpos.
+Qed.
+
+(** Shifts are morphisms *)
+
+Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr.
+Proof.
+ intros a a' Ha n n' Hn.
+ destruct (le_ge_cases n 0) as [H|H]; assert (H':=H); rewrite Hn in H'.
+ now rewrite 2 shiftr_mul_pow2, Ha, Hn.
+ now rewrite 2 shiftr_div_pow2, Ha, Hn.
+Qed.
+
+Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl.
+Proof.
+ intros a a' Ha n n' Hn. now rewrite <- 2 shiftr_opp_r, Ha, Hn.
+Qed.
+
+(** We could also have specified shiftl with an addition on the left. *)
+
+Lemma shiftl_spec_alt : forall a n m, 0<=n -> (a << n).[m+n] = a.[m].
+Proof.
+ intros. now rewrite shiftl_mul_pow2, mul_pow2_bits, add_simpl_r.
+Qed.
+
+(** Chaining several shifts. The only case for which
+    there isn't any simple expression is a true shiftr
+    followed by a true shiftl.
+*)
+
+Lemma shiftl_shiftl : forall a n m, 0<=n ->
+ (a << n) << m == a << (n+m).
+Proof.
+ intros a n p Hn. bitwise.
+ rewrite 2 (shiftl_spec _ _ m) by trivial.
+ rewrite add_comm, sub_add_distr.
+ destruct (le_gt_cases 0 (m-p)) as [H|H].
+ now rewrite shiftl_spec.
+ rewrite 2 testbit_neg_r; trivial.
+ apply lt_sub_0. now apply lt_le_trans with 0.
+Qed.
+
+Lemma shiftr_shiftl_l : forall a n m, 0<=n ->
+ (a << n) >> m == a << (n-m).
+Proof.
+ intros. now rewrite <- shiftl_opp_r, shiftl_shiftl, add_opp_r.
+Qed.
+
+Lemma shiftr_shiftl_r : forall a n m, 0<=n ->
+ (a << n) >> m == a >> (m-n).
+Proof.
+ intros. now rewrite <- 2 shiftl_opp_r, shiftl_shiftl, opp_sub_distr, add_comm.
+Qed.
+
+Lemma shiftr_shiftr : forall a n m, 0<=m ->
+ (a >> n) >> m == a >> (n+m).
+Proof.
+ intros a n p Hn. bitwise.
+ rewrite 3 shiftr_spec; trivial.
+ now rewrite (add_comm n p), add_assoc.
+ now apply add_nonneg_nonneg.
+Qed.
+
+(** shifts and constants *)
+
+Lemma shiftl_1_l : forall n, 1 << n == 2^n.
+Proof.
+ intros n. destruct (le_gt_cases 0 n).
+ now rewrite shiftl_mul_pow2, mul_1_l.
+ rewrite shiftl_div_pow2, div_1_l, pow_neg_r; try order.
+ apply pow_gt_1. order'. now apply opp_pos_neg.
+Qed.
+
+Lemma shiftl_0_r : forall a, a << 0 == a.
+Proof.
+ intros. rewrite shiftl_mul_pow2 by order. now nzsimpl.
+Qed.
+
+Lemma shiftr_0_r : forall a, a >> 0 == a.
+Proof.
+ intros. now rewrite <- shiftl_opp_r, opp_0, shiftl_0_r.
+Qed.
+
+Lemma shiftl_0_l : forall n, 0 << n == 0.
+Proof.
+ intros.
+ destruct (le_ge_cases 0 n).
+ rewrite shiftl_mul_pow2 by trivial. now nzsimpl.
+ rewrite shiftl_div_pow2 by trivial.
+ rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz.
+Qed.
+
+Lemma shiftr_0_l : forall n, 0 >> n == 0.
+Proof.
+ intros. now rewrite <- shiftl_opp_r, shiftl_0_l.
+Qed.
+
+Lemma shiftl_eq_0_iff : forall a n, 0<=n -> (a << n == 0 <-> a == 0).
+Proof.
+ intros a n Hn.
+ rewrite shiftl_mul_pow2 by trivial. rewrite eq_mul_0. split.
+ intros [H | H]; trivial. contradict H; order_nz.
+ intros H. now left.
+Qed.
+
+Lemma shiftr_eq_0_iff : forall a n,
+ a >> n == 0 <-> a==0 \/ (0<a /\ log2 a < n).
+Proof.
+ intros a n.
+ destruct (le_gt_cases 0 n) as [Hn|Hn].
+ rewrite shiftr_div_pow2, div_small_iff by order_nz.
+ destruct (lt_trichotomy a 0) as [LT|[EQ|LT]].
+ split.
+ intros [(H,_)|(H,H')]. order. generalize (pow_nonneg 2 n le_0_2); order.
+ intros [H|(H,H')]; order.
+ rewrite EQ. split. now left. intros _; left. split; order_pos.
+ split. intros [(H,H')|(H,H')]; right. split; trivial.
+  apply log2_lt_pow2; trivial.
+  generalize (pow_nonneg 2 n le_0_2); order.
+ intros [H|(H,H')]. order. left.
+ split. order. now apply log2_lt_pow2.
+ rewrite shiftr_mul_pow2 by order. rewrite eq_mul_0.
+ split; intros [H|H].
+ now left.
+ elim (pow_nonzero 2 (-n)); try apply opp_nonneg_nonpos; order'.
+ now left.
+ destruct H. generalize (log2_nonneg a); order.
+Qed.
+
+Lemma shiftr_eq_0 : forall a n, 0<=a -> log2 a < n -> a >> n == 0.
+Proof.
+ intros a n Ha H. apply shiftr_eq_0_iff.
+ le_elim Ha. right. now split. now left.
+Qed.
+
+(** Properties of [div2]. *)
+
+Lemma div2_div : forall a, div2 a == a/2.
+Proof.
+ intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. order'.
+Qed.
+
+Instance div2_wd : Proper (eq==>eq) div2.
+Proof.
+ intros a a' Ha. now rewrite 2 div2_div, Ha.
+Qed.
+
+Lemma div2_odd : forall a, a == 2*(div2 a) + odd a.
+Proof.
+ intros a. rewrite div2_div, <- bit0_odd, bit0_mod.
+ apply div_mod. order'.
+Qed.
+
+(** Properties of [lxor] and others, directly deduced
+    from properties of [xorb] and others. *)
+
+Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance land_wd : Proper (eq ==> eq ==> eq) land.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance lor_wd : Proper (eq ==> eq ==> eq) lor.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'.
+Proof.
+ intros a a' H. bitwise. apply xorb_eq.
+ now rewrite <- lxor_spec, H, bits_0.
+Qed.
+
+Lemma lxor_nilpotent : forall a, lxor a a == 0.
+Proof.
+ intros. bitwise. apply xorb_nilpotent.
+Qed.
+
+Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'.
+Proof.
+ split. apply lxor_eq. intros EQ; rewrite EQ; apply lxor_nilpotent.
+Qed.
+
+Lemma lxor_0_l : forall a, lxor 0 a == a.
+Proof.
+ intros. bitwise. apply xorb_false_l.
+Qed.
+
+Lemma lxor_0_r : forall a, lxor a 0 == a.
+Proof.
+ intros. bitwise. apply xorb_false_r.
+Qed.
+
+Lemma lxor_comm : forall a b, lxor a b == lxor b a.
+Proof.
+ intros. bitwise. apply xorb_comm.
+Qed.
+
+Lemma lxor_assoc :
+ forall a b c, lxor (lxor a b) c == lxor a (lxor b c).
+Proof.
+ intros. bitwise. apply xorb_assoc.
+Qed.
+
+Lemma lor_0_l : forall a, lor 0 a == a.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma lor_0_r : forall a, lor a 0 == a.
+Proof.
+ intros. bitwise. apply orb_false_r.
+Qed.
+
+Lemma lor_comm : forall a b, lor a b == lor b a.
+Proof.
+ intros. bitwise. apply orb_comm.
+Qed.
+
+Lemma lor_assoc :
+ forall a b c, lor a (lor b c) == lor (lor a b) c.
+Proof.
+ intros. bitwise. apply orb_assoc.
+Qed.
+
+Lemma lor_diag : forall a, lor a a == a.
+Proof.
+ intros. bitwise. apply orb_diag.
+Qed.
+
+Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0.
+Proof.
+ intros a b H. bitwise.
+ apply (orb_false_iff a.[m] b.[m]).
+ now rewrite <- lor_spec, H, bits_0.
+Qed.
+
+Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0.
+Proof.
+ intros a b. split.
+ split. now apply lor_eq_0_l in H.
+ rewrite lor_comm in H. now apply lor_eq_0_l in H.
+ intros (EQ,EQ'). now rewrite EQ, lor_0_l.
+Qed.
+
+Lemma land_0_l : forall a, land 0 a == 0.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma land_0_r : forall a, land a 0 == 0.
+Proof.
+ intros. bitwise. apply andb_false_r.
+Qed.
+
+Lemma land_comm : forall a b, land a b == land b a.
+Proof.
+ intros. bitwise. apply andb_comm.
+Qed.
+
+Lemma land_assoc :
+ forall a b c, land a (land b c) == land (land a b) c.
+Proof.
+ intros. bitwise. apply andb_assoc.
+Qed.
+
+Lemma land_diag : forall a, land a a == a.
+Proof.
+ intros. bitwise. apply andb_diag.
+Qed.
+
+Lemma ldiff_0_l : forall a, ldiff 0 a == 0.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma ldiff_0_r : forall a, ldiff a 0 == a.
+Proof.
+ intros. bitwise. now rewrite andb_true_r.
+Qed.
+
+Lemma ldiff_diag : forall a, ldiff a a == 0.
+Proof.
+ intros. bitwise. apply andb_negb_r.
+Qed.
+
+Lemma lor_land_distr_l : forall a b c,
+ lor (land a b) c == land (lor a c) (lor b c).
+Proof.
+ intros. bitwise. apply orb_andb_distrib_l.
+Qed.
+
+Lemma lor_land_distr_r : forall a b c,
+ lor a (land b c) == land (lor a b) (lor a c).
+Proof.
+ intros. bitwise. apply orb_andb_distrib_r.
+Qed.
+
+Lemma land_lor_distr_l : forall a b c,
+ land (lor a b) c == lor (land a c) (land b c).
+Proof.
+ intros. bitwise. apply andb_orb_distrib_l.
+Qed.
+
+Lemma land_lor_distr_r : forall a b c,
+ land a (lor b c) == lor (land a b) (land a c).
+Proof.
+ intros. bitwise. apply andb_orb_distrib_r.
+Qed.
+
+Lemma ldiff_ldiff_l : forall a b c,
+ ldiff (ldiff a b) c == ldiff a (lor b c).
+Proof.
+ intros. bitwise. now rewrite negb_orb, andb_assoc.
+Qed.
+
+Lemma lor_ldiff_and : forall a b,
+ lor (ldiff a b) (land a b) == a.
+Proof.
+ intros. bitwise.
+ now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r.
+Qed.
+
+Lemma land_ldiff : forall a b,
+ land (ldiff a b) b == 0.
+Proof.
+ intros. bitwise.
+ now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r.
+Qed.
+
+(** Properties of [setbit] and [clearbit] *)
+
+Definition setbit a n := lor a (1 << n).
+Definition clearbit a n := ldiff a (1 << n).
+
+Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n).
+Proof.
+ intros. unfold setbit. now rewrite shiftl_1_l.
+Qed.
+
+Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n).
+Proof.
+ intros. unfold clearbit. now rewrite shiftl_1_l.
+Qed.
+
+Instance setbit_wd : Proper (eq==>eq==>eq) setbit.
+Proof. unfold setbit. solve_proper. Qed.
+
+Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit.
+Proof. unfold clearbit. solve_proper. Qed.
+
+Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true.
+Proof.
+ intros. rewrite <- (mul_1_l (2^n)).
+ now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1.
+Qed.
+
+Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false.
+Proof.
+ intros.
+ destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0].
+ destruct (le_gt_cases n m).
+ rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial.
+ rewrite <- (succ_pred (m-n)), <- div2_bits.
+ now rewrite div_small, bits_0 by (split; order').
+ rewrite <- lt_succ_r, succ_pred, lt_0_sub. order.
+ rewrite <- (mul_1_l (2^n)), mul_pow2_bits_low; trivial.
+Qed.
+
+Lemma pow2_bits_eqb : forall n m, 0<=n -> (2^n).[m] = eqb n m.
+Proof.
+ intros n m Hn. apply eq_true_iff_eq. rewrite eqb_eq. split.
+ destruct (eq_decidable n m) as [H|H]. trivial.
+ now rewrite (pow2_bits_false _ _ H).
+ intros EQ. rewrite EQ. apply pow2_bits_true; order.
+Qed.
+
+Lemma setbit_eqb : forall a n m, 0<=n ->
+ (setbit a n).[m] = eqb n m || a.[m].
+Proof.
+ intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm.
+Qed.
+
+Lemma setbit_iff : forall a n m, 0<=n ->
+ ((setbit a n).[m] = true <-> n==m \/ a.[m] = true).
+Proof.
+ intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq.
+Qed.
+
+Lemma setbit_eq : forall a n, 0<=n -> (setbit a n).[n] = true.
+Proof.
+ intros. apply setbit_iff; trivial. now left.
+Qed.
+
+Lemma setbit_neq : forall a n m, 0<=n -> n~=m ->
+ (setbit a n).[m] = a.[m].
+Proof.
+ intros a n m Hn H. rewrite setbit_eqb; trivial.
+ rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H.
+Qed.
+
+Lemma clearbit_eqb : forall a n m,
+ (clearbit a n).[m] = a.[m] && negb (eqb n m).
+Proof.
+ intros.
+ destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r].
+ rewrite clearbit_spec', ldiff_spec. f_equal. f_equal.
+ destruct (le_gt_cases 0 n) as [Hn|Hn].
+ now apply pow2_bits_eqb.
+ symmetry. rewrite pow_neg_r, bits_0, <- not_true_iff_false, eqb_eq; order.
+Qed.
+
+Lemma clearbit_iff : forall a n m,
+ (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m.
+Proof.
+ intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq.
+ now rewrite negb_true_iff, not_true_iff_false.
+Qed.
+
+Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false.
+Proof.
+ intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)).
+ apply andb_false_r.
+Qed.
+
+Lemma clearbit_neq : forall a n m, n~=m ->
+ (clearbit a n).[m] = a.[m].
+Proof.
+ intros a n m H. rewrite clearbit_eqb.
+ rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H.
+ apply andb_true_r.
+Qed.
+
+(** Shifts of bitwise operations *)
+
+Lemma shiftl_lxor : forall a b n,
+ (lxor a b) << n == lxor (a << n) (b << n).
+Proof.
+ intros. bitwise. now rewrite !shiftl_spec, lxor_spec.
+Qed.
+
+Lemma shiftr_lxor : forall a b n,
+ (lxor a b) >> n == lxor (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec, lxor_spec.
+Qed.
+
+Lemma shiftl_land : forall a b n,
+ (land a b) << n == land (a << n) (b << n).
+Proof.
+ intros. bitwise. now rewrite !shiftl_spec, land_spec.
+Qed.
+
+Lemma shiftr_land : forall a b n,
+ (land a b) >> n == land (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec, land_spec.
+Qed.
+
+Lemma shiftl_lor : forall a b n,
+ (lor a b) << n == lor (a << n) (b << n).
+Proof.
+ intros. bitwise. now rewrite !shiftl_spec, lor_spec.
+Qed.
+
+Lemma shiftr_lor : forall a b n,
+ (lor a b) >> n == lor (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec, lor_spec.
+Qed.
+
+Lemma shiftl_ldiff : forall a b n,
+ (ldiff a b) << n == ldiff (a << n) (b << n).
+Proof.
+ intros. bitwise. now rewrite !shiftl_spec, ldiff_spec.
+Qed.
+
+Lemma shiftr_ldiff : forall a b n,
+ (ldiff a b) >> n == ldiff (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec, ldiff_spec.
+Qed.
+
+(** For integers, we do have a binary complement function *)
+
+Definition lnot a := P (-a).
+
+Instance lnot_wd : Proper (eq==>eq) lnot.
+Proof. unfold lnot. solve_proper. Qed.
+
+Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n].
+Proof.
+ intros. unfold lnot. rewrite <- (opp_involutive a) at 2.
+ rewrite bits_opp, negb_involutive; trivial.
+Qed.
+
+Lemma lnot_involutive : forall a, lnot (lnot a) == a.
+Proof.
+ intros a. bitwise. now rewrite 2 lnot_spec, negb_involutive.
+Qed.
+
+Lemma lnot_0 : lnot 0 == -1.
+Proof.
+ unfold lnot. now rewrite opp_0, <- sub_1_r, sub_0_l.
+Qed.
+
+Lemma lnot_m1 : lnot (-1) == 0.
+Proof.
+ unfold lnot. now rewrite opp_involutive, one_succ, pred_succ.
+Qed.
+
+(** Complement and other operations *)
+
+Lemma lor_m1_r : forall a, lor a (-1) == -1.
+Proof.
+ intros. bitwise. now rewrite bits_m1, orb_true_r.
+Qed.
+
+Lemma lor_m1_l : forall a, lor (-1) a == -1.
+Proof.
+ intros. now rewrite lor_comm, lor_m1_r.
+Qed.
+
+Lemma land_m1_r : forall a, land a (-1) == a.
+Proof.
+ intros. bitwise. now rewrite bits_m1, andb_true_r.
+Qed.
+
+Lemma land_m1_l : forall a, land (-1) a == a.
+Proof.
+ intros. now rewrite land_comm, land_m1_r.
+Qed.
+
+Lemma ldiff_m1_r : forall a, ldiff a (-1) == 0.
+Proof.
+ intros. bitwise. now rewrite bits_m1, andb_false_r.
+Qed.
+
+Lemma ldiff_m1_l : forall a, ldiff (-1) a == lnot a.
+Proof.
+ intros. bitwise. now rewrite lnot_spec, bits_m1.
+Qed.
+
+Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1.
+Proof.
+ intros a. bitwise. rewrite lnot_spec, bits_m1; trivial.
+ now destruct a.[m].
+Qed.
+
+Lemma add_lnot_diag : forall a, a + lnot a == -1.
+Proof.
+ intros a. unfold lnot.
+ now rewrite add_pred_r, add_opp_r, sub_diag, one_succ, opp_succ, opp_0.
+Qed.
+
+Lemma ldiff_land : forall a b, ldiff a b == land a (lnot b).
+Proof.
+ intros. bitwise. now rewrite lnot_spec.
+Qed.
+
+Lemma land_lnot_diag : forall a, land a (lnot a) == 0.
+Proof.
+ intros. now rewrite <- ldiff_land, ldiff_diag.
+Qed.
+
+Lemma lnot_lor : forall a b, lnot (lor a b) == land (lnot a) (lnot b).
+Proof.
+ intros a b. bitwise. now rewrite !lnot_spec, lor_spec, negb_orb.
+Qed.
+
+Lemma lnot_land : forall a b, lnot (land a b) == lor (lnot a) (lnot b).
+Proof.
+ intros a b. bitwise. now rewrite !lnot_spec, land_spec, negb_andb.
+Qed.
+
+Lemma lnot_ldiff : forall a b, lnot (ldiff a b) == lor (lnot a) b.
+Proof.
+ intros a b. bitwise.
+ now rewrite !lnot_spec, ldiff_spec, negb_andb, negb_involutive.
+Qed.
+
+Lemma lxor_lnot_lnot : forall a b, lxor (lnot a) (lnot b) == lxor a b.
+Proof.
+ intros a b. bitwise. now rewrite !lnot_spec, xorb_negb_negb.
+Qed.
+
+Lemma lnot_lxor_l : forall a b, lnot (lxor a b) == lxor (lnot a) b.
+Proof.
+ intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_l.
+Qed.
+
+Lemma lnot_lxor_r : forall a b, lnot (lxor a b) == lxor a (lnot b).
+Proof.
+ intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_r.
+Qed.
+
+Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a.
+Proof.
+ intros. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot.
+Qed.
+
+Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a.
+Proof.
+ intros. now rewrite lxor_comm, lxor_m1_r.
+Qed.
+
+Lemma lxor_lor : forall a b, land a b == 0 ->
+ lxor a b == lor a b.
+Proof.
+ intros a b H. bitwise.
+ assert (a.[m] && b.[m] = false)
+   by now rewrite <- land_spec, H, bits_0.
+ now destruct a.[m], b.[m].
+Qed.
+
+Lemma lnot_shiftr : forall a n, 0<=n -> lnot (a >> n) == (lnot a) >> n.
+Proof.
+ intros a n Hn. bitwise.
+ now rewrite lnot_spec, 2 shiftr_spec, lnot_spec by order_pos.
+Qed.
+
+(** [(ones n)] is [2^n-1], the number with [n] digits 1 *)
+
+Definition ones n := P (1<<n).
+
+Instance ones_wd : Proper (eq==>eq) ones.
+Proof. unfold ones. solve_proper. Qed.
+
+Lemma ones_equiv : forall n, ones n == P (2^n).
+Proof.
+ intros. unfold ones.
+ destruct (le_gt_cases 0 n).
+ now rewrite shiftl_mul_pow2, mul_1_l.
+ f_equiv. rewrite pow_neg_r; trivial.
+ rewrite <- shiftr_opp_r. apply shiftr_eq_0_iff. right; split.
+ order'. rewrite log2_1. now apply opp_pos_neg.
+Qed.
+
+Lemma ones_add : forall n m, 0<=n -> 0<=m ->
+ ones (m+n) == 2^m * ones n + ones m.
+Proof.
+ intros n m Hn Hm. rewrite !ones_equiv.
+ rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r by trivial.
+ rewrite add_sub_assoc, sub_add. reflexivity.
+Qed.
+
+Lemma ones_div_pow2 : forall n m, 0<=m<=n -> ones n / 2^m == ones (n-m).
+Proof.
+ intros n m (Hm,H). symmetry. apply div_unique with (ones m).
+ left. rewrite ones_equiv. split.
+ rewrite <- lt_succ_r, succ_pred. order_pos.
+ now rewrite <- le_succ_l, succ_pred.
+ rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m).
+ apply ones_add; trivial. now apply le_0_sub.
+Qed.
+
+Lemma ones_mod_pow2 : forall n m, 0<=m<=n -> (ones n) mod (2^m) == ones m.
+Proof.
+ intros n m (Hm,H). symmetry. apply mod_unique with (ones (n-m)).
+ left. rewrite ones_equiv. split.
+ rewrite <- lt_succ_r, succ_pred. order_pos.
+ now rewrite <- le_succ_l, succ_pred.
+ rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m).
+ apply ones_add; trivial. now apply le_0_sub.
+Qed.
+
+Lemma ones_spec_low : forall n m, 0<=m<n -> (ones n).[m] = true.
+Proof.
+ intros n m (Hm,H). apply testbit_true; trivial.
+ rewrite ones_div_pow2 by (split; order).
+ rewrite <- (pow_1_r 2). rewrite ones_mod_pow2.
+ rewrite ones_equiv. now nzsimpl'.
+ split. order'. apply le_add_le_sub_r. nzsimpl. now apply le_succ_l.
+Qed.
+
+Lemma ones_spec_high : forall n m, 0<=n<=m -> (ones n).[m] = false.
+Proof.
+ intros n m (Hn,H). le_elim Hn.
+ apply bits_above_log2; rewrite ones_equiv.
+ rewrite <-lt_succ_r, succ_pred; order_pos.
+ rewrite log2_pred_pow2; trivial. now rewrite <-le_succ_l, succ_pred.
+ rewrite ones_equiv. now rewrite <- Hn, pow_0_r, one_succ, pred_succ, bits_0.
+Qed.
+
+Lemma ones_spec_iff : forall n m, 0<=n ->
+ ((ones n).[m] = true <-> 0<=m<n).
+Proof.
+ intros n m Hn. split. intros H.
+ destruct (lt_ge_cases m 0) as [Hm|Hm].
+  now rewrite testbit_neg_r in H.
+  split; trivial. apply lt_nge. intro H'. rewrite ones_spec_high in H.
+  discriminate. now split.
+ apply ones_spec_low.
+Qed.
+
+Lemma lor_ones_low : forall a n, 0<=a -> log2 a < n ->
+ lor a (ones n) == ones n.
+Proof.
+ intros a n Ha H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, bits_above_log2; try split; trivial.
+ now apply lt_le_trans with n.
+ apply le_trans with (log2 a); order_pos.
+ rewrite ones_spec_low, orb_true_r; try split; trivial.
+Qed.
+
+Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n.
+Proof.
+ intros a n Hn. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r;
+  try split; trivial.
+ rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r;
+  try split; trivial.
+Qed.
+
+Lemma land_ones_low : forall a n, 0<=a -> log2 a < n ->
+ land a (ones n) == a.
+Proof.
+ intros a n Ha H.
+ assert (Hn : 0<=n) by (generalize (log2_nonneg a); order).
+ rewrite land_ones; trivial. apply mod_small.
+ split; trivial.
+ apply log2_lt_cancel. now rewrite log2_pow2.
+Qed.
+
+Lemma ldiff_ones_r : forall a n, 0<=n ->
+ ldiff a (ones n) == (a >> n) << n.
+Proof.
+ intros a n Hn. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial.
+ rewrite sub_add; trivial. apply andb_true_r.
+ now apply le_0_sub.
+ now split.
+ rewrite ones_spec_low, shiftl_spec_low, andb_false_r;
+  try split; trivial.
+Qed.
+
+Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n ->
+ ldiff a (ones n) == 0.
+Proof.
+ intros a n Ha H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ split; trivial. now apply le_trans with (log2 a); order_pos.
+ rewrite ones_spec_low, andb_false_r; try split; trivial.
+Qed.
+
+Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n ->
+ ldiff (ones n) a == lxor a (ones n).
+Proof.
+ intros a n Ha H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ split; trivial. now apply le_trans with (log2 a); order_pos.
+ rewrite ones_spec_low, xorb_true_r; try split; trivial.
+Qed.
+
+(** Bitwise operations and sign *)
+
+Lemma shiftl_nonneg : forall a n, 0 <= (a << n) <-> 0 <= a.
+Proof.
+ intros a n.
+ destruct (le_ge_cases 0 n) as [Hn|Hn].
+ (* 0<=n *)
+ rewrite 2 bits_iff_nonneg_ex. split; intros (k,Hk).
+ exists (k-n). intros m Hm.
+ destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r].
+ rewrite <- (add_simpl_r m n), <- (shiftl_spec a n) by order_pos.
+ apply Hk. now apply lt_sub_lt_add_r.
+ exists (k+n). intros m Hm.
+ destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r].
+ rewrite shiftl_spec by trivial. apply Hk. now apply lt_add_lt_sub_r.
+ (* n<=0*)
+ rewrite <- shiftr_opp_r, 2 bits_iff_nonneg_ex. split; intros (k,Hk).
+ destruct (le_gt_cases 0 k).
+ exists (k-n). intros m Hm. apply lt_sub_lt_add_r in Hm.
+ rewrite <- (add_simpl_r m n), <- add_opp_r, <- (shiftr_spec a (-n)).
+ now apply Hk. order.
+ assert (EQ : a >> (-n) == 0).
+  apply bits_inj'. intros m Hm. rewrite bits_0. apply Hk; order.
+ apply shiftr_eq_0_iff in EQ.
+ rewrite <- bits_iff_nonneg_ex. destruct EQ as [EQ|[LT _]]; order.
+ exists (k+n). intros m Hm.
+ destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r].
+ rewrite shiftr_spec by trivial. apply Hk.
+ rewrite add_opp_r. now apply lt_add_lt_sub_r.
+Qed.
+
+Lemma shiftl_neg : forall a n, (a << n) < 0 <-> a < 0.
+Proof.
+ intros a n. now rewrite 2 lt_nge, shiftl_nonneg.
+Qed.
+
+Lemma shiftr_nonneg : forall a n, 0 <= (a >> n) <-> 0 <= a.
+Proof.
+ intros. rewrite <- shiftl_opp_r. apply shiftl_nonneg.
+Qed.
+
+Lemma shiftr_neg : forall a n, (a >> n) < 0 <-> a < 0.
+Proof.
+ intros a n. now rewrite 2 lt_nge, shiftr_nonneg.
+Qed.
+
+Lemma div2_nonneg : forall a, 0 <= div2 a <-> 0 <= a.
+Proof.
+ intros. rewrite div2_spec. apply shiftr_nonneg.
+Qed.
+
+Lemma div2_neg : forall a, div2 a < 0 <-> a < 0.
+Proof.
+ intros a. now rewrite 2 lt_nge, div2_nonneg.
+Qed.
+
+Lemma lor_nonneg : forall a b, 0 <= lor a b <-> 0<=a /\ 0<=b.
+Proof.
+ intros a b.
+ rewrite 3 bits_iff_nonneg_ex. split. intros (k,Hk).
+ split; exists k; intros m Hm; apply (orb_false_elim a.[m] b.[m]);
+  rewrite <- lor_spec; now apply Hk.
+ intros ((k,Hk),(k',Hk')).
+ destruct (le_ge_cases k k'); [ exists k' | exists k ];
+  intros m Hm; rewrite lor_spec, Hk, Hk'; trivial; order.
+Qed.
+
+Lemma lor_neg : forall a b, lor a b < 0 <-> a < 0 \/ b < 0.
+Proof.
+ intros a b. rewrite 3 lt_nge, lor_nonneg. split.
+  apply not_and. apply le_decidable.
+  now intros [H|H] (H',H'').
+Qed.
+
+Lemma lnot_nonneg : forall a, 0 <= lnot a <-> a < 0.
+Proof.
+ intros a; unfold lnot.
+ now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l.
+Qed.
+
+Lemma lnot_neg : forall a, lnot a < 0 <-> 0 <= a.
+Proof.
+ intros a. now rewrite le_ngt, lt_nge, lnot_nonneg.
+Qed.
+
+Lemma land_nonneg : forall a b, 0 <= land a b <-> 0<=a \/ 0<=b.
+Proof.
+ intros a b.
+ now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_nonneg,
+  lor_neg, !lnot_neg.
+Qed.
+
+Lemma land_neg : forall a b, land a b < 0 <-> a < 0 /\ b < 0.
+Proof.
+ intros a b.
+ now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_neg,
+  lor_nonneg, !lnot_nonneg.
+Qed.
+
+Lemma ldiff_nonneg : forall a b, 0 <= ldiff a b <-> 0<=a \/ b<0.
+Proof.
+ intros. now rewrite ldiff_land, land_nonneg, lnot_nonneg.
+Qed.
+
+Lemma ldiff_neg : forall a b, ldiff a b < 0 <-> a<0 /\ 0<=b.
+Proof.
+ intros. now rewrite ldiff_land, land_neg, lnot_neg.
+Qed.
+
+Lemma lxor_nonneg : forall a b, 0 <= lxor a b <-> (0<=a <-> 0<=b).
+Proof.
+ assert (H : forall a b, 0<=a -> 0<=b -> 0<=lxor a b).
+  intros a b. rewrite 3 bits_iff_nonneg_ex. intros (k,Hk) (k', Hk').
+  destruct (le_ge_cases k k'); [ exists k' | exists k];
+   intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order.
+ assert (H' : forall a b, 0<=a -> b<0 -> lxor a b<0).
+  intros a b. rewrite bits_iff_nonneg_ex, 2 bits_iff_neg_ex.
+  intros (k,Hk) (k', Hk').
+  destruct (le_ge_cases k k'); [ exists k' | exists k];
+   intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order.
+ intros a b.
+ split.
+ intros Hab. split.
+ intros Ha. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial.
+  generalize (H' _ _ Ha Hb). order.
+ intros Hb. destruct (le_gt_cases 0 a) as [Ha|Ha]; trivial.
+  generalize (H' _ _ Hb Ha). rewrite lxor_comm. order.
+ intros E.
+ destruct (le_gt_cases 0 a) as [Ha|Ha]. apply H; trivial. apply E; trivial.
+ destruct (le_gt_cases 0 b) as [Hb|Hb]. apply H; trivial. apply E; trivial.
+ rewrite <- lxor_lnot_lnot. apply H; now apply lnot_nonneg.
+Qed.
+
+(** Bitwise operations and log2 *)
+
+Lemma log2_bits_unique : forall a n,
+ a.[n] = true ->
+ (forall m, n<m -> a.[m] = false) ->
+ log2 a == n.
+Proof.
+ intros a n H H'.
+ destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]].
+ (* a < 0 *)
+ destruct (proj1 (bits_iff_neg_ex a) Ha) as (k,Hk).
+ destruct (le_gt_cases n k).
+ specialize (Hk (S k) (lt_succ_diag_r _)).
+ rewrite H' in Hk. discriminate. apply lt_succ_r; order.
+ specialize (H' (S n) (lt_succ_diag_r _)).
+ rewrite Hk in H'. discriminate. apply lt_succ_r; order.
+ (* a = 0 *)
+ now rewrite Ha, bits_0 in H.
+ (* 0 < a *)
+ apply le_antisymm; apply le_ngt; intros LT.
+ specialize (H' _ LT). now rewrite bit_log2 in H'.
+ now rewrite bits_above_log2 in H by order.
+Qed.
+
+Lemma log2_shiftr : forall a n, 0<a -> log2 (a >> n) == max 0 (log2 a - n).
+Proof.
+ intros a n Ha.
+ destruct (le_gt_cases 0 (log2 a - n));
+   [rewrite max_r | rewrite max_l]; try order.
+ apply log2_bits_unique.
+ now rewrite shiftr_spec, sub_add, bit_log2.
+ intros m Hm.
+ destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r].
+ rewrite shiftr_spec; trivial. apply bits_above_log2; try order.
+ now apply lt_sub_lt_add_r.
+ rewrite lt_sub_lt_add_r, add_0_l in H.
+ apply log2_nonpos. apply le_lteq; right.
+ apply shiftr_eq_0_iff. right. now split.
+Qed.
+
+Lemma log2_shiftl : forall a n, 0<a -> 0<=n -> log2 (a << n) == log2 a + n.
+Proof.
+ intros a n Ha Hn.
+ rewrite shiftl_mul_pow2, add_comm by trivial.
+ now apply log2_mul_pow2.
+Qed.
+
+Lemma log2_shiftl' : forall a n, 0<a -> log2 (a << n) == max 0 (log2 a + n).
+Proof.
+ intros a n Ha.
+ rewrite <- shiftr_opp_r, log2_shiftr by trivial.
+ destruct (le_gt_cases 0 (log2 a + n));
+   [rewrite 2 max_r | rewrite 2 max_l]; rewrite ?sub_opp_r; try order.
+Qed.
+
+Lemma log2_lor : forall a b, 0<=a -> 0<=b ->
+ log2 (lor a b) == max (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lor a b) == log2 b).
+  intros a b Ha H.
+  le_elim Ha; [|now rewrite <- Ha, lor_0_l].
+  apply log2_bits_unique.
+  now rewrite lor_spec, bit_log2, orb_true_r by order.
+  intros m Hm. assert (H' := log2_le_mono _ _ H).
+  now rewrite lor_spec, 2 bits_above_log2 by order.
+ (* main *)
+ intros a b Ha Hb. destruct (le_ge_cases a b) as [H|H].
+ rewrite max_r by now apply log2_le_mono.
+ now apply AUX.
+ rewrite max_l by now apply log2_le_mono.
+ rewrite lor_comm. now apply AUX.
+Qed.
+
+Lemma log2_land : forall a b, 0<=a -> 0<=b ->
+ log2 (land a b) <= min (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, 0<=a -> a<=b -> log2 (land a b) <= log2 a).
+  intros a b Ha Hb.
+  apply le_ngt. intros LT.
+  assert (H : 0 <= land a b) by (apply land_nonneg; now left).
+  le_elim H.
+  generalize (bit_log2 (land a b) H).
+  now rewrite land_spec, bits_above_log2.
+  rewrite <- H in LT. apply log2_lt_cancel in LT; order.
+ (* main *)
+ intros a b Ha Hb.
+ destruct (le_ge_cases a b) as [H|H].
+ rewrite min_l by now apply log2_le_mono. now apply AUX.
+ rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX.
+Qed.
+
+Lemma log2_lxor : forall a b, 0<=a -> 0<=b ->
+ log2 (lxor a b) <= max (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lxor a b) <= log2 b).
+  intros a b Ha Hb.
+  apply le_ngt. intros LT.
+  assert (H : 0 <= lxor a b) by (apply lxor_nonneg; split; order).
+  le_elim H.
+  generalize (bit_log2 (lxor a b) H).
+  rewrite lxor_spec, 2 bits_above_log2; try order. discriminate.
+  apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono.
+  rewrite <- H in LT. apply log2_lt_cancel in LT; order.
+ (* main *)
+ intros a b Ha Hb.
+ destruct (le_ge_cases a b) as [H|H].
+ rewrite max_r by now apply log2_le_mono. now apply AUX.
+ rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX.
+Qed.
+
+(** Bitwise operations and arithmetical operations *)
+
+Local Notation xor3 a b c := (xorb (xorb a b) c).
+Local Notation lxor3 a b c := (lxor (lxor a b) c).
+Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))).
+Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))).
+
+Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0].
+Proof.
+ intros. now rewrite !bit0_odd, odd_add.
+Qed.
+
+Lemma add3_bit0 : forall a b c,
+ (a+b+c).[0] = xor3 a.[0] b.[0] c.[0].
+Proof.
+ intros. now rewrite !add_bit0.
+Qed.
+
+Lemma add3_bits_div2 : forall (a0 b0 c0 : bool),
+ (a0 + b0 + c0)/2 == nextcarry a0 b0 c0.
+Proof.
+ assert (H : 1+1 == 2) by now nzsimpl'.
+ intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H;
+  (apply div_same; order') || (apply div_small; split; order') || idtac.
+ symmetry. apply div_unique with 1. left; split; order'. now nzsimpl'.
+Qed.
+
+Lemma add_carry_div2 : forall a b (c0:bool),
+ (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0.
+Proof.
+ intros.
+ rewrite <- add3_bits_div2.
+ rewrite (add_comm ((a/2)+_)).
+ rewrite <- div_add by order'.
+ f_equiv.
+ rewrite <- !div2_div, mul_comm, mul_add_distr_l.
+ rewrite (div2_odd a), <- bit0_odd at 1.
+ rewrite (div2_odd b), <- bit0_odd at 1.
+ rewrite add_shuffle1.
+ rewrite <-(add_assoc _ _ c0). apply add_comm.
+Qed.
+
+(** The main result concerning addition: we express the bits of the sum
+  in term of bits of [a] and [b] and of some carry stream which is also
+  recursively determined by another equation.
+*)
+
+Lemma add_carry_bits_aux : forall n, 0<=n ->
+ forall a b (c0:bool), -(2^n) <= a < 2^n -> -(2^n) <= b < 2^n ->
+  exists c,
+   a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0.
+Proof.
+ intros n Hn. apply le_ind with (4:=Hn).
+ solve_proper.
+ (* base *)
+ intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r, <- !one_succ.
+ intros (Ha1,Ha2) (Hb1,Hb2).
+ le_elim Ha1; rewrite <- ?le_succ_l, ?succ_m1 in Ha1;
+  le_elim Hb1; rewrite <- ?le_succ_l, ?succ_m1 in Hb1.
+ (* base, a = 0, b = 0 *)
+ exists c0.
+ rewrite (le_antisymm _ _ Ha2 Ha1), (le_antisymm _ _ Hb2 Hb1).
+ rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r.
+ rewrite b2z_div2, b2z_bit0; now repeat split.
+ (* base, a = 0, b = -1 *)
+ exists (-c0). rewrite <- Hb1, (le_antisymm _ _ Ha2 Ha1). repeat split.
+ rewrite add_0_l, lxor_0_l, lxor_m1_l.
+ unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r.
+ rewrite land_0_l, !lor_0_l, land_m1_r.
+ symmetry. apply div_unique with c0. left; destruct c0; simpl; split; order'.
+  now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add.
+ rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0.
+ (* base, a = -1, b = 0 *)
+ exists (-c0). rewrite <- Ha1, (le_antisymm _ _ Hb2 Hb1). repeat split.
+ rewrite add_0_r, lxor_0_r, lxor_m1_l.
+ unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r.
+ rewrite land_0_r, lor_0_r, lor_0_l, land_m1_r.
+ symmetry. apply div_unique with c0. left; destruct c0; simpl; split; order'.
+  now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add.
+ rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0.
+ (* base, a = -1, b = -1 *)
+ exists (c0 + 2*(-1)). rewrite <- Ha1, <- Hb1. repeat split.
+ rewrite lxor_m1_l, lnot_m1, lxor_0_l.
+ now rewrite two_succ, mul_succ_l, mul_1_l, add_comm, add_assoc.
+ rewrite land_m1_l, lor_m1_l.
+ apply add_b2z_double_div2.
+ apply add_b2z_double_bit0.
+ (* step *)
+ clear n Hn. intros n Hn IH a b c0 Ha Hb.
+ set (c1:=nextcarry a.[0] b.[0] c0).
+ destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH.
+ split.
+ apply div_le_lower_bound. order'. now rewrite mul_opp_r, <- pow_succ_r.
+ apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r.
+ split.
+ apply div_le_lower_bound. order'. now rewrite mul_opp_r, <- pow_succ_r.
+ apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r.
+ exists (c0 + 2*c). repeat split.
+ (* step, add *)
+ bitwise.
+ le_elim Hm.
+ rewrite <- (succ_pred m), lt_succ_r in Hm.
+ rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial.
+ f_equiv.
+ rewrite add_b2z_double_div2, <- IH1. apply add_carry_div2.
+ rewrite <- Hm.
+ now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0.
+ (* step, carry *)
+ rewrite add_b2z_double_div2.
+ bitwise.
+ le_elim Hm.
+ rewrite <- (succ_pred m), lt_succ_r in Hm.
+ rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial.
+ autorewrite with bitwise. now rewrite add_b2z_double_div2.
+ rewrite <- Hm.
+ now rewrite add_b2z_double_bit0.
+ (* step, carry0 *)
+ apply add_b2z_double_bit0.
+Qed.
+
+Lemma add_carry_bits : forall a b (c0:bool), exists c,
+ a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0.
+Proof.
+ intros a b c0.
+ set (n := max (abs a) (abs b)).
+ apply (add_carry_bits_aux n).
+ (* positivity *)
+ unfold n.
+ destruct (le_ge_cases (abs a) (abs b));
+  [rewrite max_r|rewrite max_l]; order_pos'.
+ (* bound for a *)
+ assert (Ha : abs a < 2^n).
+  apply lt_le_trans with (2^(abs a)). apply pow_gt_lin_r; order_pos'.
+  apply pow_le_mono_r. order'. unfold n.
+  destruct (le_ge_cases (abs a) (abs b));
+   [rewrite max_r|rewrite max_l]; try order.
+ apply abs_lt in Ha. destruct Ha; split; order.
+ (* bound for b *)
+ assert (Hb : abs b < 2^n).
+  apply lt_le_trans with (2^(abs b)). apply pow_gt_lin_r; order_pos'.
+  apply pow_le_mono_r. order'. unfold n.
+  destruct (le_ge_cases (abs a) (abs b));
+   [rewrite max_r|rewrite max_l]; try order.
+ apply abs_lt in Hb. destruct Hb; split; order.
+Qed.
+
+(** Particular case : the second bit of an addition *)
+
+Lemma add_bit1 : forall a b,
+ (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]).
+Proof.
+ intros a b.
+ destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
+ simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
+ autorewrite with bitwise. f_equal.
+ rewrite one_succ, <- div2_bits, EQ2 by order.
+ autorewrite with bitwise.
+ rewrite Hc. simpl. apply orb_false_r.
+Qed.
+
+(** In an addition, there will be no carries iff there is
+  no common bits in the numbers to add *)
+
+Lemma nocarry_equiv : forall a b c,
+ c/2 == lnextcarry a b c -> c.[0] = false ->
+ (c == 0 <-> land a b == 0).
+Proof.
+ intros a b c H H'.
+ split. intros EQ; rewrite EQ in *.
+ rewrite div_0_l in H by order'.
+ symmetry in H. now apply lor_eq_0_l in H.
+ intros EQ. rewrite EQ, lor_0_l in H.
+ apply bits_inj'. intros n Hn. rewrite bits_0.
+ apply le_ind with (4:=Hn).
+ solve_proper.
+ trivial.
+ clear n Hn. intros n Hn IH.
+ rewrite <- div2_bits, H; trivial.
+ autorewrite with bitwise.
+ now rewrite IH.
+Qed.
+
+(** When there is no common bits, the addition is just a xor *)
+
+Lemma add_nocarry_lxor : forall a b, land a b == 0 ->
+ a+b == lxor a b.
+Proof.
+ intros a b H.
+ destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
+ simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
+ apply (nocarry_equiv a b c) in H; trivial.
+ rewrite H. now rewrite lxor_0_r.
+Qed.
+
+(** A null [ldiff] implies being smaller *)
+
+Lemma ldiff_le : forall a b, 0<=b -> ldiff a b == 0 -> 0 <= a <= b.
+Proof.
+ assert (AUX : forall n, 0<=n ->
+          forall a b, 0 <= a < 2^n -> 0<=b -> ldiff a b == 0 -> a <= b).
+ intros n Hn. apply le_ind with (4:=Hn); clear n Hn.
+ solve_proper.
+ intros a b Ha Hb _. rewrite pow_0_r, one_succ, lt_succ_r in Ha.
+ setoid_replace a with 0 by (destruct Ha; order'); trivial.
+ intros n Hn IH a b (Ha,Ha') Hb H.
+ assert (NEQ : 2 ~= 0) by order'.
+ rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ).
+ apply add_le_mono.
+ apply mul_le_mono_pos_l; try order'.
+ apply IH.
+ split. apply div_pos; order'.
+ apply div_lt_upper_bound; try order'. now rewrite <- pow_succ_r.
+ apply div_pos; order'.
+ rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2 by order'.
+ rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l; order'.
+ rewrite <- 2 bit0_mod.
+ apply bits_inj_iff in H. specialize (H 0).
+ rewrite ldiff_spec, bits_0 in H.
+ destruct a.[0], b.[0]; try discriminate; simpl; order'.
+ (* main *)
+ intros a b Hb Hd.
+ assert (Ha : 0<=a).
+  apply le_ngt; intros Ha'. apply (lt_irrefl 0). rewrite <- Hd at 1.
+  apply ldiff_neg. now split.
+ split; trivial. apply (AUX a); try split; trivial. apply pow_gt_lin_r; order'.
+Qed.
+
+(** Subtraction can be a ldiff when the opposite ldiff is null. *)
+
+Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 ->
+ a-b == ldiff a b.
+Proof.
+ intros a b H.
+ apply add_cancel_r with b.
+ rewrite sub_add.
+ symmetry.
+ rewrite add_nocarry_lxor; trivial.
+ bitwise.
+ apply bits_inj_iff in H. specialize (H m).
+ rewrite ldiff_spec, bits_0 in H.
+ now destruct a.[m], b.[m].
+ apply land_ldiff.
+Qed.
+
+(** Adding numbers with no common bits cannot lead to a much bigger number *)
+
+Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 ->
+ a < 2^n -> b < 2^n -> a+b < 2^n.
+Proof.
+ intros a b n H Ha Hb.
+ destruct (le_gt_cases a 0) as [Ha'|Ha'].
+ apply le_lt_trans with (0+b). now apply add_le_mono_r. now nzsimpl.
+ destruct (le_gt_cases b 0) as [Hb'|Hb'].
+ apply le_lt_trans with (a+0). now apply add_le_mono_l. now nzsimpl.
+ rewrite add_nocarry_lxor by order.
+ destruct (lt_ge_cases 0 (lxor a b)); [|apply le_lt_trans with 0; order_pos].
+ apply log2_lt_pow2; trivial.
+ apply log2_lt_pow2 in Ha; trivial.
+ apply log2_lt_pow2 in Hb; trivial.
+ apply le_lt_trans with (max (log2 a) (log2 b)).
+ apply log2_lxor; order.
+ destruct (le_ge_cases (log2 a) (log2 b));
+  [rewrite max_r|rewrite max_l]; order.
+Qed.
+
+Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 ->
+ a mod 2^n + b mod 2^n < 2^n.
+Proof.
+ intros a b n Hn H.
+ apply add_nocarry_lt_pow2.
+ bitwise.
+ destruct (le_gt_cases n m).
+ rewrite mod_pow2_bits_high; now split.
+ now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0.
+ apply mod_pos_bound; order_pos.
+ apply mod_pos_bound; order_pos.
+Qed.
+
+End ZBitsProp.
diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v
index 4555e733..fe951a75 100644
--- a/theories/Numbers/Integer/Abstract/ZDivEucl.v
+++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v
@@ -1,11 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.
+
 (** * Euclidean Division for integers, Euclid convention
 
     We use here the "usual" formulation of the Euclid Theorem
@@ -19,37 +21,29 @@
     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.
+    We simply extend NZDiv with a bound for modulo that holds
+    regardless of the sign of a and b. This new specification
+    subsume mod_bound_pos, which nonetheless stays there for
+    subtyping. Note also that ZAxiomSig now already contain
+    a div and a modulo (that follow the Floor convention).
+    We just ignore them here.
+*)
 
-Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv.
-Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation.
+Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod' A).
+ Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= a mod b < abs b.
+End EuclidSpec.
 
-Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z).
+Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.
+Module Type ZEuclid' (Z:ZAxiomsSig) := NZDiv.NZDiv' Z <+ EuclidSpec Z.
 
-(** We benefit from what already exists for NZ *)
+Module ZEuclidProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZSgnAbsProp A B)
+ (Import D : ZEuclid' A).
 
- 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.
+ Module Import Private_NZDiv := Nop <+ NZDivProp A D B.
 
 (** Another formulation of the main equation *)
 
@@ -117,7 +111,7 @@ 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 abs_opp; now apply mod_always_pos.
 rewrite mul_opp_opp; now apply div_mod.
 Qed.
 
@@ -125,7 +119,7 @@ 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 abs_opp; now apply mod_always_pos.
 rewrite mul_opp_opp; now apply div_mod.
 Qed.
 
@@ -274,6 +268,11 @@ Proof.
 intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
 Qed.
 
+Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b.
+Proof.
+ intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul.
+Qed.
+
 (** * Order results about mod and div *)
 
 (** A modulo cannot grow beyond its starting point. *)
@@ -296,7 +295,7 @@ intros a b Hb.
 split.
 intros EQ.
 rewrite (div_mod a b Hb), EQ; nzsimpl.
-apply mod_always_pos.
+now apply mod_always_pos.
 intros. pos_or_neg b.
 apply div_small.
 now rewrite <- (abs_eq b).
@@ -365,7 +364,7 @@ intros.
 nzsimpl.
 rewrite (div_mod a b) at 1; try order.
 rewrite <- add_lt_mono_l.
-destruct (mod_always_pos a b).
+destruct (mod_always_pos a b). order.
 rewrite abs_eq in *; order.
 Qed.
 
@@ -375,7 +374,7 @@ 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).
+destruct (mod_always_pos a b). order.
 rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
 Qed.
 
@@ -469,7 +468,7 @@ 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.
+now apply mod_always_pos.
 (* equation *)
 rewrite (div_mod a b) at 1 by order.
 rewrite mul_add_distr_r.
@@ -556,17 +555,18 @@ Proof.
 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) ]. *)
+    true with a negative intermediate divisor. For instance
+    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and
+    [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *)
 
-Lemma div_div : forall a b c, 0<b -> 0<c ->
+Lemma div_div : forall a b c, 0<b -> c~=0 ->
  (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).
+ destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order.
  split.
  apply add_nonneg_nonneg; trivial.
  apply mul_nonneg_nonneg; order.
@@ -581,6 +581,22 @@ Proof.
  apply div_mod; order.
 Qed.
 
+(** Similarly, the following result doesn't always hold when [b<0].
+    For instance [3 mod (-2*-2)) = 3] while
+    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *)
+
+Lemma mod_mul_r : forall a b c, 0<b -> c~=0 ->
+ a mod (b*c) == a mod b + b*((a/b) mod c).
+Proof.
+ intros a b c Hb Hc.
+ apply add_cancel_l with (b*c*(a/(b*c))).
+ rewrite <- div_mod by (apply neq_mul_0; split; order).
+ rewrite <- div_div by trivial.
+ rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
+ rewrite <- div_mod by order.
+ apply div_mod; order.
+Qed.
+
 (** A last inequality: *)
 
 Theorem div_mul_le:
@@ -590,16 +606,13 @@ 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).
+ (a mod b == 0 <-> (b|a)).
 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.
+intros Hab. exists (a/b). rewrite mul_comm.
+ rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
+intros (c,Hc). rewrite Hc. now apply mod_mul.
 Qed.
 
-
-End ZDivPropFunct.
+End ZEuclidProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v
index efefab81..14003d89 100644
--- a/theories/Numbers/Integer/Abstract/ZDivFloor.v
+++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v
@@ -1,11 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.
+
 (** * Euclidean Division for integers (Floor convention)
 
     We use here the convention known as Floor, or Round-Toward-Bottom,
@@ -24,33 +26,13 @@
     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).
+Module Type ZDivProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZSgnAbsProp A B).
 
 (** 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.
+Module Import Private_NZDiv := Nop <+ NZDivProp A A B.
 
 (** Another formulation of the main equation *)
 
@@ -62,6 +44,18 @@ rewrite <- add_move_l.
 symmetry. now apply div_mod.
 Qed.
 
+(** We have a general bound for absolute values *)
+
+Lemma mod_bound_abs :
+ forall a b, b~=0 -> abs (a mod b) < abs b.
+Proof.
+intros.
+destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ.
+destruct (mod_pos_bound a b). order. now rewrite abs_eq.
+destruct (mod_neg_bound a b). order. rewrite abs_neq; trivial.
+now rewrite <- opp_lt_mono.
+Qed.
+
 (** Uniqueness theorems *)
 
 Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
@@ -94,7 +88,7 @@ Theorem div_unique_pos:
 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.
+ forall a b q r, b<r<=0 -> a == b*q + r -> q == a/b.
 Proof. intros; apply div_unique with r; auto. Qed.
 
 Theorem mod_unique:
@@ -230,11 +224,26 @@ 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] *)
+(** The sign of [a mod b] is the one of [b] (when it isn't null) *)
+
+Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 ->
+ sgn (a mod b) == sgn b.
+Proof.
+intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb'].
+destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order.
+destruct (mod_neg_bound a b). order. rewrite 2 sgn_neg; order.
+Qed.
 
-(* TODO: a proper sgn function and theory *)
+Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b.
+Proof.
+intros a b Hb H.
+destruct (eq_decidable (a mod b) 0) as [EQ|NEQ].
+apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0.
+apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'.
+apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz.
+Qed.
 
-Lemma mod_sign : forall a b, b~=0 -> (0 <= (a mod b) * b).
+Lemma mod_sign_mul : 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.
@@ -307,6 +316,11 @@ Proof.
 intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
 Qed.
 
+Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b.
+Proof.
+ intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul.
+Qed.
+
 (** * Order results about mod and div *)
 
 (** A modulo cannot grow beyond its starting point. *)
@@ -585,15 +599,25 @@ Proof.
 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) ]. *)
+    true with a negative last divisor. For instance
+    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ], or
+    [ 5/2/(-2) = -1 <> -2 = 5 / (2*-2) ]. *)
 
-Lemma div_div : forall a b c, 0<b -> 0<c ->
+Lemma div_div : forall a b c, b~=0 -> 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 \/ ... *)
+ apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb].
+ right.
+ destruct (mod_pos_bound (a/b) c), (mod_neg_bound a b); trivial.
+ split.
+ apply le_lt_trans with (b*((a/b) mod c) + b).
+ now rewrite <- mul_succ_r, <- mul_le_mono_neg_l, le_succ_l.
+ now rewrite <- add_lt_mono_l.
+ apply add_nonpos_nonpos; trivial.
+ apply mul_nonpos_nonneg; order.
  left.
  destruct (mod_pos_bound (a/b) c), (mod_pos_bound a b); trivial.
  split.
@@ -609,24 +633,27 @@ Proof.
  apply div_mod; order.
 Qed.
 
+(** Similarly, the following result doesn't always hold when [c<0].
+    For instance [3 mod (-2*-2)) = 3] while
+    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1].
+*)
+
+Lemma rem_mul_r : forall a b c, b~=0 -> 0<c ->
+ a mod (b*c) == a mod b + b*((a/b) mod c).
+Proof.
+ intros a b c Hb Hc.
+ apply add_cancel_l with (b*c*(a/(b*c))).
+ rewrite <- div_mod by (apply neq_mul_0; split; order).
+ rewrite <- div_div by trivial.
+ rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
+ rewrite <- div_mod 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.
-
+End ZDivProp.
diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
index 069d8a8d..bd8b6ce2 100644
--- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v
+++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
@@ -1,11 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.
+
 (** * Euclidean Division for integers (Trunc convention)
 
     We use here the convention known as Trunc, or Round-Toward-Zero,
@@ -24,25 +26,24 @@
     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).
+Module Type ZQuotProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZSgnAbsProp A B).
 
 (** We benefit from what already exists for NZ *)
 
- Module Import NZDivP := NZDivPropFunct Z ZP Z.
+ Module Import Private_Div.
+ Module Quot2Div <: NZDiv A.
+  Definition div := quot.
+  Definition modulo := A.rem.
+  Definition div_wd := quot_wd.
+  Definition mod_wd := rem_wd.
+  Definition div_mod := quot_rem.
+  Definition mod_bound_pos := rem_bound_pos.
+ End Quot2Div.
+ Module NZQuot := Nop <+ NZDivProp A Quot2Div B.
+ End Private_Div.
 
 Ltac pos_or_neg a :=
  let LT := fresh "LT" in
@@ -51,175 +52,274 @@ Ltac pos_or_neg a :=
 
 (** Another formulation of the main equation *)
 
-Lemma mod_eq :
- forall a b, b~=0 -> a mod b == a - b*(a/b).
+Lemma rem_eq :
+ forall a b, b~=0 -> a rem b == a - b*(a÷b).
 Proof.
 intros.
 rewrite <- add_move_l.
-symmetry. now apply div_mod.
+symmetry. now apply quot_rem.
 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 rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b).
+Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed.
 
-Lemma div_opp_l : forall a b, b ~= 0 -> (-a)/b == -(a/b).
+Lemma quot_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.
+rewrite <- (add_cancel_r _ _ ((-a) rem b)).
+now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem.
 Qed.
 
-Lemma div_opp_r : forall a b, b ~= 0 -> a/(-b) == -(a/b).
+Lemma quot_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.
+rewrite <- (add_cancel_r _ _ (a rem (-b))).
+now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem.
 Qed.
 
+Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)÷(-b) == a÷b.
+Proof. intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed.
 
 (** Uniqueness theorems *)
 
-Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
+Theorem quot_rem_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.
+apply NZQuot.div_mod_unique with b; trivial.
 rewrite <- (opp_inj_wd r1 r2).
-apply div_mod_unique with (-b); trivial.
+apply NZQuot.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 quot_unique:
+ forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a÷b.
+Proof. intros; now apply NZQuot.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.
+Theorem rem_unique:
+ forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a rem b.
+Proof. intros; now apply NZQuot.mod_unique with q. Qed.
 
 (** A division by itself returns 1 *)
 
-Lemma div_same : forall a, a~=0 -> a/a == 1.
+Lemma quot_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.
+intros. pos_or_neg a. apply NZQuot.div_same; order.
+rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same.
 Qed.
 
-Lemma mod_same : forall a, a~=0 -> a mod a == 0.
+Lemma rem_same : forall a, a~=0 -> a rem a == 0.
 Proof.
-intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
+intros. rewrite rem_eq, quot_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.
+Theorem quot_small: forall a b, 0<=a<b -> a÷b == 0.
+Proof. exact NZQuot.div_small. Qed.
 
-(** Same situation, in term of modulo: *)
+(** Same situation, in term of remulo: *)
 
-Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
-Proof. exact mod_small. Qed.
+Theorem rem_small: forall a b, 0<=a<b -> a rem b == a.
+Proof. exact NZQuot.mod_small. Qed.
 
 (** * Basic values of divisions and modulo. *)
 
-Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
+Lemma quot_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.
+intros. pos_or_neg a. apply NZQuot.div_0_l; order.
+rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l.
 Qed.
 
-Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
+Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0.
 Proof.
-intros; rewrite mod_eq, div_0_l; now nzsimpl.
+intros; rewrite rem_eq, quot_0_l; now nzsimpl.
 Qed.
 
-Lemma div_1_r: forall a, a/1 == a.
+Lemma quot_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.
+intros. pos_or_neg a. now apply NZQuot.div_1_r.
+apply opp_inj. rewrite <- quot_opp_l. apply NZQuot.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.
+Lemma rem_1_r: forall a, a rem 1 == 0.
 Proof.
-intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
+intros. rewrite rem_eq, quot_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 quot_1_l: forall a, 1<a -> 1÷a == 0.
+Proof. exact NZQuot.div_1_l. Qed.
+
+Lemma rem_1_l: forall a, 1<a -> 1 rem a == 1.
+Proof. exact NZQuot.mod_1_l. Qed.
 
-Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
-Proof. exact mod_1_l. Qed.
+Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a.
+Proof.
+intros. pos_or_neg a; pos_or_neg b. apply NZQuot.div_mul; order.
+rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order.
+rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order.
+apply NZQuot.div_mul; order.
+rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order.
+apply NZQuot.div_mul; order.
+Qed.
 
-Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
+Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0.
 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.
+intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag.
 Qed.
 
-Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
+Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b.
 Proof.
-intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
+ intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul.
 Qed.
 
-(** * Order results about mod and div *)
+(** The sign of [a rem b] is the one of [a] (when it's not null) *)
+
+Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b.
+Proof.
+ intros. pos_or_neg b. destruct (rem_bound_pos a b); order.
+ rewrite <- rem_opp_r; trivial.
+ destruct (rem_bound_pos a (-b)); trivial.
+Qed.
+
+Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0.
+Proof.
+ intros a b Hb Ha.
+ apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha.
+ rewrite <- rem_opp_l by trivial. now apply rem_nonneg.
+Qed.
+
+Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a.
+Proof.
+intros a b Hb. destruct (le_ge_cases 0 a).
+ apply mul_nonneg_nonneg; trivial. now apply rem_nonneg.
+ apply mul_nonpos_nonpos; trivial. now apply rem_nonpos.
+Qed.
+
+Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 ->
+ sgn (a rem b) == sgn a.
+Proof.
+intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
+rewrite 2 sgn_pos; try easy.
+ generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order.
+now rewrite <- EQ, rem_0_l, sgn_0.
+rewrite 2 sgn_neg; try easy.
+ generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order.
+Qed.
+
+Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a.
+Proof.
+intros a b Ha Hb H.
+destruct (eq_decidable (a rem b) 0) as [EQ|NEQ].
+apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0.
+apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'.
+apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz.
+Qed.
+
+(** Operations and absolute value *)
+
+Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b).
+Proof.
+intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE].
+rewrite 2 abs_eq; try easy. now apply rem_nonneg.
+rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos.
+Qed.
+
+Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b.
+Proof.
+intros a b Hb. destruct (le_ge_cases 0 b).
+now rewrite abs_eq. now rewrite abs_neq, ?rem_opp_r.
+Qed.
+
+Lemma rem_abs : forall a b,  b ~= 0 -> (abs a) rem (abs b) == abs (a rem b).
+Proof.
+intros. now rewrite rem_abs_r, rem_abs_l.
+Qed.
+
+Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)÷b == (sgn a)*(a÷b).
+Proof.
+intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
+rewrite abs_eq, sgn_pos by order. now nzsimpl.
+rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl.
+rewrite abs_neq, quot_opp_l, sgn_neg by order.
+ rewrite mul_opp_l. now nzsimpl.
+Qed.
+
+Lemma quot_abs_r : forall a b, b ~= 0 -> a÷(abs b) == (sgn b)*(a÷b).
+Proof.
+intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]].
+rewrite abs_eq, sgn_pos by order. now nzsimpl.
+order.
+rewrite abs_neq, quot_opp_r, sgn_neg by order.
+ rewrite mul_opp_l. now nzsimpl.
+Qed.
+
+Lemma quot_abs : forall a b, b ~= 0 -> (abs a)÷(abs b) == abs (a÷b).
+Proof.
+intros a b Hb.
+pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)];
+ try apply opp_nonneg_nonpos; try order.
+pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)];
+ try apply opp_nonneg_nonpos; try order.
+rewrite abs_eq; try easy. apply NZQuot.div_pos; order.
+rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy.
+ apply NZQuot.div_pos; order.
+pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)];
+ try apply opp_nonneg_nonpos; try order.
+rewrite <- (abs_opp (_÷_)), <- quot_opp_l, abs_eq; try easy.
+ apply NZQuot.div_pos; order.
+rewrite <- (quot_opp_opp a b), abs_eq; try easy.
+ apply NZQuot.div_pos; order.
+Qed.
+
+(** We have a general bound for absolute values *)
+
+Lemma rem_bound_abs :
+ forall a b, b~=0 -> abs (a rem b) < abs b.
+Proof.
+intros. rewrite <- rem_abs; trivial.
+apply rem_bound_pos. apply abs_nonneg. now apply abs_pos.
+Qed.
+
+(** * Order results about rem and quot *)
 
 (** 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 rem_le: forall a b, 0<=a -> 0<b -> a rem b <= a.
+Proof. exact NZQuot.mod_le. Qed.
 
-Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
-Proof. exact div_pos. Qed.
+Theorem quot_pos : forall a b, 0<=a -> 0<b -> 0<= a÷b.
+Proof. exact NZQuot.div_pos. Qed.
 
-Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
-Proof. exact div_str_pos. Qed.
+Lemma quot_str_pos : forall a b, 0<b<=a -> 0 < a÷b.
+Proof. exact NZQuot.div_str_pos. Qed.
 
-Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> abs a < abs b).
+Lemma quot_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 NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order.
+rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.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 <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order.
  rewrite (abs_neq' a), (abs_eq b); intuition; order.
-rewrite <- div_opp_opp, div_small_iff by order.
+rewrite <- quot_opp_opp, NZQuot.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).
+Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b).
 Proof.
-intros. rewrite mod_eq, <- div_small_iff by order.
+intros. rewrite rem_eq, <- quot_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.
@@ -227,306 +327,306 @@ 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.
+Lemma quot_lt : forall a b, 0<a -> 1<b -> a÷b < a.
+Proof. exact NZQuot.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.
+Lemma quot_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.
+intros. pos_or_neg a. apply NZQuot.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.
+ rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order.
+ apply quot_pos; order.
+ apply quot_pos; order.
+rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order.
+ apply NZQuot.div_le_mono; intuition; order.
 Qed.
 
 (** With this choice of division,
-    rounding of div is always done toward zero: *)
+    rounding of quot is always done toward zero: *)
 
-Lemma mul_div_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a/b) <= a.
+Lemma mul_quot_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.
+apply mul_nonneg_nonneg; [|apply quot_pos]; order.
+apply NZQuot.mul_div_le; order.
+rewrite <- mul_opp_opp, <- quot_opp_r by order.
 split.
-apply mul_nonneg_nonneg; [|apply div_pos]; order.
-apply mul_div_le; order.
+apply mul_nonneg_nonneg; [|apply quot_pos]; order.
+apply NZQuot.mul_div_le; order.
 Qed.
 
-Lemma mul_div_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a/b) <= 0.
+Lemma mul_quot_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, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order.
 rewrite <- opp_nonneg_nonpos in *.
-destruct (mul_div_le (-a) b); tauto.
+destruct (mul_quot_le (-a) b); tauto.
 Qed.
 
-(** For positive numbers, considering [S (a/b)] leads to an upper bound for [a] *)
+(** 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.
+Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a÷b)).
+Proof. exact NZQuot.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.
+Lemma mul_pred_quot_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_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order.
 rewrite <- opp_nonneg_nonpos in *.
-now apply mul_succ_div_gt.
+now apply mul_succ_quot_gt.
 Qed.
 
-Lemma mul_pred_div_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a/b)).
+Lemma mul_pred_quot_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 <- mul_opp_opp, opp_pred, <- quot_opp_r by order.
 rewrite <- opp_pos_neg in *.
-now apply mul_succ_div_gt.
+now apply mul_succ_quot_gt.
 Qed.
 
-Lemma mul_succ_div_lt: forall a b, a<=0 -> b<0 -> b*(S (a/b)) < a.
+Lemma mul_succ_quot_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_lt_mono, <- mul_opp_l, <- quot_opp_opp by order.
 rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *.
-now apply mul_succ_div_gt.
+now apply mul_succ_quot_gt.
 Qed.
 
-(** Inequality [mul_div_le] is exact iff the modulo is zero. *)
+(** Inequality [mul_quot_le] is exact iff the modulo is zero. *)
 
-Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
+Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0).
 Proof.
-intros. rewrite mod_eq by order. rewrite sub_move_r; nzsimpl; tauto.
+intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto.
 Qed.
 
-(** Some additionnal inequalities about div. *)
+(** Some additionnal inequalities about quot. *)
 
-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 quot_lt_upper_bound:
+  forall a b q, 0<=a -> 0<b -> a < b*q -> a÷b < q.
+Proof. exact NZQuot.div_lt_upper_bound. Qed.
 
-Theorem div_le_upper_bound:
-  forall a b q, 0<b -> a <= b*q -> a/b <= q.
+Theorem quot_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.
+rewrite <- (quot_mul q b) by order.
+apply quot_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.
+Theorem quot_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.
+rewrite <- (quot_mul q b) by order.
+apply quot_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.
+Lemma quot_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p÷r <= p÷q.
+Proof. exact NZQuot.div_le_compat_l. Qed.
 
-(** * Relations between usual operations and mod and div *)
+(** * Relations between usual operations and rem and quot *)
 
 (** 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] *)
+    [(a+b*c) rem c <> a rem 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.
+Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a ->
+ (a + b * c) rem c == a rem 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.
+assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c).
+ intros. pos_or_neg c. apply NZQuot.mod_add; order.
+ rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order.
  rewrite <- mul_opp_opp in *.
- apply mod_add; order.
+ apply NZQuot.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.
+rewrite <- 2 rem_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.
+Lemma quot_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.
+rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)).
+rewrite <- quot_rem, rem_add by trivial.
+now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, 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.
+Lemma quot_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.
+ intros a b c. rewrite add_comm, (add_comm a). now apply quot_add.
 Qed.
 
 (** Cancellations. *)
 
-Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
- (a*c)/(b*c) == a/b.
+Lemma quot_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.
+assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)÷(b*c) == a÷b).
+ intros. pos_or_neg c. apply NZQuot.div_mul_cancel_r; order.
+ rewrite <- quot_opp_opp, <- 2 mul_opp_r. apply NZQuot.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).
+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.
+ apply opp_inj. rewrite <- 2 quot_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.
+apply opp_inj. rewrite <- 2 quot_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.
+Lemma quot_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.
+intros. rewrite !(mul_comm c); now apply quot_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.
+Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 ->
+  (a*c) rem (b*c) == (a rem 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).
+rewrite ! rem_eq by trivial.
+rewrite quot_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).
+Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 ->
+  (c*a) rem (c*b) == c * (a rem b).
 Proof.
-intros; rewrite !(mul_comm c); now apply mul_mod_distr_r.
+intros; rewrite !(mul_comm c); now apply mul_rem_distr_r.
 Qed.
 
 (** Operations modulo. *)
 
-Theorem mod_mod: forall a n, n~=0 ->
- (a mod n) mod n == a mod n.
+Theorem rem_rem: forall a n, n~=0 ->
+ (a rem n) rem n == a rem 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.
+intros. pos_or_neg a; pos_or_neg n. apply NZQuot.mod_mod; order.
+rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order.
+apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order.
+apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.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.
+Lemma mul_rem_idemp_l : forall a b n, n~=0 ->
+ ((a rem n)*b) rem n == (a*b) rem 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.
+         ((a rem n)*b) rem n == (a*b) rem n).
+ intros. pos_or_neg n. apply NZQuot.mul_mod_idemp_l; order.
+ rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.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).
+         ((a rem n)*b) rem n == (a*b) rem n).
  intros. pos_or_neg b. now apply Aux1.
- apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_r by order.
+ apply opp_inj. rewrite <-2 rem_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 opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_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.
+Lemma mul_rem_idemp_r : forall a b n, n~=0 ->
+ (a*(b rem n)) rem n == (a*b) rem n.
 Proof.
-intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
+intros. rewrite !(mul_comm a). now apply mul_rem_idemp_l.
 Qed.
 
-Theorem mul_mod: forall a b n, n~=0 ->
- (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Theorem mul_rem: forall a b n, n~=0 ->
+ (a * b) rem n == ((a rem n) * (b rem n)) rem n.
 Proof.
-intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
+intros. now rewrite mul_rem_idemp_l, mul_rem_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]
+       [(a+b) rem n = (a rem n + b rem n) rem n]
   for any a and b.
-  For instance, take (8 + (-10)) mod 3 = -2 whereas
-  (8 mod 3 + (-10 mod 3)) mod 3 = 1.
+  For instance, take (8 + (-10)) rem 3 = -2 whereas
+  (8 rem 3 + (-10 rem 3)) rem 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.
+Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b ->
+ ((a rem n)+b) rem n == (a+b) rem 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.
+          ((a rem n)+b) rem n == (a+b) rem n).
+ intros. pos_or_neg n. apply NZQuot.add_mod_idemp_l; order.
+ rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.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.
+apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_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.
+Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b ->
+ (a+(b rem n)) rem n == (a+b) rem n.
 Proof.
-intros. rewrite !(add_comm a). apply add_mod_idemp_l; trivial.
+intros. rewrite !(add_comm a). apply add_rem_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.
+Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b ->
+ (a+b) rem n == (a rem n + b rem n) rem n.
 Proof.
-intros a b n Hn Hab. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial.
+intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_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)];
+ destruct (le_0_mul _ _ (rem_sign_mul 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.
+ setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order.
+ setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order.
 Qed.
 
+(** Conversely, the following results need less restrictions here. *)
 
-(** 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).
+Lemma quot_quot : 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.
+assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a÷b)÷c == a÷(b*c)).
+ intros. pos_or_neg c. apply NZQuot.div_div; order.
+ apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial.
+ apply NZQuot.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)).
+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 opp_inj. rewrite <- quot_opp_l, <- 2 quot_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.
+apply opp_inj. rewrite <- 3 quot_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).
+Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 ->
+ a rem (b*c) == a rem b + b*((a÷b) rem 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.
+ intros a b c Hb Hc.
+ apply add_cancel_l with (b*c*(a÷(b*c))).
+ rewrite <- quot_rem by (apply neq_mul_0; split; order).
+ rewrite <- quot_quot by trivial.
+ rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
+ rewrite <- quot_rem by order.
+ apply quot_rem; order.
 Qed.
 
-End ZDivPropFunct.
+(** A last inequality: *)
+
+Theorem quot_mul_le:
+ forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
+Proof. exact NZQuot.div_mul_le. Qed.
+
+End ZQuotProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v
new file mode 100644
index 00000000..404fc0c4
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZGcd.v
@@ -0,0 +1,274 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Properties of the greatest common divisor *)
+
+Require Import ZAxioms ZMulOrder ZSgnAbs NZGcd.
+
+Module Type ZGcdProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZSgnAbsProp A B).
+
+ Include NZGcdProp A A B.
+
+(** Results concerning divisibility*)
+
+Lemma divide_opp_l : forall n m, (-n | m) <-> (n | m).
+Proof.
+ intros n m. split; intros (p,Hp); exists (-p); rewrite Hp.
+  now rewrite mul_opp_l, mul_opp_r.
+  now rewrite mul_opp_opp.
+Qed.
+
+Lemma divide_opp_r : forall n m, (n | -m) <-> (n | m).
+Proof.
+ intros n m. split; intros (p,Hp); exists (-p).
+  now rewrite mul_opp_l, <- Hp, opp_involutive.
+  now rewrite Hp, mul_opp_l.
+Qed.
+
+Lemma divide_abs_l : forall n m, (abs n | m) <-> (n | m).
+Proof.
+ intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H.
+ easy. apply divide_opp_l.
+Qed.
+
+Lemma divide_abs_r : forall n m, (n | abs m) <-> (n | m).
+Proof.
+ intros n m. destruct (abs_eq_or_opp m) as [H|H]; rewrite H.
+ easy. apply divide_opp_r.
+Qed.
+
+Lemma divide_1_r_abs : forall n, (n | 1) -> abs n == 1.
+Proof.
+ intros n Hn. apply divide_1_r_nonneg. apply abs_nonneg.
+ now apply divide_abs_l.
+Qed.
+
+Lemma divide_1_r : forall n, (n | 1) -> n==1 \/ n==-1.
+Proof.
+ intros n (m,H). rewrite mul_comm in H. now apply eq_mul_1 with m.
+Qed.
+
+Lemma divide_antisym_abs : forall n m,
+ (n | m) -> (m | n) -> abs n == abs m.
+Proof.
+ intros. apply divide_antisym_nonneg; try apply abs_nonneg.
+ now apply divide_abs_l, divide_abs_r.
+ now apply divide_abs_l, divide_abs_r.
+Qed.
+
+Lemma divide_antisym : forall n m,
+ (n | m) -> (m | n) -> n == m \/ n == -m.
+Proof.
+ intros. now apply abs_eq_cases, divide_antisym_abs.
+Qed.
+
+Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p).
+Proof.
+ intros n m p H H'. rewrite <- add_opp_r.
+ apply divide_add_r; trivial. now apply divide_opp_r.
+Qed.
+
+Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p).
+Proof.
+ intros n m p H H'. rewrite <- (add_simpl_l m p). now apply divide_sub_r.
+Qed.
+
+(** Properties of gcd *)
+
+Lemma gcd_opp_l : forall n m, gcd (-n) m == gcd n m.
+Proof.
+ intros. apply gcd_unique_alt; try apply gcd_nonneg.
+ intros. rewrite divide_opp_r. apply gcd_divide_iff.
+Qed.
+
+Lemma gcd_opp_r : forall n m, gcd n (-m) == gcd n m.
+Proof.
+ intros. now rewrite gcd_comm, gcd_opp_l, gcd_comm.
+Qed.
+
+Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m.
+Proof.
+ intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H.
+ easy. apply gcd_opp_l.
+Qed.
+
+Lemma gcd_abs_r : forall n m, gcd n (abs m) == gcd n m.
+Proof.
+ intros. now rewrite gcd_comm, gcd_abs_l, gcd_comm.
+Qed.
+
+Lemma gcd_0_l : forall n, gcd 0 n == abs n.
+Proof.
+ intros. rewrite <- gcd_abs_r. apply gcd_0_l_nonneg, abs_nonneg.
+Qed.
+
+Lemma gcd_0_r : forall n, gcd n 0 == abs n.
+Proof.
+ intros. now rewrite gcd_comm, gcd_0_l.
+Qed.
+
+Lemma gcd_diag : forall n, gcd n n == abs n.
+Proof.
+ intros. rewrite <- gcd_abs_l, <- gcd_abs_r.
+ apply gcd_diag_nonneg, abs_nonneg.
+Qed.
+
+Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m.
+Proof.
+ intros. apply gcd_unique_alt; try apply gcd_nonneg.
+ intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial.
+ apply divide_add_r; trivial. now apply divide_mul_r.
+ apply divide_add_cancel_r with (p*n); trivial.
+ now apply divide_mul_r. now rewrite add_comm.
+Qed.
+
+Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m.
+Proof.
+ intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r.
+Qed.
+
+Lemma gcd_sub_diag_r : forall n m, gcd n (m-n) == gcd n m.
+Proof.
+ intros n m. rewrite <- (mul_1_l n) at 2.
+ rewrite <- add_opp_r, <- mul_opp_l. apply gcd_add_mult_diag_r.
+Qed.
+
+Definition Bezout n m p := exists a b, a*n + b*m == p.
+
+Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout.
+Proof.
+ unfold Bezout. intros x x' Hx y y' Hy z z' Hz.
+ setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz.
+Qed.
+
+Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1.
+Proof.
+ intros n m (q & r & H).
+ apply gcd_unique; trivial using divide_1_l, le_0_1.
+ intros p Hn Hm.
+ rewrite <- H. apply divide_add_r; now apply divide_mul_r.
+Qed.
+
+Lemma gcd_bezout : forall n m p, gcd n m == p -> Bezout n m p.
+Proof.
+ (* First, a version restricted to natural numbers *)
+ assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)).
+  intros n Hn; pattern n.
+  apply strong_right_induction with (z:=0); trivial.
+  unfold Bezout. solve_proper.
+  clear n Hn. intros n Hn IHn.
+  apply le_lteq in Hn; destruct Hn as [Hn|Hn].
+  intros m Hm; pattern m.
+  apply strong_right_induction with (z:=0); trivial.
+  unfold Bezout. solve_proper.
+  clear m Hm. intros m Hm IHm.
+  destruct (lt_trichotomy n m) as [LT|[EQ|LT]].
+  (* n < m *)
+  destruct (IHm (m-n)) as (a & b & EQ).
+  apply sub_nonneg; order.
+  now apply lt_sub_pos.
+  exists (a-b). exists b.
+  rewrite gcd_sub_diag_r in EQ. rewrite <- EQ.
+  rewrite mul_sub_distr_r, mul_sub_distr_l.
+  now rewrite add_sub_assoc, add_sub_swap.
+  (* n = m *)
+  rewrite EQ. rewrite gcd_diag_nonneg; trivial.
+  exists 1. exists 0. now nzsimpl.
+  (* m < n *)
+  destruct (IHn m Hm LT n) as (a & b & EQ). order.
+  exists b. exists a. now rewrite gcd_comm, <- EQ, add_comm.
+  (* n = 0 *)
+  intros m Hm. rewrite <- Hn, gcd_0_l_nonneg; trivial.
+  exists 0. exists 1. now nzsimpl.
+ (* Then we relax the positivity condition on n *)
+ assert (aux' : forall n m, 0<=m -> Bezout n m (gcd n m)).
+  intros n m Hm.
+  destruct (le_ge_cases 0 n). now apply aux.
+  assert (Hn' : 0 <= -n) by now apply opp_nonneg_nonpos.
+  destruct (aux (-n) Hn' m Hm) as (a & b & EQ).
+  exists (-a). exists b. now rewrite <- gcd_opp_l, <- EQ, mul_opp_r, mul_opp_l.
+ (* And finally we do the same for m *)
+ intros n m p Hp. rewrite <- Hp; clear Hp.
+ destruct (le_ge_cases 0 m). now apply aux'.
+ assert (Hm' : 0 <= -m) by now apply opp_nonneg_nonpos.
+ destruct (aux' n (-m) Hm') as (a & b & EQ).
+ exists a. exists (-b). now rewrite <- gcd_opp_r, <- EQ, mul_opp_r, mul_opp_l.
+Qed.
+
+Lemma gcd_mul_mono_l :
+  forall n m p, gcd (p * n) (p * m) == abs p * gcd n m.
+Proof.
+ intros n m p.
+ apply gcd_unique.
+ apply mul_nonneg_nonneg; trivial using gcd_nonneg, abs_nonneg.
+ destruct (gcd_divide_l n m) as (q,Hq).
+ rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r.
+ rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l.
+ destruct (gcd_divide_r n m) as (q,Hq).
+ rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r.
+ rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l.
+ intros q H H'.
+ destruct (gcd_bezout n m (gcd n m) (eq_refl _)) as (a & b & EQ).
+ rewrite <- EQ, <- sgn_abs, mul_add_distr_l. apply divide_add_r.
+ rewrite mul_shuffle2. now apply divide_mul_l.
+ rewrite mul_shuffle2. now apply divide_mul_l.
+Qed.
+
+Lemma gcd_mul_mono_l_nonneg :
+ forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m.
+Proof.
+ intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l.
+Qed.
+
+Lemma gcd_mul_mono_r :
+ forall n m p, gcd (n * p) (m * p) == gcd n m * abs p.
+Proof.
+ intros n m p. now rewrite !(mul_comm _ p), gcd_mul_mono_l, mul_comm.
+Qed.
+
+Lemma gcd_mul_mono_r_nonneg :
+ forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p.
+Proof.
+ intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r.
+Qed.
+
+Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p).
+Proof.
+ intros n m p H G.
+ destruct (gcd_bezout n m 1 G) as (a & b & EQ).
+ rewrite <- (mul_1_l p), <- EQ, mul_add_distr_r.
+ apply divide_add_r. rewrite mul_shuffle0. apply divide_factor_r.
+ rewrite <- mul_assoc. now apply divide_mul_r.
+Qed.
+
+Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) ->
+ exists q r, n == q*r /\ (q | m) /\ (r | p).
+Proof.
+ intros n m p Hn H.
+ assert (G := gcd_nonneg n m).
+ apply le_lteq in G; destruct G as [G|G].
+ destruct (gcd_divide_l n m) as (q,Hq).
+ exists (gcd n m). exists q.
+ split. now rewrite mul_comm.
+ split. apply gcd_divide_r.
+ destruct (gcd_divide_r n m) as (r,Hr).
+ rewrite Hr in H. rewrite Hq in H at 1.
+ rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order].
+ apply gauss with r; trivial.
+ apply mul_cancel_r with (gcd n m); [order|].
+ rewrite mul_1_l.
+ rewrite <- gcd_mul_mono_r_nonneg, <- Hq, <- Hr; order.
+ symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order.
+Qed.
+
+(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *)
+
+End ZGcdProp.
diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v
new file mode 100644
index 00000000..06af04d1
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZLcm.v
@@ -0,0 +1,471 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor.
+
+(** * Least Common Multiple *)
+
+(** Unlike other functions around, we will define lcm below instead of
+  axiomatizing it. Indeed, there is no "prior art" about lcm in the
+  standard library to be compliant with, and the generic definition
+  of lcm via gcd is quite reasonable.
+
+  By the way, we also state here some combined properties of div/mod
+  and quot/rem and gcd.
+*)
+
+Module Type ZLcmProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZSgnAbsProp A B)
+ (Import D : ZDivProp A B C)
+ (Import E : ZQuotProp A B C)
+ (Import F : ZGcdProp A B C).
+
+(** The two notions of division are equal on non-negative numbers *)
+
+Lemma quot_div_nonneg : forall a b, 0<=a -> 0<b -> a÷b == a/b.
+Proof.
+ intros. apply div_unique_pos with (a rem b).
+ now apply rem_bound_pos.
+ apply quot_rem. order.
+Qed.
+
+Lemma rem_mod_nonneg : forall a b, 0<=a -> 0<b -> a rem b == a mod b.
+Proof.
+ intros. apply mod_unique_pos with (a÷b).
+ now apply rem_bound_pos.
+ apply quot_rem. order.
+Qed.
+
+(** We can use the sign rule to have an relation between divisions. *)
+
+Lemma quot_div : forall a b, b~=0 ->
+ a÷b == (sgn a)*(sgn b)*(abs a / abs b).
+Proof.
+ assert (AUX : forall a b, 0<b -> a÷b == (sgn a)*(sgn b)*(abs a / abs b)).
+  intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order.
+  destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
+  rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order.
+  rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order.
+  rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l
+    by order.
+   apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order.
+ (* main *)
+ intros a b Hb.
+ apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX].
+ rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r.
+ rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive.
+ reflexivity.
+ now apply opp_pos_neg.
+ rewrite eq_opp_l, opp_0; order.
+Qed.
+
+Lemma rem_mod : forall a b, b~=0 ->
+ a rem b == (sgn a) * ((abs a) mod (abs b)).
+Proof.
+ intros a b Hb.
+ rewrite <- rem_abs_r by trivial.
+ assert (Hb' := proj2 (abs_pos b) Hb).
+ destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
+ rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order.
+ rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order.
+ rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l
+    by order.
+  apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order.
+Qed.
+
+(** Modulo and remainder are null at the same place,
+    and this correspond to the divisibility relation. *)
+
+Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
+Proof.
+ intros a b Hb. split.
+ intros Hab. exists (a/b). rewrite mul_comm.
+ rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
+ intros (c,Hc). rewrite Hc. now apply mod_mul.
+Qed.
+
+Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)).
+Proof.
+ intros a b Hb. split.
+ intros Hab. exists (a÷b). rewrite mul_comm.
+ rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl.
+ intros (c,Hc). rewrite Hc. now apply rem_mul.
+Qed.
+
+Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0).
+Proof.
+ intros a b Hb. now rewrite mod_divide, rem_divide.
+Qed.
+
+(** When division is exact, div and quot agree *)
+
+Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b.
+Proof.
+ intros a b Hb H.
+ apply mul_cancel_l with b; trivial.
+ assert (H':=H).
+ apply rem_divide, quot_exact in H; trivial.
+ apply mod_divide, div_exact in H'; trivial.
+ now rewrite <-H,<-H'.
+Qed.
+
+Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
+ (c*a)/b == c*(a/b).
+Proof.
+ intros a b c Hb H.
+ apply mul_cancel_l with b; trivial.
+ rewrite mul_assoc, mul_shuffle0.
+ assert (H':=H). apply mod_divide, div_exact in H'; trivial.
+ rewrite <- H', (mul_comm a c).
+ symmetry. apply div_exact; trivial.
+ apply mod_divide; trivial.
+ now apply divide_mul_r.
+Qed.
+
+Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) ->
+ (c*a)÷b == c*(a÷b).
+Proof.
+ intros a b c Hb H.
+ rewrite 2 quot_div_exact; trivial.
+ apply divide_div_mul_exact; trivial.
+ now apply divide_mul_r.
+Qed.
+
+(** Gcd of divided elements, for exact divisions *)
+
+Lemma gcd_div_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
+ gcd (a/c) (b/c) == (gcd a b)/c.
+Proof.
+ intros a b c Hc Ha Hb.
+ apply mul_cancel_l with c; try order.
+ assert (H:=gcd_greatest _ _ _ Ha Hb).
+ apply mod_divide, div_exact in H; try order.
+ rewrite <- H.
+ rewrite <- gcd_mul_mono_l_nonneg; try order.
+ f_equiv; symmetry; apply div_exact; try order;
+  apply mod_divide; trivial; try order.
+Qed.
+
+Lemma gcd_quot_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
+ gcd (a÷c) (b÷c) == (gcd a b)÷c.
+Proof.
+ intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order.
+ now apply gcd_div_factor. now apply gcd_greatest.
+Qed.
+
+Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
+ gcd (a/g) (b/g) == 1.
+Proof.
+ intros a b g NZ EQ. rewrite gcd_div_factor.
+ now rewrite <- EQ, div_same.
+ generalize (gcd_nonneg a b); order.
+ rewrite EQ; apply gcd_divide_l.
+ rewrite EQ; apply gcd_divide_r.
+Qed.
+
+Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b ->
+ gcd (a÷g) (b÷g) == 1.
+Proof.
+ intros a b g NZ EQ. rewrite !quot_div_exact; trivial.
+ now apply gcd_div_gcd.
+ rewrite EQ; apply gcd_divide_r.
+ rewrite EQ; apply gcd_divide_l.
+Qed.
+
+(** The following equality is crucial for Euclid algorithm *)
+
+Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
+Proof.
+ intros a b Hb. rewrite mod_eq; trivial.
+ rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
+ rewrite (gcd_comm _ b).
+ apply gcd_add_mult_diag_r.
+Qed.
+
+Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a.
+Proof.
+ intros a b Hb. rewrite rem_eq; trivial.
+ rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
+ rewrite (gcd_comm _ b).
+ apply gcd_add_mult_diag_r.
+Qed.
+
+(** We now define lcm thanks to gcd:
+
+    lcm a b = a * (b / gcd a b)
+            = (a / gcd a b) * b
+            = (a*b) / gcd a b
+
+   We had an abs in order to have an always-nonnegative lcm,
+   in the spirit of gcd. Nota: [lcm 0 0] should be 0, which
+   isn't garantee with the third equation above.
+*)
+
+Definition lcm a b := abs (a*(b/gcd a b)).
+
+Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
+Proof. unfold lcm. solve_proper. Qed.
+
+Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
+  a * (b / gcd a b) == (a*b)/gcd a b.
+Proof.
+ intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
+Qed.
+
+Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
+  (a / gcd a b) * b == (a*b)/gcd a b.
+Proof.
+ intros a b H. rewrite 2 (mul_comm _ b).
+ rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
+Qed.
+
+Lemma gcd_div_swap : forall a b,
+ (a / gcd a b) * b == a * (b / gcd a b).
+Proof.
+ intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
+ apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
+ now rewrite lcm_equiv1, <-lcm_equiv2.
+Qed.
+
+Lemma divide_lcm_l : forall a b, (a | lcm a b).
+Proof.
+ unfold lcm. intros a b. apply divide_abs_r, divide_factor_l.
+Qed.
+
+Lemma divide_lcm_r : forall a b, (b | lcm a b).
+Proof.
+ unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap.
+ apply divide_factor_r.
+Qed.
+
+Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
+Proof.
+ intros a b c Ha Hb (c',Hc). exists c'.
+ now rewrite <- divide_div_mul_exact, <- Hc.
+Qed.
+
+Lemma lcm_least : forall a b c,
+ (a | c) -> (b | c) -> (lcm a b | c).
+Proof.
+ intros a b c Ha Hb. unfold lcm. apply divide_abs_l.
+ destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
+ apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
+ assert (Ga := gcd_divide_l a b).
+ assert (Gb := gcd_divide_r a b).
+ set (g:=gcd a b) in *.
+ assert (Ha' := divide_div g a c NEQ Ga Ha).
+ assert (Hb' := divide_div g b c NEQ Gb Hb).
+ destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'.
+ apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
+ destruct Hb' as (b',Hb').
+ exists b'.
+ rewrite mul_shuffle3, <- Hb'.
+ rewrite (proj2 (div_exact c g NEQ)).
+ rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv.
+ symmetry. apply div_exact; trivial.
+ apply mod_divide; trivial.
+ apply mod_divide; trivial. transitivity a; trivial.
+Qed.
+
+Lemma lcm_nonneg : forall a b, 0 <= lcm a b.
+Proof.
+ intros a b. unfold lcm. apply abs_nonneg.
+Qed.
+
+Lemma lcm_comm : forall a b, lcm a b == lcm b a.
+Proof.
+ intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
+ now rewrite <- gcd_div_swap.
+Qed.
+
+Lemma lcm_divide_iff : forall n m p,
+  (lcm n m | p) <-> (n | p) /\ (m | p).
+Proof.
+ intros. split. split.
+ transitivity (lcm n m); trivial using divide_lcm_l.
+ transitivity (lcm n m); trivial using divide_lcm_r.
+ intros (H,H'). now apply lcm_least.
+Qed.
+
+Lemma lcm_unique : forall n m p,
+ 0<=p -> (n|p) -> (m|p) ->
+ (forall q, (n|q) -> (m|q) -> (p|q)) ->
+ lcm n m == p.
+Proof.
+ intros n m p Hp Hn Hm H.
+ apply divide_antisym_nonneg; trivial. apply lcm_nonneg.
+ now apply lcm_least.
+ apply H. apply divide_lcm_l. apply divide_lcm_r.
+Qed.
+
+Lemma lcm_unique_alt : forall n m p, 0<=p ->
+ (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
+ lcm n m == p.
+Proof.
+ intros n m p Hp H.
+ apply lcm_unique; trivial.
+ apply H, divide_refl.
+ apply H, divide_refl.
+ intros. apply H. now split.
+Qed.
+
+Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
+Proof.
+ intros. apply lcm_unique_alt; try apply lcm_nonneg.
+ intros. now rewrite !lcm_divide_iff, and_assoc.
+Qed.
+
+Lemma lcm_0_l : forall n, lcm 0 n == 0.
+Proof.
+ intros. apply lcm_unique; trivial. order.
+ apply divide_refl.
+ apply divide_0_r.
+Qed.
+
+Lemma lcm_0_r : forall n, lcm n 0 == 0.
+Proof.
+ intros. now rewrite lcm_comm, lcm_0_l.
+Qed.
+
+Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n.
+Proof.
+ intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl.
+Qed.
+
+Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n.
+Proof.
+ intros. now rewrite lcm_comm, lcm_1_l_nonneg.
+Qed.
+
+Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n.
+Proof.
+ intros. apply lcm_unique; trivial using divide_refl.
+Qed.
+
+Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
+Proof.
+ intros. split.
+ intros EQ.
+ apply eq_mul_0.
+ apply divide_0_l. rewrite <- EQ. apply lcm_least.
+  apply divide_factor_l. apply divide_factor_r.
+ destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
+Qed.
+
+Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m.
+Proof.
+ intros n m Hm H. apply lcm_unique_alt; trivial.
+ intros q. split. split; trivial. now transitivity m.
+ now destruct 1.
+Qed.
+
+Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m).
+Proof.
+ intros n m Hn. split. now apply divide_lcm_eq_r.
+ intros EQ. rewrite <- EQ. apply divide_lcm_l.
+Qed.
+
+Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m.
+Proof.
+ intros. apply lcm_unique_alt; try apply lcm_nonneg.
+ intros. rewrite divide_opp_l. apply lcm_divide_iff.
+Qed.
+
+Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m.
+Proof.
+ intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm.
+Qed.
+
+Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m.
+Proof.
+ intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H.
+ easy. apply lcm_opp_l.
+Qed.
+
+Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m.
+Proof.
+ intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm.
+Qed.
+
+Lemma lcm_1_l : forall n, lcm 1 n == abs n.
+Proof.
+ intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg.
+Qed.
+
+Lemma lcm_1_r : forall n, lcm n 1 == abs n.
+Proof.
+ intros. now rewrite lcm_comm, lcm_1_l.
+Qed.
+
+Lemma lcm_diag : forall n, lcm n n == abs n.
+Proof.
+ intros. rewrite <- lcm_abs_l, <- lcm_abs_r.
+ apply lcm_diag_nonneg, abs_nonneg.
+Qed.
+
+Lemma lcm_mul_mono_l :
+  forall n m p, lcm (p * n) (p * m) == abs p * lcm n m.
+Proof.
+ intros n m p.
+ destruct (eq_decidable p 0) as [Hp|Hp].
+  rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl.
+ destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
+  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
+  nzsimpl. rewrite lcm_0_l. now nzsimpl.
+ unfold lcm.
+ rewrite gcd_mul_mono_l.
+ rewrite !abs_mul, mul_assoc. f_equiv.
+ rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc.
+ rewrite div_mul_cancel_l; trivial.
+ rewrite divide_div_mul_exact; trivial. rewrite abs_mul.
+ rewrite <- (sgn_abs (sgn p)), sgn_sgn.
+ destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]].
+  rewrite EQ. now nzsimpl. order.
+  rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl.
+ apply gcd_divide_r.
+ contradict Hp. now apply abs_0_iff.
+Qed.
+
+Lemma lcm_mul_mono_l_nonneg :
+ forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m.
+Proof.
+ intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l.
+Qed.
+
+Lemma lcm_mul_mono_r :
+ forall n m p, lcm (n * p) (m * p) == lcm n m * abs p.
+Proof.
+ intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
+Qed.
+
+Lemma lcm_mul_mono_r_nonneg :
+ forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p.
+Proof.
+ intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r.
+Qed.
+
+Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
+ (gcd n m == 1 <-> lcm n m == abs (n*m)).
+Proof.
+ intros n m Hn Hm. split; intros H.
+ unfold lcm. rewrite H. now rewrite div_1_r.
+ unfold lcm in *.
+ rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff].
+ assert (H' := gcd_divide_r n m).
+ assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
+ apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
+ assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl).
+ rewrite <- (mul_1_l (abs (_/_))) in H.
+ rewrite H' in H at 3. rewrite abs_mul in H.
+ apply mul_cancel_r in H; [|now rewrite abs_0_iff].
+ rewrite abs_eq in H. order. apply gcd_nonneg.
+Qed.
+
+End ZLcmProp.
diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v
index 57be0f0e..3a8e1f38 100644
--- a/theories/Numbers/Integer/Abstract/ZLt.v
+++ b/theories/Numbers/Integer/Abstract/ZLt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZLt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZMul.
 
-Module ZOrderPropFunct (Import Z : ZAxiomsSig').
-Include ZMulPropFunct Z.
+Module ZOrderProp (Import Z : ZAxiomsMiniSig').
+Include ZMulProp Z.
 
 (** Instances of earlier theorems for m == 0 *)
 
@@ -70,12 +68,12 @@ Qed.
 
 Theorem lt_lt_pred : forall n m, n < m -> P n < m.
 Proof.
-intros; apply <- lt_pred_le; now apply lt_le_incl.
+intros; apply lt_pred_le; now apply lt_le_incl.
 Qed.
 
 Theorem le_le_pred : forall n m, n <= m -> P n <= m.
 Proof.
-intros; apply lt_le_incl; now apply <- lt_pred_le.
+intros; apply lt_le_incl; now apply lt_pred_le.
 Qed.
 
 Theorem lt_pred_lt : forall n m, n < P m -> n < m.
@@ -85,7 +83,7 @@ Qed.
 
 Theorem le_pred_lt : forall n m, n <= P m -> n <= m.
 Proof.
-intros; apply lt_le_incl; now apply <- lt_le_pred.
+intros; apply lt_le_incl; now apply lt_le_pred.
 Qed.
 
 Theorem pred_lt_mono : forall n m, n < m <-> P n < P m.
@@ -123,12 +121,12 @@ Proof.
 intro; apply lt_neq; apply lt_pred_l.
 Qed.
 
-Theorem lt_n1_r : forall n m, n < m -> m < 0 -> n < -(1).
+Theorem lt_m1_r : forall n m, n < m -> m < 0 -> n < -1.
 Proof.
-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.
+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 one_succ, opp_pred, opp_0.
 Qed.
 
-End ZOrderPropFunct.
+End ZOrderProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v
new file mode 100644
index 00000000..4e653fee
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v
@@ -0,0 +1,179 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import ZAxioms ZMulOrder GenericMinMax.
+
+(** * Properties of minimum and maximum specific to integer numbers *)
+
+Module Type ZMaxMinProp (Import Z : ZAxiomsMiniSig').
+Include ZMulOrderProp Z.
+
+(** The following results are concrete instances of [max_monotone]
+    and similar lemmas. *)
+
+(** Succ *)
+
+Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono.
+Qed.
+
+Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono.
+Qed.
+
+(** Pred *)
+
+Lemma pred_max_distr : forall n m, P (max n m) == max (P n) (P m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono.
+Qed.
+
+Lemma pred_min_distr : forall n m, P (min n m) == min (P n) (P m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?pred_le_mono.
+Qed.
+
+(** Add *)
+
+Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l.
+Qed.
+
+Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r.
+Qed.
+
+Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l.
+Qed.
+
+Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r.
+Qed.
+
+(** Opp *)
+
+Lemma opp_max_distr : forall n m, -(max n m) == min (-n) (-m).
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite max_r by trivial. symmetry. apply min_r. now rewrite <- opp_le_mono.
+ rewrite max_l by trivial. symmetry. apply min_l. now rewrite <- opp_le_mono.
+Qed.
+
+Lemma opp_min_distr : forall n m, -(min n m) == max (-n) (-m).
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite min_l by trivial. symmetry. apply max_l. now rewrite <- opp_le_mono.
+ rewrite min_r by trivial. symmetry. apply max_r. now rewrite <- opp_le_mono.
+Qed.
+
+(** Sub *)
+
+Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite min_l by trivial. apply max_l. now rewrite <- sub_le_mono_l.
+ rewrite min_r by trivial. apply max_r. now rewrite <- sub_le_mono_l.
+Qed.
+
+Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r.
+Qed.
+
+Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite max_r by trivial. apply min_r. now rewrite <- sub_le_mono_l.
+ rewrite max_l by trivial. apply min_l. now rewrite <- sub_le_mono_l.
+Qed.
+
+Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r.
+Qed.
+
+(** Mul *)
+
+Lemma mul_max_distr_nonneg_l : forall n m p, 0 <= p ->
+ max (p * n) (p * m) == p * max n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l.
+Qed.
+
+Lemma mul_max_distr_nonneg_r : forall n m p, 0 <= p ->
+ max (n * p) (m * p) == max n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r.
+Qed.
+
+Lemma mul_min_distr_nonneg_l : forall n m p, 0 <= p ->
+ min (p * n) (p * m) == p * min n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l.
+Qed.
+
+Lemma mul_min_distr_nonneg_r : forall n m p, 0 <= p ->
+ min (n * p) (m * p) == min n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r.
+Qed.
+
+Lemma mul_max_distr_nonpos_l : forall n m p, p <= 0 ->
+ max (p * n) (p * m) == p * min n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite min_l by trivial. rewrite max_l. reflexivity. now apply mul_le_mono_nonpos_l.
+ rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_l.
+Qed.
+
+Lemma mul_max_distr_nonpos_r : forall n m p, p <= 0 ->
+ max (n * p) (m * p) == min n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite min_l by trivial. rewrite max_l. reflexivity. now apply mul_le_mono_nonpos_r.
+ rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_r.
+Qed.
+
+Lemma mul_min_distr_nonpos_l : forall n m p, p <= 0 ->
+ min (p * n) (p * m) == p * max n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite max_r by trivial. rewrite min_r. reflexivity. now apply mul_le_mono_nonpos_l.
+ rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_l.
+Qed.
+
+Lemma mul_min_distr_nonpos_r : forall n m p, p <= 0 ->
+ min (n * p) (m * p) == max n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite max_r by trivial. rewrite min_r. reflexivity. now apply mul_le_mono_nonpos_r.
+ rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_r.
+Qed.
+
+End ZMaxMinProp.
diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v
index 83dc0e10..36f9c3d5 100644
--- a/theories/Numbers/Integer/Abstract/ZMul.v
+++ b/theories/Numbers/Integer/Abstract/ZMul.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZAdd.
 
-Module ZMulPropFunct (Import Z : ZAxiomsSig').
-Include ZAddPropFunct Z.
+Module ZMulProp (Import Z : ZAxiomsMiniSig').
+Include ZAddProp Z.
 
 (** A note on naming: right (correspondingly, left) distributivity
     happens when the sum is multiplied by a number on the right
@@ -41,7 +39,7 @@ Qed.
 
 Theorem mul_opp_l : forall n m, (- n) * m == - (n * m).
 Proof.
-intros n m. apply -> add_move_0_r.
+intros n m. apply add_move_0_r.
 now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l.
 Qed.
 
@@ -55,6 +53,11 @@ Proof.
 intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive.
 Qed.
 
+Theorem mul_opp_comm : forall n m, (- n) * m == n * (- m).
+Proof.
+intros n m. now rewrite mul_opp_l, <- mul_opp_r.
+Qed.
+
 Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p.
 Proof.
 intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l.
@@ -67,6 +70,6 @@ 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.
+End ZMulProp.
 
 
diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v
index 06a5d168..d0d64faa 100644
--- a/theories/Numbers/Integer/Abstract/ZMulOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,14 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZAddOrder.
 
-Module Type ZMulOrderPropFunct (Import Z : ZAxiomsSig').
-Include ZAddOrderPropFunct Z.
-
-Local Notation "- 1" := (-(1)).
+Module Type ZMulOrderProp (Import Z : ZAxiomsMiniSig').
+Include ZAddOrderProp Z.
 
 Theorem mul_lt_mono_nonpos :
   forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q ->  m * q < n * p.
@@ -94,18 +90,11 @@ Qed.
 
 Notation mul_nonpos := le_mul_0 (only parsing).
 
-Theorem le_0_square : forall n, 0 <= n * n.
-Proof.
-intro n; destruct (neg_nonneg_cases n).
-apply lt_le_incl; now apply mul_neg_neg.
-now apply mul_nonneg_nonneg.
-Qed.
-
-Notation square_nonneg := le_0_square (only parsing).
+Notation le_0_square := square_nonneg (only parsing).
 
 Theorem nlt_square_0 : forall n, ~ n * n < 0.
 Proof.
-intros n H. apply -> lt_nge in H. apply H. apply square_nonneg.
+intros n H. apply lt_nge in H. apply H. apply square_nonneg.
 Qed.
 
 Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m.
@@ -120,42 +109,38 @@ Qed.
 
 Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n.
 Proof.
-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.
+intros n m H1 H2. destruct (le_gt_cases n 0); [|order].
+destruct (lt_ge_cases m n) as [LE|GT]; trivial.
+apply square_le_mono_nonpos in GT; order.
 Qed.
 
 Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n.
 Proof.
-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.
+intros n m H1 H2. destruct (le_gt_cases n 0); [|order].
+destruct (le_gt_cases m n) as [LE|GT]; trivial.
+apply square_lt_mono_nonpos in GT; order.
 Qed.
 
 Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m.
 Proof.
-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.
+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 lt_mul_n1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1.
+Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1.
 Proof.
-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.
+intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1.
+rewrite mul_1_l in H1. now apply lt_m1_r with m.
 assumption.
 Qed.
 
-Theorem lt_mul_n1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1.
+Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1.
 Proof.
-intros n m H1 H2. apply -> (mul_lt_mono_pos_r m) in H1.
+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).
+apply opp_neg_pos in H2. now apply lt_m1_r with (- m).
 assumption.
 Qed.
 
@@ -163,39 +148,33 @@ 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 (lt_trichotomy m 0) as [H1 | [H1 | H1]].
-left. now apply lt_mul_n1_neg.
+left. now apply lt_mul_m1_neg.
 right; left; now rewrite H1, mul_0_r.
 right; right; now apply lt_1_mul_pos.
 Qed.
 
-Theorem lt_n1_mul_r : forall n m, n < -1 ->
+Theorem lt_m1_mul_r : forall n m, n < -1 ->
  n * m < -1 \/ n * m == 0 \/ 1 < n * m.
 Proof.
 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.
+left. now apply lt_mul_m1_pos.
 Qed.
 
 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 <- 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.
+assert (F := lt_m1_0).
 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 neq_succ_diag_l. false_hyp H lt_irrefl.
-intros; now left.
-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.
+(* n = 0 *)
+intros m. nzsimpl. now left.
+(* 0 < n, proving P n /\ P (-n) *)
+intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn.
+le_elim Hn; split; intros m H.
+destruct (lt_1_mul_l n m) as [|[|]]; order'.
+rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'.
+now left.
+intros; right. now f_equiv.
 Qed.
 
 Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n).
@@ -229,5 +208,9 @@ apply mul_lt_mono_nonneg.
 now apply lt_le_incl. assumption. apply le_0_1. assumption.
 Qed.
 
-End ZMulOrderPropFunct.
+(** Alternative name : *)
+
+Definition mul_eq_1 := eq_mul_1.
+
+End ZMulOrderProp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v
new file mode 100644
index 00000000..b364ec3f
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZParity.v
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool ZMulOrder NZParity.
+
+(** Some more properties of [even] and [odd]. *)
+
+Module Type ZParityProp (Import Z : ZAxiomsSig')
+                        (Import ZP : ZMulOrderProp Z).
+
+Include NZParityProp Z Z ZP.
+
+Lemma odd_pred : forall n, odd (P n) = even n.
+Proof.
+ intros. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ.
+Qed.
+
+Lemma even_pred : forall n, even (P n) = odd n.
+Proof.
+ intros. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ.
+Qed.
+
+Lemma even_opp : forall n, even (-n) = even n.
+Proof.
+ assert (H : forall n, Even n -> Even (-n)).
+  intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv.
+ intros. rewrite eq_iff_eq_true, !even_spec.
+ split. rewrite <- (opp_involutive n) at 2. apply H.
+ apply H.
+Qed.
+
+Lemma odd_opp : forall n, odd (-n) = odd n.
+Proof.
+ intros. rewrite <- !negb_even. now rewrite even_opp.
+Qed.
+
+Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m).
+Proof.
+ intros. now rewrite <- add_opp_r, even_add, even_opp.
+Qed.
+
+Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m).
+Proof.
+ intros. now rewrite <- add_opp_r, odd_add, odd_opp.
+Qed.
+
+End ZParityProp.
diff --git a/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v
new file mode 100644
index 00000000..53d84dce
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZPow.v
@@ -0,0 +1,124 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Properties of the power function *)
+
+Require Import Bool ZAxioms ZMulOrder ZParity ZSgnAbs NZPow.
+
+Module Type ZPowProp
+ (Import A : ZAxiomsSig')
+ (Import B : ZMulOrderProp A)
+ (Import C : ZParityProp A B)
+ (Import D : ZSgnAbsProp A B).
+
+ Include NZPowProp A A B.
+
+(** Parity of power *)
+
+Lemma even_pow : forall a b, 0<b -> even (a^b) = even a.
+Proof.
+ intros a b Hb. apply lt_ind with (4:=Hb). solve_proper.
+ now nzsimpl.
+ clear b Hb. intros b Hb IH. nzsimpl; [|order].
+ rewrite even_mul, IH. now destruct (even a).
+Qed.
+
+Lemma odd_pow : forall a b, 0<b -> odd (a^b) = odd a.
+Proof.
+ intros. now rewrite <- !negb_even, even_pow.
+Qed.
+
+(** Properties of power of negative numbers *)
+
+Lemma pow_opp_even : forall a b, Even b -> (-a)^b == a^b.
+Proof.
+ intros a b (c,H). rewrite H.
+ destruct (le_gt_cases 0 c).
+ rewrite 2 pow_mul_r by order'.
+ rewrite 2 pow_2_r.
+ now rewrite mul_opp_opp.
+ assert (2*c < 0) by (apply mul_pos_neg; order').
+ now rewrite !pow_neg_r.
+Qed.
+
+Lemma pow_opp_odd : forall a b, Odd b -> (-a)^b == -(a^b).
+Proof.
+ intros a b (c,H). rewrite H.
+ destruct (le_gt_cases 0 c) as [LE|GT].
+ assert (0 <= 2*c) by (apply mul_nonneg_nonneg; order').
+ rewrite add_1_r, !pow_succ_r; trivial.
+ rewrite pow_opp_even by (now exists c).
+ apply mul_opp_l.
+ apply double_above in GT. rewrite mul_0_r in GT.
+ rewrite !pow_neg_r by trivial. now rewrite opp_0.
+Qed.
+
+Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b.
+Proof.
+ intros. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ.
+ reflexivity.
+ symmetry. now apply pow_opp_even.
+Qed.
+
+Lemma pow_even_nonneg : forall a b, Even b -> 0 <= a^b.
+Proof.
+ intros. rewrite pow_even_abs by trivial.
+ apply pow_nonneg, abs_nonneg.
+Qed.
+
+Lemma pow_odd_abs_sgn : forall a b, Odd b -> a^b == sgn a * (abs a)^b.
+Proof.
+ intros a b H.
+ destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
+ nzsimpl.
+ rewrite abs_eq; order.
+ rewrite <- EQ'. nzsimpl.
+ destruct (le_gt_cases 0 b).
+ apply pow_0_l.
+ assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0).
+ order.
+ now rewrite pow_neg_r.
+ rewrite abs_neq by order.
+ rewrite pow_opp_odd; trivial.
+ now rewrite mul_opp_opp, mul_1_l.
+Qed.
+
+Lemma pow_odd_sgn : forall a b, 0<=b -> Odd b -> sgn (a^b) == sgn a.
+Proof.
+ intros a b Hb H.
+ destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
+ apply sgn_pos. apply pow_pos_nonneg; trivial.
+ rewrite <- EQ'. rewrite pow_0_l. apply sgn_0.
+ assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0).
+ order.
+ apply sgn_neg.
+ rewrite <- (opp_involutive a). rewrite pow_opp_odd by trivial.
+ apply opp_neg_pos.
+ apply pow_pos_nonneg; trivial.
+ now apply opp_pos_neg.
+Qed.
+
+Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b.
+Proof.
+ intros a b.
+ destruct (Even_or_Odd b).
+ rewrite pow_even_abs by trivial.
+ apply abs_eq, pow_nonneg, abs_nonneg.
+ rewrite pow_odd_abs_sgn by trivial.
+ rewrite abs_mul.
+ destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
+ rewrite (sgn_pos a), (abs_eq 1), mul_1_l by order'.
+ apply abs_eq, pow_nonneg, abs_nonneg.
+ rewrite <- Ha, sgn_0, abs_0, mul_0_l.
+ symmetry. apply pow_0_l'. intro Hb. rewrite Hb in H.
+ apply (Even_Odd_False 0); trivial. exists 0; now nzsimpl.
+ rewrite (sgn_neg a), abs_opp, (abs_eq 1), mul_1_l by order'.
+ apply abs_eq, pow_nonneg, abs_nonneg.
+Qed.
+
+End ZPowProp.
diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v
index ae7c3209..c0455196 100644
--- a/theories/Numbers/Integer/Abstract/ZProperties.v
+++ b/theories/Numbers/Integer/Abstract/ZProperties.v
@@ -1,24 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Export ZAxioms ZMaxMin ZSgnAbs ZParity ZPow ZDivTrunc ZDivFloor
+ ZGcd ZLcm NZLog NZSqrt ZBits.
 
-Require Export ZAxioms ZMulOrder ZSgnAbs.
-
-(** 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].
-*)
-
-Module Type ZPropSig (Z:ZAxiomsExtSig) :=
- ZMulOrderPropFunct Z <+ ZSgnAbsPropSig Z.
-
-Module ZPropFunct (Z:ZAxiomsExtSig) <: ZPropSig Z.
- Include ZPropSig Z.
-End ZPropFunct.
+(** This functor summarizes all known facts about Z. *)
 
+Module Type ZProp (Z:ZAxiomsSig) :=
+ ZMaxMinProp Z <+ ZSgnAbsProp Z <+ ZParityProp Z <+ ZPowProp Z
+ <+ NZSqrtProp Z Z <+ NZSqrtUpProp Z Z
+ <+ NZLog2Prop Z Z Z <+ NZLog2UpProp Z Z Z
+ <+ ZDivProp Z <+ ZQuotProp Z <+ ZGcdProp Z <+ ZLcmProp Z
+ <+ ZBitsProp Z.
diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
index cecaa6a3..b2f6cc84 100644
--- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v
+++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
@@ -1,25 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Export ZMulOrder.
+(** Properties of [abs] and [sgn] *)
 
-(** 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.
+Require Import ZMulOrder.
 
 (** Since we already have [max], we could have defined [abs]. *)
 
-Module GenericAbs (Import Z : ZAxiomsSig')
-                  (Import ZP : ZMulOrderPropFunct Z) <: HasAbs Z.
+Module GenericAbs (Import Z : ZAxiomsMiniSig')
+                  (Import ZP : ZMulOrderProp Z) <: HasAbs Z.
  Definition abs n := max n (-n).
  Lemma abs_eq : forall n, 0<=n -> abs n == n.
  Proof.
@@ -35,37 +29,28 @@ Module GenericAbs (Import Z : ZAxiomsSig')
  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 ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare.
+Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare.
 
 Module Type GenericSgn (Import Z : ZDecAxiomsSig')
-                       (Import ZP : ZMulOrderPropFunct Z) <: HasSgn Z.
+                       (Import ZP : ZMulOrderProp Z) <: HasSgn Z.
  Definition sgn n :=
-  match compare 0 n with Eq => 0 | Lt => 1 | Gt => -(1) end.
+  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).
+ 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).
+(** Derived properties of [abs] and [sgn] *)
+
+Module Type ZSgnAbsProp (Import Z : ZAxiomsSig')
+                        (Import ZP : ZMulOrderProp Z).
 
 Ltac destruct_max n :=
  destruct (le_ge_cases 0 n);
@@ -183,6 +168,28 @@ Proof.
  rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp.
 Qed.
 
+Lemma abs_lt : forall a b, abs a < b <-> -b < a < b.
+Proof.
+ intros a b.
+ destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
+ split; try split; try destruct 1; try order.
+ apply lt_le_trans with 0; trivial. apply opp_neg_pos; order.
+ rewrite opp_lt_mono, opp_involutive.
+ split; try split; try destruct 1; try order.
+ apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
+Qed.
+
+Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b.
+Proof.
+ intros a b.
+ destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
+ split; try split; try destruct 1; try order.
+ apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
+ rewrite opp_le_mono, opp_involutive.
+ split; try split; try destruct 1; try order.
+ apply le_trans with 0. order. apply opp_nonpos_nonneg; order.
+Qed.
+
 (** Triangular inequality *)
 
 Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m.
@@ -249,7 +256,7 @@ Qed.
 Lemma sgn_spec : forall n,
   0 < n /\ sgn n == 1 \/
   0 == n /\ sgn n == 0 \/
-  0 > n /\ sgn n == -(1).
+  0 > n /\ sgn n == -1.
 Proof.
  intros n.
  destruct_sgn n; [left|right;left|right;right]; auto with relations.
@@ -264,7 +271,7 @@ 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.
+ 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.
 
@@ -272,16 +279,16 @@ 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.
+ 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.
+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.
+ 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.
+ intros. elim (lt_neq (-1) 0); auto with relations.
  rewrite opp_neg_pos. apply lt_0_1.
 Qed.
 
@@ -343,6 +350,15 @@ Proof.
  rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl.
 Qed.
 
-End ZSgnAbsPropSig.
+Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x.
+Proof.
+ intros.
+ destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
+ apply sgn_pos, lt_0_1.
+ now apply sgn_null.
+ apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1.
+Qed.
+
+End ZSgnAbsProp.
 
 
diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v
index 7df8909f..443777f5 100644
--- a/theories/Numbers/Integer/BigZ/BigZ.v
+++ b/theories/Numbers/Integer/BigZ/BigZ.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: BigZ.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export BigN.
 Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake.
 
@@ -21,77 +19,59 @@ Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake.
     - [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)
+    - [ZProp] adds all generic properties derived from [ZAxioms]
     - [MinMax*Properties] provides properties of [min] and [max]
 
 *)
 
+Delimit Scope bigZ_scope with bigZ.
 
-Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder :=
- ZMake.Make BigN <+ ZTypeIsZAxioms
- <+ !ZPropSig <+ !ZDivPropFunct <+ HasEqBool2Dec
- <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
+Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder.
+ Include ZMake.Make BigN [scope abstract_scope to bigZ_scope].
+ Bind Scope bigZ_scope with t t_.
+ Include ZTypeIsZAxioms
+ <+ ZProp [no inline]
+ <+ HasEqBool2Dec [no inline]
+ <+ MinMaxLogicalProperties [no inline]
+ <+ MinMaxDecProperties [no inline].
+End BigZ.
 
-(** Notations about [BigZ] *)
+(** For precision concerning the above scope handling, see comment in BigN *)
 
-Notation bigZ := BigZ.t.
+(** Notations about [BigZ] *)
 
-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_.
-(* 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 Open Scope bigZ_scope.
 
+Notation bigZ := BigZ.t.
+Bind Scope bigZ_scope with bigZ BigZ.t BigZ.t_.
+Arguments BigZ.Pos _%bigN.
+Arguments BigZ.Neg _%bigN.
 Local Notation "0" := BigZ.zero : bigZ_scope.
 Local Notation "1" := BigZ.one : bigZ_scope.
+Local Notation "2" := BigZ.two : 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.pow : bigZ_scope.
 Infix "?=" := BigZ.compare : bigZ_scope.
+Infix "=?" := BigZ.eqb (at level 70, no associativity) : bigZ_scope.
+Infix "<=?" := BigZ.leb (at level 70, no associativity) : bigZ_scope.
+Infix "<?" := BigZ.ltb (at level 70, no associativity) : 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.
+Notation "x != y" := (~x==y) (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 "x > y" := (y < x) (only parsing) : bigZ_scope.
+Notation "x >= y" := (y <= x) (only parsing) : bigZ_scope.
+Notation "x < y < z" := (x<y /\ y<z) : bigZ_scope.
+Notation "x < y <= z" := (x<y /\ y<=z) : bigZ_scope.
+Notation "x <= y < z" := (x<=y /\ y<z) : bigZ_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z) : bigZ_scope.
 Notation "[ i ]" := (BigZ.to_Z i) : bigZ_scope.
-Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigN_scope.
-
-Local Open Scope bigZ_scope.
+Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigZ_scope.
+Infix "÷" := BigZ.quot (at level 40, left associativity) : bigZ_scope.
 
 (** Some additional results about [BigZ] *)
 
@@ -135,24 +115,26 @@ symmetry. apply BigZ.add_opp_r.
 exact BigZ.add_opp_diag_r.
 Qed.
 
-Lemma BigZeqb_correct : forall x y, BigZ.eq_bool x y = true -> x==y.
+Lemma BigZeqb_correct : forall x y, (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.
+Definition BigZ_of_N n := BigZ.of_Z (Z_of_N n).
+
+Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq BigZ_of_N BigZ.pow.
 Proof.
 constructor.
-intros. red. rewrite BigZ.spec_power. unfold id.
-destruct Zpower_theory as [EQ]. rewrite EQ.
+intros. unfold BigZ.eq, BigZ_of_N. rewrite BigZ.spec_pow, BigZ.spec_of_Z.
+rewrite Zpower_theory.(rpow_pow_N).
 destruct n; simpl. reflexivity.
 induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto.
 Qed.
 
 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).
+ (fun a b => if 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).
+case Z.eqb_spec.
 BigZ.zify. auto with zarith.
 intros NEQ.
 generalize (BigZ.spec_div_eucl a b).
@@ -170,6 +152,7 @@ Ltac isBigZcst t :=
  | BigZ.Neg ?t => isBigNcst t
  | BigZ.zero => constr:true
  | BigZ.one => constr:true
+ | BigZ.two => constr:true
  | BigZ.minus_one => constr:true
  | _ => constr:false
  end.
@@ -180,16 +163,25 @@ Ltac BigZcst t :=
  | false => constr:NotConstant
  end.
 
+Ltac BigZ_to_N t :=
+ match t with
+ | BigZ.Pos ?t => BigN_to_N t
+ | BigZ.zero => constr:0%N
+ | BigZ.one => constr:1%N
+ | BigZ.two => constr:2%N
+ | _ => constr:NotConstant
+ end.
+
 (** Registration for the "ring" tactic *)
 
 Add Ring BigZr : BigZring
  (decidable BigZeqb_correct,
   constants [BigZcst],
-  power_tac BigZpower [Ncst],
+  power_tac BigZpower [BigZ_to_N],
   div BigZdiv).
 
 Section TestRing.
-Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
+Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + (y + 1*x)*x.
 Proof.
 intros. ring_simplify. reflexivity.
 Qed.
diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v
index 48db793c..0142b36b 100644
--- a/theories/Numbers/Integer/BigZ/ZMake.v
+++ b/theories/Numbers/Integer/BigZ/ZMake.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: ZMake.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import ZArith.
 Require Import BigNumPrelude.
 Require Import NSig.
@@ -31,8 +29,11 @@ Module Make (N:NType) <: ZType.
 
  Definition t := t_.
 
+ Bind Scope abstract_scope with t t_.
+
  Definition zero := Pos N.zero.
  Definition one  := Pos N.one.
+ Definition two := Pos N.two.
  Definition minus_one := Neg N.one.
 
  Definition of_Z x :=
@@ -66,6 +67,10 @@ Module Make (N:NType) <: ZType.
  exact N.spec_1.
  Qed.
 
+ Theorem spec_2: to_Z two = 2.
+ exact N.spec_2.
+ Qed.
+
  Theorem spec_m1: to_Z minus_one = -1.
  simpl; rewrite N.spec_1; auto.
  Qed.
@@ -104,21 +109,49 @@ Module Make (N:NType) <: ZType.
   exfalso. omega.
  Qed.
 
- Definition eq_bool x y :=
+ Definition eqb x y :=
   match compare x y with
   | Eq => true
   | _ => false
   end.
 
- Theorem spec_eq_bool:
-  forall x y, eq_bool x y = Zeq_bool (to_Z x) (to_Z y).
+ Theorem spec_eqb x y : eqb x y = Z.eqb (to_Z x) (to_Z y).
  Proof.
- unfold eq_bool, Zeq_bool; intros; rewrite spec_compare; reflexivity.
+ apply Bool.eq_iff_eq_true.
+ unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare.
+ split; [now destruct Z.compare | now intros ->].
  Qed.
 
  Definition lt n m := to_Z n < to_Z m.
  Definition le n m := to_Z n <= to_Z m.
 
+
+ Definition ltb (x y : t) : bool :=
+  match compare x y with
+  | Lt => true
+  | _  => false
+  end.
+
+ Theorem spec_ltb x y : ltb x y = Z.ltb (to_Z x) (to_Z y).
+ Proof.
+ apply Bool.eq_iff_eq_true.
+ rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare.
+ split; [now destruct Z.compare | now intros ->].
+ Qed.
+
+ Definition leb (x y : t) : bool :=
+  match compare x y with
+  | Gt => false
+  | _  => true
+  end.
+
+ Theorem spec_leb x y : leb x y = Z.leb (to_Z x) (to_Z y).
+ Proof.
+ apply Bool.eq_iff_eq_true.
+ rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare.
+ destruct Z.compare; split; try easy. now destruct 1.
+ Qed.
+
  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.
 
@@ -273,23 +306,23 @@ Module Make (N:NType) <: ZType.
  unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring.
  Qed.
 
- Definition power_pos x p :=
+ Definition pow_pos x p :=
   match x with
-  | Pos nx => Pos (N.power_pos nx p)
+  | Pos nx => Pos (N.pow_pos nx p)
   | Neg nx =>
     match p with
     | xH => x
-    | xO _ => Pos (N.power_pos nx p)
-    | xI _ => Neg (N.power_pos nx p)
+    | xO _ => Pos (N.pow_pos nx p)
+    | xI _ => Neg (N.pow_pos nx p)
     end
   end.
 
- Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n.
+ Theorem spec_pow_pos: forall x n, to_Z (pow_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 |];
-   try rewrite N.spec_power_pos; try ring.
+ unfold pow_pos, to_Z; intros [x | x] [p | p |];
+   try rewrite N.spec_pow_pos; try ring.
  assert (F: 0 <= 2 * Zpos p).
   assert (0 <= Zpos p); auto with zarith.
  rewrite Zpos_xI; repeat rewrite Zpower_exp; auto with zarith.
@@ -302,18 +335,47 @@ Module Make (N:NType) <: ZType.
  rewrite F0; ring.
  Qed.
 
- Definition power x n :=
+ Definition pow_N x n :=
   match n with
   | N0 => one
-  | Npos p => power_pos x p
+  | Npos p => pow_pos x p
+  end.
+
+ Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z_of_N n.
+ Proof.
+ destruct n; simpl. apply N.spec_1.
+ apply spec_pow_pos.
+ Qed.
+
+ Definition pow x y :=
+  match to_Z y with
+  | Z0 => one
+  | Zpos p => pow_pos x p
+  | Zneg p => zero
   end.
 
- Theorem spec_power: forall x n, to_Z (power x n) = to_Z x ^ Z_of_N n.
+ Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y.
  Proof.
- destruct n; simpl. rewrite N.spec_1; reflexivity.
- apply spec_power_pos.
+ intros. unfold pow. destruct (to_Z y); simpl.
+ apply N.spec_1.
+ apply spec_pow_pos.
+ apply N.spec_0.
  Qed.
 
+ Definition log2 x :=
+  match x with
+  | Pos nx => Pos (N.log2 nx)
+  | Neg nx => zero
+  end.
+
+ Theorem spec_log2: forall x, to_Z (log2 x) = Z.log2 (to_Z x).
+ Proof.
+  intros. destruct x as [p|p]; simpl. apply N.spec_log2.
+  rewrite N.spec_0.
+  destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ].
+  rewrite Z.log2_nonpos; auto with zarith.
+  now rewrite <- EQ.
+ Qed.
 
  Definition sqrt x :=
   match x with
@@ -321,15 +383,14 @@ Module Make (N:NType) <: ZType.
   | Neg nx => Neg N.zero
   end.
 
- Theorem spec_sqrt: forall x, 0 <= to_Z x ->
-   to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2.
+ Theorem spec_sqrt: forall x, to_Z (sqrt x) = Z.sqrt (to_Z x).
  Proof.
- unfold to_Z, sqrt; intros [x | x] H.
-   exact (N.spec_sqrt x).
- replace (N.to_Z x) with 0.
-   rewrite N.spec_0; simpl Zpower; unfold Zpower_pos, iter_pos;
-    auto with zarith.
- generalize (N.spec_pos x); auto with zarith.
+  destruct x as [p|p]; simpl.
+  apply N.spec_sqrt.
+  rewrite N.spec_0.
+  destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ].
+  rewrite Z.sqrt_neg; auto with zarith.
+  now rewrite <- EQ.
  Qed.
 
  Definition div_eucl x y :=
@@ -339,12 +400,12 @@ Module Make (N:NType) <: ZType.
     (Pos q, Pos r)
   | Pos nx, Neg ny =>
     let (q, r) := N.div_eucl nx ny in
-    if N.eq_bool N.zero r
+    if N.eqb 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
-    if N.eq_bool N.zero r
+    if N.eqb N.zero r
     then (Neg q, zero)
     else (Neg (N.succ q), Pos (N.sub ny r))
   | Neg nx, Neg ny =>
@@ -368,32 +429,32 @@ Module Make (N:NType) <: ZType.
  (* 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;
+ try (injection 1; intros Hr Hq; rewrite N.spec_eqb, 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'.
+ rewrite N.spec_eqb, N.spec_0, Hr'.
  break_nonneg r pr EQr.
  subst; simpl. rewrite N.spec_0; auto.
- subst. lazy iota beta delta [Zeq_bool Zcompare].
+ subst. lazy iota beta delta [Z.eqb].
  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;
+ try (injection 1; intros Hr Hq; rewrite N.spec_eqb, 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'.
+ rewrite N.spec_eqb, N.spec_0, Hr'.
  break_nonneg r pr EQr.
  subst; simpl. rewrite N.spec_0; auto.
- subst. lazy iota beta delta [Zeq_bool Zcompare].
+ subst. lazy iota beta delta [Z.eqb].
  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).
@@ -422,6 +483,50 @@ Module Make (N:NType) <: ZType.
  intros q r q11 r1 H; injection H; auto.
  Qed.
 
+ Definition quot x y :=
+  match x, y with
+  | Pos nx, Pos ny => Pos (N.div nx ny)
+  | Pos nx, Neg ny => Neg (N.div nx ny)
+  | Neg nx, Pos ny => Neg (N.div nx ny)
+  | Neg nx, Neg ny => Pos (N.div nx ny)
+  end.
+
+ Definition rem x y :=
+  if eqb y zero then x
+  else
+    match x, y with
+      | Pos nx, Pos ny => Pos (N.modulo nx ny)
+      | Pos nx, Neg ny => Pos (N.modulo nx ny)
+      | Neg nx, Pos ny => Neg (N.modulo nx ny)
+      | Neg nx, Neg ny => Neg (N.modulo nx ny)
+    end.
+
+ Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y).
+ Proof.
+  intros [x|x] [y|y]; simpl; symmetry; rewrite N.spec_div;
+  (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *)
+  destruct (Z.eq_dec (N.to_Z y) 0) as [EQ|NEQ];
+    try (rewrite EQ; now destruct (N.to_Z x));
+  rewrite ?Z.quot_opp_r, ?Z.quot_opp_l, ?Z.opp_involutive, ?Z.opp_inj_wd;
+  trivial; apply Z.quot_div_nonneg;
+   generalize (N.spec_pos x) (N.spec_pos y); Z.order.
+ Qed.
+
+ Lemma spec_rem : forall x y,
+   to_Z (rem x y) = Z.rem (to_Z x) (to_Z y).
+ Proof.
+  intros x y. unfold rem. rewrite spec_eqb, spec_0.
+  case Z.eqb_spec; intros Hy.
+  (* Nota: we rely here on [Z.rem a 0 = a] *)
+  rewrite Hy. now destruct (to_Z x).
+  destruct x as [x|x], y as [y|y]; simpl in *; symmetry;
+   rewrite ?Z.eq_opp_l, ?Z.opp_0 in Hy;
+   rewrite N.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive,
+    ?Z.opp_inj_wd;
+   trivial; apply Z.rem_mod_nonneg;
+    generalize (N.spec_pos x) (N.spec_pos y); Z.order.
+ Qed.
+
  Definition gcd x y :=
   match x, y with
   | Pos nx, Pos ny => Pos (N.gcd nx ny)
@@ -453,4 +558,204 @@ Module Make (N:NType) <: ZType.
  rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith.
  Qed.
 
+ Definition even z :=
+  match z with
+   | Pos n => N.even n
+   | Neg n => N.even n
+  end.
+
+ Definition odd z :=
+  match z with
+   | Pos n => N.odd n
+   | Neg n => N.odd n
+  end.
+
+ Lemma spec_even : forall z, even z = Zeven_bool (to_Z z).
+ Proof.
+  intros [n|n]; simpl; rewrite N.spec_even; trivial.
+  destruct (N.to_Z n) as [|p|p]; now try destruct p.
+ Qed.
+
+ Lemma spec_odd : forall z, odd z = Zodd_bool (to_Z z).
+ Proof.
+  intros [n|n]; simpl; rewrite N.spec_odd; trivial.
+  destruct (N.to_Z n) as [|p|p]; now try destruct p.
+ Qed.
+
+ Definition norm_pos z :=
+   match z with
+     | Pos _ => z
+     | Neg n => if N.eqb n N.zero then Pos n else z
+   end.
+
+ Definition testbit a n :=
+   match norm_pos n, norm_pos a with
+     | Pos p, Pos a => N.testbit a p
+     | Pos p, Neg a => negb (N.testbit (N.pred a) p)
+     | Neg p, _ => false
+   end.
+
+ Definition shiftl a n :=
+   match norm_pos a, n with
+     | Pos a, Pos n => Pos (N.shiftl a n)
+     | Pos a, Neg n => Pos (N.shiftr a n)
+     | Neg a, Pos n => Neg (N.shiftl a n)
+     | Neg a, Neg n => Neg (N.succ (N.shiftr (N.pred a) n))
+   end.
+
+ Definition shiftr a n := shiftl a (opp n).
+
+ Definition lor a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (N.lor a b)
+     | Neg a, Pos b => Neg (N.succ (N.ldiff (N.pred a) b))
+     | Pos a, Neg b => Neg (N.succ (N.ldiff (N.pred b) a))
+     | Neg a, Neg b => Neg (N.succ (N.land (N.pred a) (N.pred b)))
+   end.
+
+ Definition land a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (N.land a b)
+     | Neg a, Pos b => Pos (N.ldiff b (N.pred a))
+     | Pos a, Neg b => Pos (N.ldiff a (N.pred b))
+     | Neg a, Neg b => Neg (N.succ (N.lor (N.pred a) (N.pred b)))
+   end.
+
+ Definition ldiff a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (N.ldiff a b)
+     | Neg a, Pos b => Neg (N.succ (N.lor (N.pred a) b))
+     | Pos a, Neg b => Pos (N.land a (N.pred b))
+     | Neg a, Neg b => Pos (N.ldiff (N.pred b) (N.pred a))
+   end.
+
+ Definition lxor a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (N.lxor a b)
+     | Neg a, Pos b => Neg (N.succ (N.lxor (N.pred a) b))
+     | Pos a, Neg b => Neg (N.succ (N.lxor a (N.pred b)))
+     | Neg a, Neg b => Pos (N.lxor (N.pred a) (N.pred b))
+   end.
+
+ Definition div2 x := shiftr x one.
+
+ Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x.
+ Proof.
+  unfold Z.lnot, Zpred; auto with zarith.
+ Qed.
+
+ Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x.
+ Proof.
+  unfold Z.lnot, Zpred; auto with zarith.
+ Qed.
+
+ Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1.
+ Proof.
+  unfold Z.lnot, Zpred; auto with zarith.
+ Qed.
+
+ Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x.
+ Proof.
+  intros [x|x]; simpl; trivial.
+  rewrite N.spec_eqb, N.spec_0.
+  case Z.eqb_spec; simpl; auto with zarith.
+ Qed.
+
+ Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y ->
+  0 < N.to_Z y.
+ Proof.
+  intros [x|x] y; simpl; try easy.
+  rewrite N.spec_eqb, N.spec_0.
+  case Z.eqb_spec; simpl; try easy.
+  inversion 2. subst. generalize (N.spec_pos y); auto with zarith.
+ Qed.
+
+ Ltac destr_norm_pos x :=
+  rewrite <- (spec_norm_pos x);
+  let H := fresh in
+  let x' := fresh x in
+  assert (H := spec_norm_pos_pos x);
+  destruct (norm_pos x) as [x'|x'];
+   specialize (H x' (eq_refl _)) || clear H.
+
+ Lemma spec_testbit: forall x p, testbit x p = Z.testbit (to_Z x) (to_Z p).
+ Proof.
+  intros x p. unfold testbit.
+  destr_norm_pos p; simpl. destr_norm_pos x; simpl.
+  apply N.spec_testbit.
+  rewrite N.spec_testbit, N.spec_pred, Zmax_r by auto with zarith.
+  symmetry. apply Z.bits_opp. apply N.spec_pos.
+  symmetry. apply Z.testbit_neg_r; auto with zarith.
+ Qed.
+
+ Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Z.shiftl (to_Z x) (to_Z p).
+ Proof.
+  intros x p. unfold shiftl.
+  destr_norm_pos x; destruct p as [p|p]; simpl;
+   assert (Hp := N.spec_pos p).
+  apply N.spec_shiftl.
+  rewrite Z.shiftl_opp_r. apply N.spec_shiftr.
+  rewrite !N.spec_shiftl.
+  rewrite !Z.shiftl_mul_pow2 by apply N.spec_pos.
+  apply Zopp_mult_distr_l.
+  rewrite Z.shiftl_opp_r, N.spec_succ, N.spec_shiftr, N.spec_pred, Zmax_r
+   by auto with zarith.
+  now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2.
+ Qed.
+
+ Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Z.shiftr (to_Z x) (to_Z p).
+ Proof.
+  intros. unfold shiftr. rewrite spec_shiftl, spec_opp.
+  apply Z.shiftl_opp_r.
+ Qed.
+
+ Lemma spec_land: forall x y, to_Z (land x y) = Z.land (to_Z x) (to_Z y).
+ Proof.
+  intros x y. unfold land.
+  destr_norm_pos x; destr_norm_pos y; simpl;
+   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
+    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
+  now rewrite Z.ldiff_land, Zlnot_alt2.
+  now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2.
+  now rewrite Z.lnot_lor, !Zlnot_alt2.
+ Qed.
+
+ Lemma spec_lor: forall x y, to_Z (lor x y) = Z.lor (to_Z x) (to_Z y).
+ Proof.
+  intros x y. unfold lor.
+  destr_norm_pos x; destr_norm_pos y; simpl;
+   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
+    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
+  now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2.
+  now rewrite Z.lnot_ldiff, Zlnot_alt2.
+  now rewrite Z.lnot_land, !Zlnot_alt2.
+ Qed.
+
+ Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Z.ldiff (to_Z x) (to_Z y).
+ Proof.
+  intros x y. unfold ldiff.
+  destr_norm_pos x; destr_norm_pos y; simpl;
+   rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor,
+    ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith.
+  now rewrite Z.ldiff_land, Zlnot_alt3.
+  now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2.
+  now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3.
+ Qed.
+
+ Lemma spec_lxor: forall x y, to_Z (lxor x y) = Z.lxor (to_Z x) (to_Z y).
+ Proof.
+  intros x y. unfold lxor.
+  destr_norm_pos x; destr_norm_pos y; simpl;
+   rewrite ?N.spec_succ, ?N.spec_lxor, ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1;
+   auto with zarith.
+  now rewrite !Z.lnot_lxor_r, Zlnot_alt2.
+  now rewrite !Z.lnot_lxor_l, Zlnot_alt2.
+  now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2.
+ Qed.
+
+ Lemma spec_div2: forall x, to_Z (div2 x) = Z.div2 (to_Z x).
+ Proof.
+  intros x. unfold div2. now rewrite spec_shiftr, Z.div2_spec, spec_1.
+ Qed.
+
 End Make.
diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v
index a7e05fee..d7c0abd8 100644
--- a/theories/Numbers/Integer/Binary/ZBinary.v
+++ b/theories/Numbers/Integer/Binary/ZBinary.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,103 +8,31 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZBinary.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-
-Require Import ZAxioms ZProperties.
-Require Import ZArith_base.
+Require Import ZAxioms ZProperties BinInt.
 
 Local Open Scope Z_scope.
 
-(** * Implementation of [ZAxiomsSig] by [BinInt.Z] *)
-
-Module ZBinAxiomsMod <: ZAxiomsExtSig.
-
-(** Bi-directional induction. *)
-
-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; 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.
+(** BinInt.Z is already implementing [ZAxiomsMiniSig] *)
 
-Definition min_l := Zmin_l.
-Definition min_r := Zmin_r.
-Definition max_l := Zmax_l.
-Definition max_r := Zmax_r.
+Module Z
+ <: ZAxiomsSig <: UsualOrderedTypeFull <: TotalOrder
+ <: UsualDecidableTypeFull
+ := BinInt.Z.
 
-(** Properties specific to integers, not natural numbers. *)
+(** * An [order] tactic for integers *)
 
-Program Instance opp_wd : Proper (eq==>eq) Zopp.
+Ltac z_order := Z.order.
 
-Definition succ_pred n := eq_sym (Zsucc_pred n).
-Definition opp_0 := Zopp_0.
-Definition opp_succ := Zopp_succ.
+(** 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]. *)
 
-(** 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 ZBinPropMod := ZPropFunct ZBinAxiomsMod.
+Section TestOrder.
+ Let test : forall x y, x<=y -> y<=x -> x=y.
+ Proof.
+ z_order.
+ Qed.
+End TestOrder.
 
 (** Z forms a ring *)
 
@@ -123,18 +51,3 @@ exact Zadd_opp_r.
 Qed.
 
 Add Ring ZR : Zring.*)
-
-
-
-(*
-Theorem eq_equiv_e : forall x y : Z, E x y <-> e x y.
-Proof.
-intros x y; unfold E, e, Zeq_bool; split; intro H.
-rewrite H; now rewrite Zcompare_refl.
-rewrite eq_true_unfold_pos in H.
-assert (H1 : (x ?= y) = Eq).
-case_eq (x ?= y); intro H1; rewrite H1 in H; simpl in H;
-[reflexivity | discriminate H | discriminate H].
-now apply Zcompare_Eq_eq.
-Qed.
-*)
diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
index ea3d9ad9..dbcc1961 100644
--- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v
+++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,25 +8,25 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZNatPairs.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import NProperties. (* The most complete file for N *)
-Require Export ZProperties. (* The most complete file for Z *)
+Require Import NSub ZAxioms.
 Require Export Ring.
 
 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.
+Local Open Scope pair_scope.
 
-Module ZPairsAxiomsMod (Import N : NAxiomsSig) <: ZAxiomsSig.
-Module Import NPropMod := NPropFunct N. (* Get all properties of N *)
+Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig.
+ Module Import NProp.
+   Include NSubProp N.
+ End NProp.
 
 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.
+Notation "1" := N.one : NScope.
+Notation "2" := N.two : NScope.
 Infix "+" := N.add : NScope.
 Infix "-" := N.sub : NScope.
 Infix "*" := N.mul : NScope.
@@ -44,6 +44,8 @@ Module Z.
 
 Definition t := (N.t * N.t)%type.
 Definition zero : t := (0, 0).
+Definition one : t := (1,0).
+Definition two : t := (2,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).
@@ -74,7 +76,8 @@ 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.
+Notation "1" := Z.one : ZScope.
+Notation "2" := Z.two : ZScope.
 Infix "+" := Z.add : ZScope.
 Infix "-" := Z.sub : ZScope.
 Infix "*" := Z.mul : ZScope.
@@ -128,15 +131,14 @@ Qed.
 
 Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub.
 Proof.
-intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp.
-apply add_wd, opp_wd; auto.
+intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. now do 2 f_equiv.
 Qed.
 
 Lemma mul_comm : forall n m, n*m == m*n.
 Proof.
 intros (n1,n2) (m1,m2); compute.
 rewrite (add_comm (m1*n2)%N).
-apply N.add_wd; apply N.add_wd; apply mul_comm.
+do 2 f_equiv; apply mul_comm.
 Qed.
 
 Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul.
@@ -160,20 +162,22 @@ Hypothesis A_wd : Proper (Z.eq==>iff) A.
 Theorem bi_induction :
   A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n.
 Proof.
+Open Scope NScope.
 intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *.
 destruct n as [n m].
-cut (forall p, A (p, 0%N)); [intro H1 |].
-cut (forall p, A (0%N, p)); [intro H2 |].
+cut (forall p, A (p, 0)); [intro H1 |].
+cut (forall p, A (0, p)); [intro H2 |].
 destruct (add_dichotomy n m) as [[p H] | [p H]].
-rewrite (A_wd (n, m) (0%N, p)) by (rewrite add_0_l; now rewrite add_comm).
+rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm).
 apply H2.
-rewrite (A_wd (n, m) (p, 0%N)) by now rewrite add_0_r. apply H1.
+rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1.
 induct p. assumption. intros p IH.
-apply -> (A_wd (0%N, p) (1%N, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l].
-now apply <- AS.
+apply (A_wd (0, p) (1, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l].
+rewrite one_succ in IH. now apply AS.
 induct p. assumption. intros p IH.
-replace 0%N with (snd (p, 0%N)); [| reflexivity].
-replace (N.succ p) with (N.succ (fst (p, 0%N))); [| reflexivity]. now apply -> AS.
+replace 0 with (snd (p, 0)); [| reflexivity].
+replace (N.succ p) with (N.succ (fst (p, 0))); [| reflexivity]. now apply -> AS.
+Close Scope NScope.
 Qed.
 
 End Induction.
@@ -190,6 +194,16 @@ Proof.
 intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl.
 Qed.
 
+Theorem one_succ : 1 == Z.succ 0.
+Proof.
+unfold Z.eq; simpl. now nzsimpl'.
+Qed.
+
+Theorem two_succ : 2 == Z.succ 1.
+Proof.
+unfold Z.eq; simpl. now nzsimpl'.
+Qed.
+
 Theorem opp_0 : - 0 == 0.
 Proof.
 unfold Z.opp, Z.eq; simpl. now nzsimpl.
@@ -298,6 +312,8 @@ Qed.
 Definition t := Z.t.
 Definition eq := Z.eq.
 Definition zero := Z.zero.
+Definition one := Z.one.
+Definition two := Z.two.
 Definition succ := Z.succ.
 Definition pred := Z.pred.
 Definition add := Z.add.
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v
index ff797e32..98ac5dfc 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSig.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,9 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: ZSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import ZArith Znumtheory.
+Require Import BinInt.
 
 Open Scope Z_scope.
 
@@ -35,11 +33,14 @@ Module Type ZType.
  Parameter spec_of_Z: forall x, to_Z (of_Z x) = x.
 
  Parameter compare : t -> t -> comparison.
- Parameter eq_bool : t -> t -> bool.
+ Parameter eqb : t -> t -> bool.
+ Parameter ltb : t -> t -> bool.
+ Parameter leb : t -> t -> bool.
  Parameter min : t -> t -> t.
  Parameter max : t -> t -> t.
  Parameter zero : t.
  Parameter one : t.
+ Parameter two : t.
  Parameter minus_one : t.
  Parameter succ : t -> t.
  Parameter add  : t -> t -> t.
@@ -48,22 +49,39 @@ Module Type ZType.
  Parameter opp : t -> t.
  Parameter mul : t -> t -> t.
  Parameter square : t -> t.
- Parameter power_pos : t -> positive -> t.
- Parameter power : t -> N -> t.
+ Parameter pow_pos : t -> positive -> t.
+ Parameter pow_N : t -> N -> t.
+ Parameter pow : t -> t -> t.
  Parameter sqrt : t -> t.
+ Parameter log2 : t -> t.
  Parameter div_eucl : t -> t -> t * t.
  Parameter div : t -> t -> t.
  Parameter modulo : t -> t -> t.
+ Parameter quot : t -> t -> t.
+ Parameter rem : t -> t -> t.
  Parameter gcd : t -> t -> t.
  Parameter sgn : t -> t.
  Parameter abs : t -> t.
+ Parameter even : t -> bool.
+ Parameter odd : t -> bool.
+ Parameter testbit : t -> t -> bool.
+ Parameter shiftr : t -> t -> t.
+ Parameter shiftl : t -> t -> t.
+ Parameter land : t -> t -> t.
+ Parameter lor : t -> t -> t.
+ Parameter ldiff : t -> t -> t.
+ Parameter lxor : t -> t -> t.
+ Parameter div2 : 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_compare: forall x y, compare x y = ([x] ?= [y]).
+ Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]).
+ Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]).
+ Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]).
+ Parameter spec_min : forall x y, [min x y] = Z.min [x] [y].
+ Parameter spec_max : forall x y, [max x y] = Z.max [x] [y].
  Parameter spec_0: [zero] = 0.
  Parameter spec_1: [one] = 1.
+ Parameter spec_2: [two] = 2.
  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].
@@ -72,17 +90,30 @@ Module Type ZType.
  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_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
+ Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n.
+ Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
+ Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x].
+ Parameter spec_log2: forall x, [log2 x] = Z.log2 [x].
  Parameter spec_div_eucl: forall x y,
-   let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
+   let (q,r) := div_eucl x y in ([q], [r]) = Z.div_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].
+ Parameter spec_quot: forall x y, [quot x y] = [x] ÷ [y].
+ Parameter spec_rem: forall x y, [rem x y] = Z.rem [x] [y].
+ Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b].
+ Parameter spec_sgn : forall x, [sgn x] = Z.sgn [x].
+ Parameter spec_abs : forall x, [abs x] = Z.abs [x].
+ Parameter spec_even : forall x, even x = Z.even [x].
+ Parameter spec_odd : forall x, odd x = Z.odd [x].
+ Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p].
+ Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p].
+ Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p].
+ Parameter spec_land: forall x y, [land x y] = Z.land [x] [y].
+ Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
+ Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
+ Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
+ Parameter spec_div2: forall x, [div2 x] = Z.div2 [x].
 
 End ZType.
 
@@ -90,12 +121,15 @@ Module Type ZType_Notation (Import Z:ZType).
  Notation "[ x ]" := (to_Z x).
  Infix "=="  := eq (at level 70).
  Notation "0" := zero.
+ Notation "1" := one.
+ Notation "2" := two.
  Infix "+" := add.
  Infix "-" := sub.
  Infix "*" := mul.
+ Infix "^" := pow.
  Notation "- x" := (opp x).
  Infix "<=" := le.
  Infix "<" := lt.
 End ZType_Notation.
 
-Module Type ZType' := ZType <+ ZType_Notation.
\ No newline at end of file
+Module Type ZType' := ZType <+ ZType_Notation.
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
index 879a17dd..bfbc063c 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
@@ -1,27 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZSigZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Import Bool ZArith OrdersFacts Nnat ZAxioms ZSig.
 
-Require Import ZArith ZAxioms ZDivFloor ZSig.
+(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *)
 
-(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig]
-
-    It also provides [sgn], [abs], [div], [mod]
-*)
-
-
-Module ZTypeIsZAxioms (Import Z : ZType').
+Module ZTypeIsZAxioms (Import ZZ : ZType').
 
 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
+ spec_0 spec_1 spec_2 spec_add spec_sub spec_pred spec_succ
+ spec_mul spec_opp spec_of_Z spec_div spec_modulo spec_square spec_sqrt
+ spec_compare spec_eqb spec_ltb spec_leb spec_max spec_min
+ spec_abs spec_sgn spec_pow spec_log2 spec_even spec_odd spec_gcd
+ spec_quot spec_rem spec_testbit spec_shiftl spec_shiftr
+ spec_land spec_lor spec_ldiff spec_lxor spec_div2
  : zsimpl.
 
 Ltac zsimpl := autorewrite with zsimpl.
@@ -44,9 +41,19 @@ Proof.
 intros. zify. auto with zarith.
 Qed.
 
+Theorem one_succ : 1 == succ 0.
+Proof.
+now zify.
+Qed.
+
+Theorem two_succ : 2 == succ 1.
+Proof.
+now zify.
+Qed.
+
 Section Induction.
 
-Variable A : Z.t -> Prop.
+Variable A : ZZ.t -> Prop.
 Hypothesis A_wd : Proper (eq==>iff) A.
 Hypothesis A0 : A 0.
 Hypothesis AS : forall n, A n <-> A (succ n).
@@ -131,36 +138,66 @@ Qed.
 
 (** Order *)
 
-Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Lemma eqb_eq x y : eqb x y = true <-> x == y.
+Proof.
+ zify. apply Z.eqb_eq.
+Qed.
+
+Lemma leb_le x y : leb x y = true <-> x <= y.
+Proof.
+ zify. apply Z.leb_le.
+Qed.
+
+Lemma ltb_lt x y : ltb x y = true <-> x < y.
 Proof.
- intros. zify. destruct (Zcompare_spec [x] [y]); auto.
+ zify. apply Z.ltb_lt.
 Qed.
 
-Definition eqb := eq_bool.
+Lemma compare_eq_iff n m : compare n m = Eq <-> n == m.
+Proof.
+ intros. zify. apply Z.compare_eq_iff.
+Qed.
+
+Lemma compare_lt_iff n m : compare n m = Lt <-> n < m.
+Proof.
+ intros. zify. reflexivity.
+Qed.
 
-Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
+Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m.
 Proof.
- intros. zify. symmetry. apply Zeq_is_eq_bool.
+ intros. zify. reflexivity.
 Qed.
 
+Lemma compare_antisym n m : compare m n = CompOpp (compare n m).
+Proof.
+ intros. zify. apply Z.compare_antisym.
+Qed.
+
+Include BoolOrderFacts ZZ ZZ ZZ [no inline].
+
 Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
 Proof.
-intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
+Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb.
 Proof.
-intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
+Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb.
 Proof.
-intros. zify. omega.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Theorem lt_irrefl : forall n, ~ n < n.
+Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb.
 Proof.
-intros. zify. omega.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
+Qed.
+
+Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
+Proof.
+intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
 Qed.
 
 Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
@@ -190,13 +227,15 @@ Qed.
 
 (** 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. zify. auto with zarith.
 Qed.
 
+(** Opp *)
+
+Program Instance opp_wd : Proper (eq ==> eq) opp.
+
 Theorem opp_0 : - 0 == 0.
 Proof.
 intros. zify. auto with zarith.
@@ -207,6 +246,8 @@ Proof.
 intros. zify. auto with zarith.
 Qed.
 
+(** Abs / Sgn *)
+
 Theorem abs_eq : forall n, 0 <= n -> abs n == n.
 Proof.
 intros n. zify. omega with *.
@@ -222,16 +263,102 @@ Proof.
 intros n. zify. omega with *.
 Qed.
 
-Theorem sgn_pos : forall n, 0<n -> sgn n == succ 0.
+Theorem sgn_pos : forall n, 0<n -> sgn n == 1.
 Proof.
 intros n. zify. omega with *.
 Qed.
 
-Theorem sgn_neg : forall n, n<0 -> sgn n == opp (succ 0).
+Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1.
 Proof.
 intros n. zify. omega with *.
 Qed.
 
+(** Power *)
+
+Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
+
+Lemma pow_0_r : forall a, a^0 == 1.
+Proof.
+ intros. now zify.
+Qed.
+
+Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
+Proof.
+ intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r.
+Qed.
+
+Lemma pow_neg_r : forall a b, b<0 -> a^b == 0.
+Proof.
+ intros a b. zify. intros Hb.
+ destruct [b]; reflexivity || discriminate.
+Qed.
+
+Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)).
+Proof.
+ intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id.
+Qed.
+
+Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p).
+Proof.
+ intros a b. red. now rewrite spec_pow_N, spec_pow_pos.
+Qed.
+
+(** Square *)
+
+Lemma square_spec n : square n == n * n.
+Proof.
+ now zify.
+Qed.
+
+(** Sqrt *)
+
+Lemma sqrt_spec : forall n, 0<=n ->
+ (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)).
+Proof.
+ intros n. zify. apply Z.sqrt_spec.
+Qed.
+
+Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0.
+Proof.
+ intros n. zify. apply Z.sqrt_neg.
+Qed.
+
+(** Log2 *)
+
+Lemma log2_spec : forall n, 0<n ->
+ 2^(log2 n) <= n /\ n < 2^(succ (log2 n)).
+Proof.
+ intros n. zify. apply Z.log2_spec.
+Qed.
+
+Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0.
+Proof.
+ intros n. zify. apply Z.log2_nonpos.
+Qed.
+
+(** Even / Odd *)
+
+Definition Even n := exists m, n == 2*m.
+Definition Odd n := exists m, n == 2*m+1.
+
+Lemma even_spec n : even n = true <-> Even n.
+Proof.
+ unfold Even. zify. rewrite Z.even_spec.
+ split; intros (m,Hm).
+ - exists (of_Z m). now zify.
+ - exists [m]. revert Hm. now zify.
+Qed.
+
+Lemma odd_spec n : odd n = true <-> Odd n.
+Proof.
+ unfold Odd. zify. rewrite Z.odd_spec.
+ split; intros (m,Hm).
+ - exists (of_Z m). now zify.
+ - exists [m]. revert Hm. now zify.
+Qed.
+
+(** Div / Mod *)
+
 Program Instance div_wd : Proper (eq==>eq==>eq) div.
 Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 
@@ -252,8 +379,149 @@ Proof.
 intros a b. zify. intros. apply Z_mod_neg; auto with zarith.
 Qed.
 
+Definition mod_bound_pos :
+ forall a b, 0<=a -> 0<b -> 0 <= modulo a b /\ modulo a b < b :=
+ fun a b _ H => mod_pos_bound a b H.
+
+(** Quot / Rem *)
+
+Program Instance quot_wd : Proper (eq==>eq==>eq) quot.
+Program Instance rem_wd : Proper (eq==>eq==>eq) rem.
+
+Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b.
+Proof.
+intros a b. zify. apply Z.quot_rem.
+Qed.
+
+Theorem rem_bound_pos :
+ forall a b, 0<=a -> 0<b -> 0 <= rem a b /\ rem a b < b.
+Proof.
+intros a b. zify. apply Z.rem_bound_pos.
+Qed.
+
+Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b).
+Proof.
+intros a b. zify. apply Z.rem_opp_l.
+Qed.
+
+Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b.
+Proof.
+intros a b. zify. apply Z.rem_opp_r.
+Qed.
+
+(** Gcd *)
+
+Definition divide n m := exists p, m == p*n.
+Local Notation "( x | y )" := (divide x y) (at level 0).
+
+Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m].
+Proof.
+ intros n m. split.
+ - intros (p,H). exists [p]. revert H; now zify.
+ - intros (z,H). exists (of_Z z). now zify.
+Qed.
+
+Lemma gcd_divide_l : forall n m, (gcd n m | n).
+Proof.
+ intros n m. apply spec_divide. zify. apply Z.gcd_divide_l.
+Qed.
+
+Lemma gcd_divide_r : forall n m, (gcd n m | m).
+Proof.
+ intros n m. apply spec_divide. zify. apply Z.gcd_divide_r.
+Qed.
+
+Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m).
+Proof.
+ intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest.
+Qed.
+
+Lemma gcd_nonneg : forall n m, 0 <= gcd n m.
+Proof.
+ intros. zify. apply Z.gcd_nonneg.
+Qed.
+
+(** Bitwise operations *)
+
+Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.
+
+Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true.
+Proof.
+ intros. zify. apply Z.testbit_odd_0.
+Qed.
+
+Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false.
+Proof.
+ intros. zify. apply Z.testbit_even_0.
+Qed.
+
+Lemma testbit_odd_succ : forall a n, 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a n.
+Proof.
+ intros a n. zify. apply Z.testbit_odd_succ.
+Qed.
+
+Lemma testbit_even_succ : forall a n, 0<=n ->
+ testbit (2*a) (succ n) = testbit a n.
+Proof.
+ intros a n. zify. apply Z.testbit_even_succ.
+Qed.
+
+Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false.
+Proof.
+ intros a n. zify. apply Z.testbit_neg_r.
+Qed.
+
+Lemma shiftr_spec : forall a n m, 0<=m ->
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ intros a n m. zify. apply Z.shiftr_spec.
+Qed.
+
+Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ intros a n m. zify. intros Hn H.
+ now apply Z.shiftl_spec_high.
+Qed.
+
+Lemma shiftl_spec_low : forall a n m, m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ intros a n m. zify. intros H. now apply Z.shiftl_spec_low.
+Qed.
+
+Lemma land_spec : forall a b n,
+ testbit (land a b) n = testbit a n && testbit b n.
+Proof.
+ intros a n m. zify. now apply Z.land_spec.
+Qed.
+
+Lemma lor_spec : forall a b n,
+ testbit (lor a b) n = testbit a n || testbit b n.
+Proof.
+ intros a n m. zify. now apply Z.lor_spec.
+Qed.
+
+Lemma ldiff_spec : forall a b n,
+ testbit (ldiff a b) n = testbit a n && negb (testbit b n).
+Proof.
+ intros a n m. zify. now apply Z.ldiff_spec.
+Qed.
+
+Lemma lxor_spec : forall a b n,
+ testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
+Proof.
+ intros a n m. zify. now apply Z.lxor_spec.
+Qed.
+
+Lemma div2_spec : forall a, div2 a == shiftr a 1.
+Proof.
+ intros a. zify. now apply Z.div2_spec.
+Qed.
+
 End ZTypeIsZAxioms.
 
-Module ZType_ZAxioms (Z : ZType)
- <: ZAxiomsSig <: ZDivSig <: HasCompare Z <: HasEqBool Z <: HasMinMax Z
- := Z <+ ZTypeIsZAxioms.
+Module ZType_ZAxioms (ZZ : ZType)
+ <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ
+ := ZZ <+ ZTypeIsZAxioms.
diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v
index 1d9a65dc..c1b7bafa 100644
--- a/theories/Numbers/NaryFunctions.v
+++ b/theories/Numbers/NaryFunctions.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 (*          Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008        *)
 (************************************************************************)
 
-(*i $Id: NaryFunctions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Local Open Scope type_scope.
 
 Require Import List.
diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v
index 782619f0..8bed3027 100644
--- a/theories/Numbers/NatInt/NZAdd.v
+++ b/theories/Numbers/NatInt/NZAdd.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,16 +8,15 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms NZBase.
 
-Module Type NZAddPropSig
- (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ).
+Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ).
 
 Hint Rewrite
  pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz.
+Hint Rewrite one_succ two_succ : nz'.
 Ltac nzsimpl := autorewrite with nz.
+Ltac nzsimpl' := autorewrite with nz nz'.
 
 Theorem add_0_r : forall n, n + 0 == n.
 Proof.
@@ -31,6 +30,11 @@ intros n m; nzinduct n. now nzsimpl.
 intro. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
+Theorem add_succ_comm : forall n m, S n + m == n + S m.
+Proof.
+intros n m. now rewrite add_succ_r, add_succ_l.
+Qed.
+
 Hint Rewrite add_0_r add_succ_r : nz.
 
 Theorem add_comm : forall n m, n + m == m + n.
@@ -41,14 +45,16 @@ Qed.
 
 Theorem add_1_l : forall n, 1 + n == S n.
 Proof.
-intro n; now nzsimpl.
+intro n; now nzsimpl'.
 Qed.
 
 Theorem add_1_r : forall n, n + 1 == S n.
 Proof.
-intro n; now nzsimpl.
+intro n; now nzsimpl'.
 Qed.
 
+Hint Rewrite add_1_l add_1_r : nz.
+
 Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p.
 Proof.
 intros n m p; nzinduct n. now nzsimpl.
@@ -78,13 +84,19 @@ Qed.
 
 Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p).
 Proof.
-intros n m p q.
-rewrite 2 add_assoc, add_shuffle0, add_cancel_r. apply add_shuffle0.
+intros n m p q. rewrite (add_comm p). apply add_shuffle1.
+Qed.
+
+Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p).
+Proof.
+intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p).
 Qed.
 
 Theorem sub_1_r : forall n, n - 1 == P n.
 Proof.
-intro n; now nzsimpl.
+intro n; now nzsimpl'.
 Qed.
 
-End NZAddPropSig.
+Hint Rewrite sub_1_r : nz.
+
+End NZAddProp.
diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v
index ed56cd8f..ee03e5f9 100644
--- a/theories/Numbers/NatInt/NZAddOrder.v
+++ b/theories/Numbers/NatInt/NZAddOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms NZBase NZMul NZOrder.
 
-Module Type NZAddOrderPropSig (Import NZ : NZOrdAxiomsSig').
-Include NZBasePropSig NZ <+ NZMulPropSig NZ <+ NZOrderPropSig NZ.
+Module Type NZAddOrderProp (Import NZ : NZOrdAxiomsSig').
+Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ.
 
 Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m.
 Proof.
@@ -30,7 +28,7 @@ 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 lt_trans with (m + p);
-[now apply -> add_lt_mono_r | now apply -> add_lt_mono_l].
+[now apply add_lt_mono_r | now apply add_lt_mono_l].
 Qed.
 
 Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m.
@@ -48,21 +46,21 @@ 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 le_trans with (m + p);
-[now apply -> add_le_mono_r | now apply -> add_le_mono_l].
+[now apply add_le_mono_r | now apply add_le_mono_l].
 Qed.
 
 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 lt_le_trans with (m + p);
-[now apply -> add_lt_mono_r | now apply -> add_le_mono_l].
+[now apply add_lt_mono_r | now apply add_le_mono_l].
 Qed.
 
 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 le_lt_trans with (m + p);
-[now apply -> add_le_mono_r | now apply -> add_lt_mono_l].
+[now apply add_le_mono_r | now apply add_lt_mono_l].
 Qed.
 
 Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m.
@@ -149,5 +147,22 @@ Proof.
 intros n m H; apply add_le_cases; now nzsimpl.
 Qed.
 
-End NZAddOrderPropSig.
+(** Substraction *)
+
+(** We can prove the existence of a subtraction of any number by
+    a smaller one *)
+
+Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p.
+Proof.
+ intros n m H. apply le_ind with (4:=H). solve_proper.
+ exists 0; nzsimpl; split; order.
+ clear m H. intros m H (p & EQ & LE). exists (S p).
+  split. nzsimpl. now f_equiv. now apply le_le_succ_r.
+Qed.
+
+(** For the moment, it doesn't seem possible to relate
+    this existing subtraction with [sub].
+*)
+
+End NZAddOrderProp.
 
diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v
index 33236cde..fcd98787 100644
--- a/theories/Numbers/NatInt/NZAxioms.v
+++ b/theories/Numbers/NatInt/NZAxioms.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (** Initial Author : Evgeny Makarov, INRIA, 2007 *)
 
-(*i $Id: NZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Equalities Orders NumPrelude GenericMinMax.
 
 (** Axiomatization of a domain with zero, successor, predecessor,
@@ -20,7 +18,7 @@ Require Export Equalities Orders NumPrelude GenericMinMax.
 *)
 
 Module Type ZeroSuccPred (Import T:Typ).
- Parameter Inline zero : t.
+ Parameter Inline(20) zero : t.
  Parameters Inline succ pred : t -> t.
 End ZeroSuccPred.
 
@@ -28,8 +26,6 @@ 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) :=
@@ -44,9 +40,33 @@ Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E).
     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 some more constants
+
+    Simply denoting "1" for (S 0) and so on works ok when implementing
+    by nat, but leaves some (Nsucc N0) when implementing by N.
+*)
+
+Module Type OneTwo (Import T:Typ).
+ Parameter Inline(20) one two : t.
+End OneTwo.
 
+Module Type OneTwoNotation (T:Typ)(Import NZ:OneTwo T).
+ Notation "1" := one.
+ Notation "2" := two.
+End OneTwoNotation.
+
+Module Type OneTwo' (T:Typ) := OneTwo T <+ OneTwoNotation T.
+
+Module Type IsOneTwo (E:Eq')(Z:ZeroSuccPred' E)(O:OneTwo' E).
+ Import E Z O.
+ Axiom one_succ : 1 == S 0.
+ Axiom two_succ : 2 == S 1.
+End IsOneTwo.
+
+Module Type NZDomainSig :=
+ EqualityType <+ ZeroSuccPred <+ IsNZDomain <+ OneTwo <+ IsOneTwo.
+Module Type NZDomainSig' :=
+ EqualityType' <+ ZeroSuccPred' <+ IsNZDomain <+ OneTwo' <+ IsOneTwo.
 
 (** Axiomatization of basic operations : [+] [-] [*] *)
 
@@ -117,3 +137,9 @@ Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare.
 Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare.
 Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare.
 
+(** A square function *)
+
+Module Type NZSquare (Import NZ : NZBasicFunsSig').
+ Parameter Inline square : t -> t.
+ Axiom square_spec : forall n, square n == n * n.
+End NZSquare.
diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v
index 119f8265..65b64635 100644
--- a/theories/Numbers/NatInt/NZBase.v
+++ b/theories/Numbers/NatInt/NZBase.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,14 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms.
 
-Module Type NZBasePropSig (Import NZ : NZDomainSig').
+Module Type NZBaseProp (Import NZ : NZDomainSig').
+
+(** An artificial scope meant to be substituted later *)
+
+Delimit Scope abstract_scope with abstract.
+Bind Scope abstract_scope with t.
 
 Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *)
 
@@ -50,7 +53,7 @@ Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2.
 Proof.
 intros; split.
 apply succ_inj.
-apply succ_wd.
+intros. now f_equiv.
 Qed.
 
 Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m.
@@ -63,7 +66,7 @@ left-inverse to the successor at this point *)
 
 Section CentralInduction.
 
-Variable A : predicate t.
+Variable A : t -> Prop.
 Hypothesis A_wd : Proper (eq==>iff) A.
 
 Theorem central_induction :
@@ -72,7 +75,7 @@ Theorem central_induction :
       forall n, A n.
 Proof.
 intros z Base Step; revert Base; pattern z; apply bi_induction.
-solve_predicate_wd.
+solve_proper.
 intro; now apply bi_induction.
 intro; pose proof (Step n); tauto.
 Qed.
@@ -85,5 +88,5 @@ Tactic Notation "nzinduct" ident(n) :=
 Tactic Notation "nzinduct" ident(n) constr(u) :=
   induction_maker n ltac:(apply central_induction with (z := u)).
 
-End NZBasePropSig.
+End NZBaseProp.
 
diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v
new file mode 100644
index 00000000..dc97eeb1
--- /dev/null
+++ b/theories/Numbers/NatInt/NZBits.v
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool NZAxioms NZMulOrder NZParity NZPow NZDiv NZLog.
+
+(** Axiomatization of some bitwise operations *)
+
+Module Type Bits (Import A : Typ).
+ Parameter Inline testbit : t -> t -> bool.
+ Parameters Inline shiftl shiftr land lor ldiff lxor : t -> t -> t.
+ Parameter Inline div2 : t -> t.
+End Bits.
+
+Module Type BitsNotation (Import A : Typ)(Import B : Bits A).
+ Notation "a .[ n ]" := (testbit a n) (at level 5, format "a .[ n ]").
+ Infix ">>" := shiftr (at level 30, no associativity).
+ Infix "<<" := shiftl (at level 30, no associativity).
+End BitsNotation.
+
+Module Type Bits' (A:Typ) := Bits A <+ BitsNotation A.
+
+Module Type NZBitsSpec
+ (Import A : NZOrdAxiomsSig')(Import B : Bits' A).
+
+ Declare Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.
+ Axiom testbit_odd_0 : forall a, (2*a+1).[0] = true.
+ Axiom testbit_even_0 : forall a, (2*a).[0] = false.
+ Axiom testbit_odd_succ : forall a n, 0<=n -> (2*a+1).[S n] = a.[n].
+ Axiom testbit_even_succ : forall a n, 0<=n -> (2*a).[S n] = a.[n].
+ Axiom testbit_neg_r : forall a n, n<0 -> a.[n] = false.
+
+ Axiom shiftr_spec : forall a n m, 0<=m -> (a >> n).[m] = a.[m+n].
+ Axiom shiftl_spec_high : forall a n m, 0<=m -> n<=m -> (a << n).[m] = a.[m-n].
+ Axiom shiftl_spec_low : forall a n m, m<n -> (a << n).[m] = false.
+
+ Axiom land_spec : forall a b n, (land a b).[n] = a.[n] && b.[n].
+ Axiom lor_spec : forall a b n, (lor a b).[n] = a.[n] || b.[n].
+ Axiom ldiff_spec : forall a b n, (ldiff a b).[n] = a.[n] && negb b.[n].
+ Axiom lxor_spec : forall a b n, (lxor a b).[n] = xorb a.[n] b.[n].
+ Axiom div2_spec : forall a, div2 a == a >> 1.
+
+End NZBitsSpec.
+
+Module Type NZBits (A:NZOrdAxiomsSig) := Bits A <+ NZBitsSpec A.
+Module Type NZBits' (A:NZOrdAxiomsSig) := Bits' A <+ NZBitsSpec A.
+
+(** In the functor of properties will also be defined:
+   - [setbit : t -> t -> t ] defined as [lor a (1<<n)].
+   - [clearbit : t -> t -> t ] defined as [ldiff a (1<<n)].
+   - [ones : t -> t], the number with [n] initial true bits,
+     corresponding to [2^n - 1].
+   - a logical complement [lnot]. For integer numbers it will
+     be a [t->t], doing a swap of all bits, while on natural
+     numbers, it will be a bounded complement [t->t->t], swapping
+     only the first [n] bits.
+*)
+
+(** For the moment, no shared properties about NZ here,
+  since properties and proofs for N and Z are quite different *)
diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v
index ba1c171e..bc109ace 100644
--- a/theories/Numbers/NatInt/NZDiv.v
+++ b/theories/Numbers/NatInt/NZDiv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,44 +12,36 @@ Require Import NZAxioms NZMulOrder.
 
 (** The first signatures will be common to all divisions over NZ, N and Z *)
 
-Module Type DivMod (Import T:Typ).
+Module Type DivMod (Import A : Typ).
  Parameters Inline div modulo : t -> t -> t.
 End DivMod.
 
-Module Type DivModNotation (T:Typ)(Import NZ:DivMod T).
+Module Type DivModNotation (A : Typ)(Import B : DivMod A).
  Infix "/" := div.
  Infix "mod" := modulo (at level 40, no associativity).
 End DivModNotation.
 
-Module Type DivMod' (T:Typ) := DivMod T <+ DivModNotation T.
+Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A.
 
-Module Type NZDivCommon (Import NZ : NZAxiomsSig')(Import DM : DivMod' NZ).
+Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A).
  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.
+ Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+End NZDivSpec.
 
 (** 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.
+    they impose on [modulo]. For NZ, we have only described the
+    behavior on positive numbers.
 *)
 
-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 (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A.
+Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A.
 
-Module Type NZDiv' (NZ:NZOrdAxiomsSig) := NZDiv NZ <+ DivModNotation NZ.
-
-Module NZDivPropFunct
- (Import NZ : NZOrdAxiomsSig')
- (Import NZP : NZMulOrderPropSig NZ)
- (Import NZD : NZDiv' NZ)
-.
+Module Type NZDivProp
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZDiv' A)
+ (Import C : NZMulOrderProp A).
 
 (** Uniqueness theorems *)
 
@@ -84,7 +76,7 @@ Theorem div_unique:
 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.
+apply mod_bound_pos; order.
 rewrite <- div_mod; order.
 Qed.
 
@@ -94,18 +86,21 @@ Theorem mod_unique:
 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.
+apply mod_bound_pos; order.
 rewrite <- div_mod; order.
 Qed.
 
+Theorem div_unique_exact a b q:
+ 0<=a -> 0<b -> a == b*q -> q == a/b.
+Proof.
+ intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split.
+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.
+intros. symmetry. apply div_unique_exact; nzsimpl; order.
 Qed.
 
 Lemma mod_same : forall a, 0<a -> a mod a == 0.
@@ -147,9 +142,7 @@ 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.
+intros. symmetry. apply div_unique_exact; nzsimpl; order'.
 Qed.
 
 Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
@@ -161,20 +154,19 @@ Qed.
 
 Lemma div_1_l: forall a, 1<a -> 1/a == 0.
 Proof.
-intros; apply div_small; split; auto. apply le_succ_diag_r.
+intros; apply div_small; split; auto. apply le_0_1.
 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.
+intros; apply mod_small; split; auto. apply le_0_1.
 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.
+intros; symmetry. apply div_unique_exact; trivial.
 apply mul_nonneg_nonneg; order.
-nzsimpl; apply mul_comm.
+apply mul_comm.
 Qed.
 
 Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
@@ -194,7 +186,7 @@ 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.
+apply lt_le_incl. destruct (mod_bound_pos a b); auto.
 rewrite lt_eq_cases; right.
 apply mod_small; auto.
 Qed.
@@ -216,7 +208,7 @@ 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).
+assert (MOD : a mod b < b) by (destruct (mod_bound_pos 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.
@@ -263,7 +255,7 @@ 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.
+rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
 Qed.
 
 (** [le] is compatible with a positive division. *)
@@ -282,8 +274,8 @@ 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.
+nzsimpl; destruct (mod_bound_pos b c); order.
+rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order.
 Qed.
 
 (** The following two properties could be used as specification of div *)
@@ -293,7 +285,7 @@ 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.
+rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
 Qed.
 
 Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
@@ -302,7 +294,7 @@ 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.
+destruct (mod_bound_pos a b); auto.
 Qed.
 
 
@@ -359,7 +351,7 @@ Proof.
  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.
+ rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order.
 Qed.
 
 
@@ -371,7 +363,7 @@ Proof.
  intros.
  symmetry.
  apply mod_unique with (a/c+b); auto.
- apply mod_bound; auto.
+ apply mod_bound_pos; auto.
  rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
  now rewrite mul_comm.
 Qed.
@@ -404,8 +396,8 @@ Proof.
  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.
+ apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order.
+ rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto.
  rewrite (div_mod a b) at 1 by order.
  rewrite mul_add_distr_r.
  rewrite add_cancel_r.
@@ -441,7 +433,7 @@ Qed.
 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.
+ intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff.
 Qed.
 
 Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
@@ -454,7 +446,7 @@ Proof.
  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.
+ apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto.
 Qed.
 
 Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
@@ -467,7 +459,7 @@ 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).
+ now destruct (mod_bound_pos b n).
 Qed.
 
 Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
@@ -478,7 +470,7 @@ Proof.
  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.
+ apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto.
 Qed.
 
 Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
@@ -491,7 +483,7 @@ 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).
+ now destruct (mod_bound_pos b n).
 Qed.
 
 Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
@@ -500,7 +492,7 @@ 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.
+ destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos.
  split.
  apply add_nonneg_nonneg; auto.
  apply mul_nonneg_nonneg; order.
@@ -514,6 +506,18 @@ Proof.
  apply div_mod; order.
 Qed.
 
+Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c ->
+ a mod (b*c) == a mod b + b*((a/b) mod c).
+Proof.
+ intros a b c Ha Hb Hc.
+ apply add_cancel_l with (b*c*(a/(b*c))).
+ rewrite <- div_mod by (apply neq_mul_0; split; order).
+ rewrite <- div_div by trivial.
+ rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
+ rewrite <- div_mod by order.
+ apply div_mod; order.
+Qed.
+
 (** A last inequality: *)
 
 Theorem div_mul_le:
@@ -538,5 +542,5 @@ Proof.
  rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
 Qed.
 
-End NZDivPropFunct.
+End NZDivProp.
 
diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v
index 9dba3c3c..36aaa3e7 100644
--- a/theories/Numbers/NatInt/NZDomain.v
+++ b/theories/Numbers/NatInt/NZDomain.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NZDomain.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NumPrelude NZAxioms.
 Require Import NZBase NZOrder NZAddOrder Plus Minus.
 
@@ -16,97 +14,36 @@ Require Import NZBase NZOrder NZAddOrder Plus Minus.
     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.
+(** First, some complements about [nat_iter] *)
 
-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.
+Local Notation "f ^ n" := (nat_iter n f).
 
-Global Instance iter_wd (R:relation A) : Proper ((R==>R)==>eq==>R==>R) iter.
+Instance nat_iter_wd n {A} (R:relation A) :
+ Proper ((R==>R)==>R==>R) (nat_iter n).
 Proof.
-intros f f' Hf n n' Hn; subst n'. induction n; simpl; red; auto.
+intros f f' Hf. induction n; simpl; red; auto.
 Qed.
 
-End Iter.
-Implicit Arguments iter [A].
-Local Infix "^" := iter.
-
-
 Module NZDomainProp (Import NZ:NZDomainSig').
+Include NZBaseProp NZ.
 
 (** * 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. *)
+(** 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.
+Lemma itersucc_or_itersucc 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.
+nzinduct n m.
+exists 0%nat. now left.
+intros n. split; intros [k [L|R]].
+exists (Datatypes.S k). left. now apply succ_wd.
+destruct k as [|k].
+simpl in R. exists 1%nat. left. now apply succ_wd.
+rewrite nat_iter_succ_r in R. exists k. now right.
+destruct k as [|k]; simpl in L.
+exists 1%nat. now right.
+apply succ_inj in L. exists k. now left.
+exists (Datatypes.S k). right. now rewrite nat_iter_succ_r.
 Qed.
 
 (** Generalized version of [pred_succ] when iterating *)
@@ -116,7 +53,7 @@ Proof.
 induction k.
 simpl; auto with *.
 simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto.
-rewrite <- iter_alt in H; auto.
+rewrite <- nat_iter_succ_r in H; auto.
 Qed.
 
 (** From a given point, all others are iterated successors
@@ -307,7 +244,7 @@ End NZOfNat.
 
 Module NZOfNatOrd (Import NZ:NZOrdSig').
 Include NZOfNat NZ.
-Include NZOrderPropFunct NZ.
+Include NZBaseProp NZ <+ NZOrderProp NZ.
 Local Open Scope ofnat.
 
 Theorem ofnat_S_gt_0 :
@@ -315,8 +252,8 @@ Theorem ofnat_S_gt_0 :
 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.
+apply lt_succ_diag_r.
+apply lt_trans with (S 0). apply lt_succ_diag_r. now rewrite <- succ_lt_mono.
 Qed.
 
 Theorem ofnat_S_neq_0 :
@@ -375,14 +312,14 @@ 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.
+ rewrite ofnat_succ, add_succ_l. simpl. now f_equiv.
 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.
+ rewrite ofnat_succ. now f_equiv.
 Qed.
 
 Lemma ofnat_mul : forall n m, [n*m] == [n]*[m].
@@ -391,14 +328,14 @@ Proof.
  symmetry. apply mul_0_l.
  rewrite plus_comm.
  rewrite ofnat_succ, ofnat_add, mul_succ_l.
- now apply add_wd.
+ now f_equiv.
 Qed.
 
 Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n.
 Proof.
  induction m; simpl; intros.
  rewrite ofnat_zero. apply sub_0_r.
- rewrite ofnat_succ, sub_succ_r. now apply pred_wd.
+ rewrite ofnat_succ, sub_succ_r. now f_equiv.
 Qed.
 
 Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m].
@@ -409,7 +346,7 @@ Proof.
  intros.
  destruct n.
  inversion H.
- rewrite iter_alt.
+ rewrite nat_iter_succ_r.
  simpl.
  rewrite ofnat_succ, pred_succ; auto with arith.
 Qed.
diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v
new file mode 100644
index 00000000..f72023d9
--- /dev/null
+++ b/theories/Numbers/NatInt/NZGcd.v
@@ -0,0 +1,307 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Greatest Common Divisor *)
+
+Require Import NZAxioms NZMulOrder.
+
+(** Interface of a gcd function, then its specification on naturals *)
+
+Module Type Gcd (Import A : Typ).
+ Parameter Inline gcd : t -> t -> t.
+End Gcd.
+
+Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A).
+ Import A B.
+ Definition divide n m := exists p, m == p*n.
+ Local Notation "( n | m )" := (divide n m) (at level 0).
+ Axiom gcd_divide_l : forall n m, (gcd n m | n).
+ Axiom gcd_divide_r : forall n m, (gcd n m | m).
+ Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m).
+ Axiom gcd_nonneg : forall n m, 0 <= gcd n m.
+End NZGcdSpec.
+
+Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B).
+ Import A B C.
+ Notation "( n | m )" := (divide n m) (at level 0).
+End DivideNotation.
+
+Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A.
+Module Type NZGcd' (A : NZOrdAxiomsSig) :=
+ Gcd A <+ NZGcdSpec A <+ DivideNotation A.
+
+(** Derived properties of gcd *)
+
+Module NZGcdProp
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZGcd' A)
+ (Import C : NZMulOrderProp A).
+
+(** Results concerning divisibility*)
+
+Instance divide_wd : Proper (eq==>eq==>iff) divide.
+Proof.
+ unfold divide. intros x x' Hx y y' Hy.
+ setoid_rewrite Hx. setoid_rewrite Hy. easy.
+Qed.
+
+Lemma divide_1_l : forall n, (1 | n).
+Proof.
+ intros n. exists n. now nzsimpl.
+Qed.
+
+Lemma divide_0_r : forall n, (n | 0).
+Proof.
+ intros n. exists 0. now nzsimpl.
+Qed.
+
+Hint Rewrite divide_1_l divide_0_r : nz.
+
+Lemma divide_0_l : forall n, (0 | n) -> n==0.
+Proof.
+ intros n (m,Hm). revert Hm. now nzsimpl.
+Qed.
+
+Lemma eq_mul_1_nonneg : forall n m,
+ 0<=n -> n*m == 1 -> n==1 /\ m==1.
+Proof.
+ intros n m Hn H.
+ le_elim Hn.
+ destruct (lt_ge_cases m 0) as [Hm|Hm].
+ generalize (mul_pos_neg n m Hn Hm). order'.
+ le_elim Hm.
+ apply le_succ_l in Hn. rewrite <- one_succ in Hn.
+ le_elim Hn.
+ generalize (lt_1_mul_pos n m Hn Hm). order.
+ rewrite <- Hn, mul_1_l in H. now split.
+ rewrite <- Hm, mul_0_r in H. order'.
+ rewrite <- Hn, mul_0_l in H. order'.
+Qed.
+
+Lemma eq_mul_1_nonneg' : forall n m,
+ 0<=m -> n*m == 1 -> n==1 /\ m==1.
+Proof.
+ intros n m Hm H. rewrite mul_comm in H.
+ now apply and_comm, eq_mul_1_nonneg.
+Qed.
+
+Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1.
+Proof.
+ intros n Hn (m,Hm). symmetry in Hm.
+ now apply (eq_mul_1_nonneg' m n).
+Qed.
+
+Lemma divide_refl : forall n, (n | n).
+Proof.
+ intros n. exists 1. now nzsimpl.
+Qed.
+
+Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p).
+Proof.
+ intros n m p (q,Hq) (r,Hr). exists (r*q).
+ now rewrite Hr, Hq, mul_assoc.
+Qed.
+
+Instance divide_reflexive : Reflexive divide := divide_refl.
+Instance divide_transitive : Transitive divide := divide_trans.
+
+(** Due to sign, no general antisymmetry result *)
+
+Lemma divide_antisym_nonneg : forall n m,
+ 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m.
+Proof.
+ intros n m Hn Hm (q,Hq) (r,Hr).
+ le_elim Hn.
+ destruct (lt_ge_cases q 0) as [Hq'|Hq'].
+ generalize (mul_neg_pos q n Hq' Hn). order.
+ rewrite Hq, mul_assoc in Hr. symmetry in Hr.
+ apply mul_id_l in Hr; [|order].
+ destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial.
+ now rewrite H, mul_1_l in Hq.
+ rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn.
+Qed.
+
+Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m).
+Proof.
+ intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq.
+Qed.
+
+Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p).
+Proof.
+ intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq.
+Qed.
+
+Lemma mul_divide_cancel_l : forall n m p, p ~= 0 ->
+ ((p * n | p * m) <-> (n | m)).
+Proof.
+ intros n m p Hp. split.
+ intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq.
+ apply mul_divide_mono_l.
+Qed.
+
+Lemma mul_divide_cancel_r : forall n m p, p ~= 0 ->
+ ((n * p | m * p) <-> (n | m)).
+Proof.
+ intros. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l.
+Qed.
+
+Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p).
+Proof.
+ intros n m p (q,Hq) (r,Hr). exists (q+r).
+ now rewrite mul_add_distr_r, Hq, Hr.
+Qed.
+
+Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p).
+Proof.
+ intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq.
+Qed.
+
+Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p).
+Proof.
+ intros n m p. rewrite mul_comm. apply divide_mul_l.
+Qed.
+
+Lemma divide_factor_l : forall n m, (n | n * m).
+Proof.
+ intros. apply divide_mul_l, divide_refl.
+Qed.
+
+Lemma divide_factor_r : forall n m, (n | m * n).
+Proof.
+ intros. apply divide_mul_r, divide_refl.
+Qed.
+
+Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m.
+Proof.
+ intros n m Hm (q,Hq).
+ destruct (le_gt_cases n 0) as [Hn|Hn]. order.
+ rewrite Hq.
+ destruct (lt_ge_cases q 0) as [Hq'|Hq'].
+ generalize (mul_neg_pos q n Hq' Hn). order.
+ le_elim Hq'.
+ rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial.
+ now rewrite one_succ, le_succ_l.
+ rewrite <- Hq', mul_0_l in Hq. order.
+Qed.
+
+(** Basic properties of gcd *)
+
+Lemma gcd_unique : forall n m p,
+ 0<=p -> (p|n) -> (p|m) ->
+ (forall q, (q|n) -> (q|m) -> (q|p)) ->
+ gcd n m == p.
+Proof.
+ intros n m p Hp Hn Hm H.
+ apply divide_antisym_nonneg; trivial. apply gcd_nonneg.
+ apply H. apply gcd_divide_l. apply gcd_divide_r.
+ now apply gcd_greatest.
+Qed.
+
+Instance gcd_wd : Proper (eq==>eq==>eq) gcd.
+Proof.
+ intros x x' Hx y y' Hy.
+ apply gcd_unique.
+ apply gcd_nonneg.
+ rewrite Hx. apply gcd_divide_l.
+ rewrite Hy. apply gcd_divide_r.
+ intro. rewrite Hx, Hy. apply gcd_greatest.
+Qed.
+
+Lemma gcd_divide_iff : forall n m p,
+  (p | gcd n m) <-> (p | n) /\ (p | m).
+Proof.
+ intros. split. split.
+ transitivity (gcd n m); trivial using gcd_divide_l.
+ transitivity (gcd n m); trivial using gcd_divide_r.
+ intros (H,H'). now apply gcd_greatest.
+Qed.
+
+Lemma gcd_unique_alt : forall n m p, 0<=p ->
+ (forall q, (q|p) <-> (q|n) /\ (q|m)) ->
+ gcd n m == p.
+Proof.
+ intros n m p Hp H.
+ apply gcd_unique; trivial.
+ apply H. apply divide_refl.
+ apply H. apply divide_refl.
+ intros. apply H. now split.
+Qed.
+
+Lemma gcd_comm : forall n m, gcd n m == gcd m n.
+Proof.
+ intros. apply gcd_unique_alt; try apply gcd_nonneg.
+ intros. rewrite and_comm. apply gcd_divide_iff.
+Qed.
+
+Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p.
+Proof.
+ intros. apply gcd_unique_alt; try apply gcd_nonneg.
+ intros. now rewrite !gcd_divide_iff, and_assoc.
+Qed.
+
+Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n.
+Proof.
+ intros. apply gcd_unique; trivial.
+ apply divide_0_r.
+ apply divide_refl.
+Qed.
+
+Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n.
+Proof.
+ intros. now rewrite gcd_comm, gcd_0_l_nonneg.
+Qed.
+
+Lemma gcd_1_l : forall n, gcd 1 n == 1.
+Proof.
+ intros. apply gcd_unique; trivial using divide_1_l, le_0_1.
+Qed.
+
+Lemma gcd_1_r : forall n, gcd n 1 == 1.
+Proof.
+ intros. now rewrite gcd_comm, gcd_1_l.
+Qed.
+
+Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n.
+Proof.
+ intros. apply gcd_unique; trivial using divide_refl.
+Qed.
+
+Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0.
+Proof.
+ intros.
+ generalize (gcd_divide_l n m). rewrite H. apply divide_0_l.
+Qed.
+
+Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0.
+Proof.
+ intros. apply gcd_eq_0_l with n. now rewrite gcd_comm.
+Qed.
+
+Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0.
+Proof.
+ intros. split. split.
+ now apply gcd_eq_0_l with m.
+ now apply gcd_eq_0_r with n.
+ intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg.
+Qed.
+
+Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n.
+Proof.
+ intros n m Hn. apply gcd_unique_alt; trivial.
+ intros q. split. split; trivial. now apply divide_mul_l.
+ now destruct 1.
+Qed.
+
+Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n).
+Proof.
+ intros n m Hn. split. intros (q,Hq). rewrite Hq.
+ rewrite mul_comm. now apply gcd_mul_diag_l.
+ intros EQ. rewrite <- EQ. apply gcd_divide_r.
+Qed.
+
+End NZGcdProp.
diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v
new file mode 100644
index 00000000..a5aa6d8a
--- /dev/null
+++ b/theories/Numbers/NatInt/NZLog.v
@@ -0,0 +1,889 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Base-2 Logarithm *)
+
+Require Import NZAxioms NZMulOrder NZPow.
+
+(** Interface of a log2 function, then its specification on naturals *)
+
+Module Type Log2 (Import A : Typ).
+ Parameter Inline log2 : t -> t.
+End Log2.
+
+Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A).
+ Import A B C.
+ Axiom log2_spec : forall a, 0<a -> 2^(log2 a) <= a < 2^(S (log2 a)).
+ Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0.
+End NZLog2Spec.
+
+Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B.
+
+(** Derived properties of logarithm *)
+
+Module Type NZLog2Prop
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZPow' A)
+ (Import C : NZLog2 A B)
+ (Import D : NZMulOrderProp A)
+ (Import E : NZPowProp A B D).
+
+(** log2 is always non-negative *)
+
+Lemma log2_nonneg : forall a, 0 <= log2 a.
+Proof.
+ intros a. destruct (le_gt_cases a 0) as [Ha|Ha].
+ now rewrite log2_nonpos.
+ destruct (log2_spec a Ha) as (_,LT).
+ apply lt_succ_r, (pow_gt_1 2). order'.
+ rewrite <- le_succ_l, <- one_succ in Ha. order.
+Qed.
+
+(** A tactic for proving positivity and non-negativity *)
+
+Ltac order_pos :=
+((apply add_pos_pos || apply add_nonneg_nonneg ||
+  apply mul_pos_pos || apply mul_nonneg_nonneg ||
+  apply pow_nonneg || apply pow_pos_nonneg ||
+  apply log2_nonneg || apply (le_le_succ_r 0));
+ order_pos) (* in case of success of an apply, we recurse *)
+|| order'.  (* otherwise *)
+
+(** The spec of log2 indeed determines it *)
+
+Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b.
+Proof.
+ intros a b Hb (LEb,LTb).
+ assert (Ha : 0 < a).
+  apply lt_le_trans with (2^b); trivial.
+  apply pow_pos_nonneg; order'.
+ assert (Hc := log2_nonneg a).
+ destruct (log2_spec a Ha) as (LEc,LTc).
+ assert (log2 a <= b).
+  apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'.
+  now apply le_le_succ_r.
+ assert (b <= log2 a).
+  apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'.
+  now apply le_le_succ_r.
+ order.
+Qed.
+
+(** Hence log2 is a morphism. *)
+
+Instance log2_wd : Proper (eq==>eq) log2.
+Proof.
+ intros x x' Hx.
+ destruct (le_gt_cases x 0).
+ rewrite 2 log2_nonpos; trivial. reflexivity. now rewrite <- Hx.
+ apply log2_unique. apply log2_nonneg.
+ rewrite Hx in *. now apply log2_spec.
+Qed.
+
+(** An alternate specification *)
+
+Lemma log2_spec_alt : forall a, 0<a -> exists r,
+ a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a).
+Proof.
+ intros a Ha.
+ destruct (log2_spec _ Ha) as (LE,LT).
+ destruct (le_exists_sub _ _ LE) as (r & Hr & Hr').
+ exists r.
+ split. now rewrite add_comm.
+ split. trivial.
+ apply (add_lt_mono_r _ _ (2^log2 a)).
+ rewrite <- Hr. generalize LT.
+ rewrite pow_succ_r by order_pos.
+ rewrite two_succ at 1. now nzsimpl.
+Qed.
+
+Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b ->
+ a == 2^b + c -> log2 a == b.
+Proof.
+ intros a b c Hb (Hc,H) EQ.
+ apply log2_unique. trivial.
+ rewrite EQ.
+ split.
+ rewrite <- add_0_r at 1. now apply add_le_mono_l.
+ rewrite pow_succ_r by order.
+ rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l.
+Qed.
+
+(** log2 is exact on powers of 2 *)
+
+Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a.
+Proof.
+ intros a Ha.
+ apply log2_unique' with 0; trivial.
+ split; order_pos. now nzsimpl.
+Qed.
+
+(** log2 and predecessors of powers of 2 *)
+
+Lemma log2_pred_pow2 : forall a, 0<a -> log2 (P (2^a)) == P a.
+Proof.
+ intros a Ha.
+ assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0).
+ apply log2_unique.
+ apply lt_succ_r; order.
+ rewrite <-le_succ_l, <-lt_succ_r, Ha'.
+ rewrite lt_succ_pred with 0.
+ split; try easy. apply pow_lt_mono_r_iff; try order'.
+  rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r.
+ apply pow_pos_nonneg; order'.
+Qed.
+
+(** log2 and basic constants *)
+
+Lemma log2_1 : log2 1 == 0.
+Proof.
+ rewrite <- (pow_0_r 2). now apply log2_pow2.
+Qed.
+
+Lemma log2_2 : log2 2 == 1.
+Proof.
+ rewrite <- (pow_1_r 2). apply log2_pow2; order'.
+Qed.
+
+(** log2 n is strictly positive for 1<n *)
+
+Lemma log2_pos : forall a, 1<a -> 0 < log2 a.
+Proof.
+ intros a Ha.
+ assert (Ha' : 0 < a) by order'.
+ assert (H := log2_nonneg a). le_elim H; trivial.
+ generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order.
+ intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order.
+Qed.
+
+(** Said otherwise, log2 is null only below 1 *)
+
+Lemma log2_null : forall a, log2 a == 0 <-> a <= 1.
+Proof.
+ intros a. split; intros H.
+ destruct (le_gt_cases a 1) as [Ha|Ha]; trivial.
+ generalize (log2_pos a Ha); order.
+ le_elim H.
+ apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ.
+ rewrite H. apply log2_1.
+Qed.
+
+(** log2 is a monotone function (but not a strict one) *)
+
+Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases a 0) as [Ha|Ha].
+ rewrite log2_nonpos; order_pos.
+ assert (Hb : 0 < b) by order.
+ destruct (log2_spec a Ha) as (LEa,_).
+ destruct (log2_spec b Hb) as (_,LTb).
+ apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos.
+Qed.
+
+(** No reverse result for <=, consider for instance log2 3 <= log2 2 *)
+
+Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases b 0) as [Hb|Hb].
+  rewrite (log2_nonpos b) in H; trivial.
+  generalize (log2_nonneg a); order.
+ destruct (le_gt_cases a 0) as [Ha|Ha]. order.
+ destruct (log2_spec a Ha) as (_,LTa).
+ destruct (log2_spec b Hb) as (LEb,_).
+ apply le_succ_l in H.
+ apply (pow_le_mono_r_iff 2) in H; order_pos.
+Qed.
+
+(** When left side is a power of 2, we have an equivalence for <= *)
+
+Lemma log2_le_pow2 : forall a b, 0<a -> (2^b<=a <-> b <= log2 a).
+Proof.
+ intros a b Ha.
+ split; intros H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ generalize (log2_nonneg a); order.
+ rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono.
+ transitivity (2^(log2 a)).
+ apply pow_le_mono_r; order'.
+ now destruct (log2_spec a Ha).
+Qed.
+
+(** When right side is a square, we have an equivalence for < *)
+
+Lemma log2_lt_pow2 : forall a b, 0<a -> (a<2^b <-> log2 a < b).
+Proof.
+ intros a b Ha.
+ split; intros H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite pow_neg_r in H; order.
+ apply (pow_lt_mono_r_iff 2); try order_pos.
+ apply le_lt_trans with a; trivial.
+ now destruct (log2_spec a Ha).
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ generalize (log2_nonneg a); order.
+ apply log2_lt_cancel; try order.
+ now rewrite log2_pow2.
+Qed.
+
+(** Comparing log2 and identity *)
+
+Lemma log2_lt_lin : forall a, 0<a -> log2 a < a.
+Proof.
+ intros a Ha.
+ apply (pow_lt_mono_r_iff 2); try order_pos.
+ apply le_lt_trans with a.
+ now destruct (log2_spec a Ha).
+ apply pow_gt_lin_r; order'.
+Qed.
+
+Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a.
+Proof.
+ intros a Ha.
+ le_elim Ha.
+ now apply lt_le_incl, log2_lt_lin.
+ rewrite <- Ha, log2_nonpos; order.
+Qed.
+
+(** Log2 and multiplication. *)
+
+(** Due to rounding error, we don't have the usual
+    [log2 (a*b) = log2 a + log2 b] but we may be off by 1 at most *)
+
+Lemma log2_mul_below : forall a b, 0<a -> 0<b ->
+ log2 a + log2 b <= log2 (a*b).
+Proof.
+ intros a b Ha Hb.
+ apply log2_le_pow2; try order_pos.
+ rewrite pow_add_r by order_pos.
+ apply mul_le_mono_nonneg; try apply log2_spec; order_pos.
+Qed.
+
+Lemma log2_mul_above : forall a b, 0<=a -> 0<=b ->
+ log2 (a*b) <= log2 a + log2 b + 1.
+Proof.
+ intros a b Ha Hb.
+ le_elim Ha.
+ le_elim Hb.
+ apply lt_succ_r.
+ rewrite add_1_r, <- add_succ_r, <- add_succ_l.
+ apply log2_lt_pow2; try order_pos.
+ rewrite pow_add_r by order_pos.
+ apply mul_lt_mono_nonneg; try order; now apply log2_spec.
+ rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos.
+ rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos.
+Qed.
+
+(** And we can't find better approximations in general.
+    - The lower bound is exact for powers of 2.
+    - Concerning the upper bound, for any c>1, take a=b=2^c-1,
+      then log2 (a*b) = c+c -1 while (log2 a) = (log2 b) = c-1
+*)
+
+(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *)
+
+Lemma log2_mul_pow2 : forall a b, 0<a -> 0<=b -> log2 (a*2^b) == b + log2 a.
+Proof.
+ intros a b Ha Hb.
+ apply log2_unique; try order_pos. split.
+ rewrite pow_add_r, mul_comm; try order_pos.
+ apply mul_le_mono_nonneg_r. order_pos. now apply log2_spec.
+ rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos.
+ apply mul_lt_mono_pos_l. order_pos. now apply log2_spec.
+Qed.
+
+Lemma log2_double : forall a, 0<a -> log2 (2*a) == S (log2 a).
+Proof.
+ intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'.
+Qed.
+
+(** Two numbers with same log2 cannot be far away. *)
+
+Lemma log2_same : forall a b, 0<a -> 0<b -> log2 a == log2 b -> a < 2*b.
+Proof.
+ intros a b Ha Hb H.
+ apply log2_lt_cancel. rewrite log2_double, H by trivial.
+ apply lt_succ_diag_r.
+Qed.
+
+(** Log2 and successor :
+    - the log2 function climbs by at most 1 at a time
+    - otherwise it stays at the same value
+    - the +1 steps occur for powers of two
+*)
+
+Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a).
+Proof.
+ intros a.
+ destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
+ apply (pow_le_mono_r_iff 2); try order_pos.
+ transitivity (S a).
+ apply log2_spec.
+ apply lt_succ_r; order.
+ now apply le_succ_l, log2_spec.
+ rewrite <- EQ, <- one_succ, log2_1; order_pos.
+ rewrite 2 log2_nonpos. order_pos. order'. now rewrite le_succ_l.
+Qed.
+
+Lemma log2_succ_or : forall a,
+ log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a.
+Proof.
+ intros.
+ destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H].
+ right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order.
+ left. apply le_succ_l in H. generalize (log2_succ_le a); order.
+Qed.
+
+Lemma log2_eq_succ_is_pow2 : forall a,
+ log2 (S a) == S (log2 a) -> exists b, S a == 2^b.
+Proof.
+ intros a H.
+ destruct (le_gt_cases a 0) as [Ha|Ha].
+ rewrite 2 (proj2 (log2_null _)) in H. generalize (lt_succ_diag_r 0); order.
+ order'. apply le_succ_l. order'.
+ assert (Ha' : 0 < S a) by (apply lt_succ_r; order).
+ exists (log2 (S a)).
+ generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)).
+ rewrite <- le_succ_l, <- H. order.
+Qed.
+
+Lemma log2_eq_succ_iff_pow2 : forall a, 0<a ->
+ (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b).
+Proof.
+ intros a Ha.
+ split. apply log2_eq_succ_is_pow2.
+ intros (b,Hb).
+ assert (Hb' : 0 < b).
+  apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono.
+ rewrite Hb, log2_pow2; try order'.
+ setoid_replace a with (P (2^b)). rewrite log2_pred_pow2; trivial.
+ symmetry; now apply lt_succ_pred with 0.
+ apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0.
+  rewrite <- Hb, lt_succ_r; order.
+Qed.
+
+Lemma log2_succ_double : forall a, 0<a -> log2 (2*a+1) == S (log2 a).
+Proof.
+ intros a Ha.
+ rewrite add_1_r.
+ destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double].
+ apply log2_eq_succ_is_pow2 in H. destruct H as (b,H).
+ destruct (lt_trichotomy b 0) as [LT|[EQ|LT]].
+ rewrite pow_neg_r in H; trivial.
+ apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'.
+ rewrite <- one_succ in Ha. order'.
+ rewrite EQ, pow_0_r in H.
+ apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'.
+ rewrite <- one_succ in Ha. order'.
+ assert (EQ:=lt_succ_pred 0 b LT).
+ rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ].
+ destruct (lt_ge_cases a (2^(P b))) as [LT'|LE'].
+ generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order.
+ rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'.
+ rewrite <- H in LE'. apply le_succ_l in LE'. order.
+Qed.
+
+(** Log2 and addition *)
+
+Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b.
+Proof.
+ intros a b Ha Hb.
+ destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|].
+ rewrite one_succ, lt_succ_r in Ha'.
+ rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono.
+ rewrite <- (add_0_l b) at 2. now apply add_le_mono.
+ destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|].
+ rewrite one_succ, lt_succ_r in Hb'.
+ rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono.
+ rewrite <- (add_0_r a) at 2. now apply add_le_mono.
+ clear Ha Hb.
+ apply lt_succ_r.
+ apply log2_lt_pow2; try order_pos.
+ rewrite pow_succ_r by order_pos.
+ rewrite two_succ, one_succ at 1. nzsimpl.
+ apply add_lt_mono.
+ apply lt_le_trans with (2^(S (log2 a))). apply log2_spec; order'.
+ apply pow_le_mono_r. order'. rewrite <- add_1_r. apply add_le_mono_l.
+  rewrite one_succ; now apply le_succ_l, log2_pos.
+ apply lt_le_trans with (2^(S (log2 b))). apply log2_spec; order'.
+ apply pow_le_mono_r. order'. rewrite <- add_1_l. apply add_le_mono_r.
+  rewrite one_succ; now apply le_succ_l, log2_pos.
+Qed.
+
+(** The sum of two log2 is less than twice the log2 of the sum.
+    The large inequality is obvious thanks to monotonicity.
+    The strict one requires some more work. This is almost
+    a convexity inequality for points [2a], [2b] and their middle [a+b] :
+    ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b].
+    Here, we cannot do better: consider for instance a=2 b=4, then 1+2<2*2
+*)
+
+Lemma add_log2_lt : forall a b, 0<a -> 0<b ->
+ log2 a + log2 b < 2 * log2 (a+b).
+Proof.
+ intros a b Ha Hb. nzsimpl'.
+ assert (H : log2 a <= log2 (a+b)).
+  apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order.
+ assert (H' : log2 b <= log2 (a+b)).
+  apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
+ le_elim H.
+ apply lt_le_trans with (log2 (a+b) + log2 b).
+  now apply add_lt_mono_r. now apply add_le_mono_l.
+ rewrite <- H at 1. apply add_lt_mono_l.
+ le_elim H'; trivial.
+ symmetry in H. apply log2_same in H; try order_pos.
+ symmetry in H'. apply log2_same in H'; try order_pos.
+ revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order.
+Qed.
+
+End NZLog2Prop.
+
+Module NZLog2UpProp
+ (Import A : NZDecOrdAxiomsSig')
+ (Import B : NZPow' A)
+ (Import C : NZLog2 A B)
+ (Import D : NZMulOrderProp A)
+ (Import E : NZPowProp A B D)
+ (Import F : NZLog2Prop A B C D E).
+
+(** * [log2_up] : a binary logarithm that rounds up instead of down *)
+
+(** For once, we define instead of axiomatizing, thanks to log2 *)
+
+Definition log2_up a :=
+ match compare 1 a with
+  | Lt => S (log2 (P a))
+  | _ => 0
+ end.
+
+Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0.
+Proof.
+ intros a Ha. unfold log2_up. case compare_spec; try order.
+Qed.
+
+Lemma log2_up_eqn : forall a, 1<a -> log2_up a == S (log2 (P a)).
+Proof.
+ intros a Ha. unfold log2_up. case compare_spec; try order.
+Qed.
+
+Lemma log2_up_spec : forall a, 1<a ->
+ 2^(P (log2_up a)) < a <= 2^(log2_up a).
+Proof.
+ intros a Ha.
+ rewrite log2_up_eqn; trivial.
+ rewrite pred_succ.
+ rewrite <- (lt_succ_pred 1 a Ha) at 2 3.
+ rewrite lt_succ_r, le_succ_l.
+ apply log2_spec.
+ apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ.
+Qed.
+
+Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0.
+Proof.
+ intros. apply log2_up_eqn0. order'.
+Qed.
+
+Instance log2_up_wd : Proper (eq==>eq) log2_up.
+Proof.
+ assert (Proper (eq==>eq==>Logic.eq) compare).
+  repeat red; intros; do 2 case compare_spec; trivial; order.
+ intros a a' Ha. unfold log2_up. rewrite Ha at 1.
+ case compare; now rewrite ?Ha.
+Qed.
+
+(** [log2_up] is always non-negative *)
+
+Lemma log2_up_nonneg : forall a, 0 <= log2_up a.
+Proof.
+ intros a. unfold log2_up. case compare_spec; try order.
+ intros. apply le_le_succ_r, log2_nonneg.
+Qed.
+
+(** The spec of [log2_up] indeed determines it *)
+
+Lemma log2_up_unique : forall a b, 0<b -> 2^(P b)<a<=2^b -> log2_up a == b.
+Proof.
+ intros a b Hb (LEb,LTb).
+ assert (Ha : 1 < a).
+  apply le_lt_trans with (2^(P b)); trivial.
+  rewrite one_succ. apply le_succ_l.
+  apply pow_pos_nonneg. order'. apply lt_succ_r.
+  now rewrite (lt_succ_pred 0 b Hb).
+ assert (Hc := log2_up_nonneg a).
+ destruct (log2_up_spec a Ha) as (LTc,LEc).
+ assert (b <= log2_up a).
+  apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb).
+  rewrite <- succ_lt_mono.
+  apply (pow_lt_mono_r_iff 2); try order'.
+ assert (Hc' : 0 < log2_up a) by order.
+ assert (log2_up a <= b).
+  apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc').
+  rewrite <- succ_lt_mono.
+  apply (pow_lt_mono_r_iff 2); try order'.
+ order.
+Qed.
+
+(** [log2_up] is exact on powers of 2 *)
+
+Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a.
+Proof.
+ intros a Ha.
+ le_elim Ha.
+ apply log2_up_unique; trivial.
+ split; try order.
+ apply pow_lt_mono_r; try order'.
+ rewrite <- (lt_succ_pred 0 a Ha) at 2.
+ now apply lt_succ_r.
+ now rewrite <- Ha, pow_0_r, log2_up_eqn0.
+Qed.
+
+(** [log2_up] and successors of powers of 2 *)
+
+Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a.
+Proof.
+ intros a Ha.
+ rewrite log2_up_eqn, pred_succ, log2_pow2; try easy.
+ rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'.
+Qed.
+
+(** Basic constants *)
+
+Lemma log2_up_1 : log2_up 1 == 0.
+Proof.
+ now apply log2_up_eqn0.
+Qed.
+
+Lemma log2_up_2 : log2_up 2 == 1.
+Proof.
+ rewrite <- (pow_1_r 2). apply log2_up_pow2; order'.
+Qed.
+
+(** Links between log2 and [log2_up] *)
+
+Lemma le_log2_log2_up : forall a, log2 a <= log2_up a.
+Proof.
+ intros a. unfold log2_up. case compare_spec; intros H.
+ rewrite <- H, log2_1. order.
+ rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le.
+ rewrite log2_nonpos. order. now rewrite <-lt_succ_r, <-one_succ.
+Qed.
+
+Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a).
+Proof.
+ intros a. unfold log2_up. case compare_spec; intros H; try order_pos.
+ rewrite <- succ_le_mono. apply log2_le_mono.
+ rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r.
+Qed.
+
+Lemma log2_log2_up_spec : forall a, 0<a ->
+ 2^log2 a <= a <= 2^log2_up a.
+Proof.
+ intros a H. split.
+ now apply log2_spec.
+ rewrite <-le_succ_l, <-one_succ in H. le_elim H.
+ now apply log2_up_spec.
+ now rewrite <-H, log2_up_1, pow_0_r.
+Qed.
+
+Lemma log2_log2_up_exact :
+ forall a, 0<a -> (log2 a == log2_up a <-> exists b, a == 2^b).
+Proof.
+ intros a Ha.
+ split. intros. exists (log2 a).
+  generalize (log2_log2_up_spec a Ha). rewrite <-H.
+  destruct 1; order.
+ intros (b,Hb). rewrite Hb.
+ destruct (le_gt_cases 0 b).
+ now rewrite log2_pow2, log2_up_pow2.
+ rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos.
+Qed.
+
+(** [log2_up] n is strictly positive for 1<n *)
+
+Lemma log2_up_pos : forall a, 1<a -> 0 < log2_up a.
+Proof.
+ intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos.
+Qed.
+
+(** Said otherwise, [log2_up] is null only below 1 *)
+
+Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1.
+Proof.
+ intros a. split; intros H.
+ destruct (le_gt_cases a 1) as [Ha|Ha]; trivial.
+ generalize (log2_up_pos a Ha); order.
+ now apply log2_up_eqn0.
+Qed.
+
+(** [log2_up] is a monotone function (but not a strict one) *)
+
+Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases a 1) as [Ha|Ha].
+ rewrite log2_up_eqn0; trivial. apply log2_up_nonneg.
+ rewrite 2 log2_up_eqn; try order.
+ rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono.
+ rewrite 2 lt_succ_pred with 1; order.
+Qed.
+
+(** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *)
+
+Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases b 1) as [Hb|Hb].
+  rewrite (log2_up_eqn0 b) in H; trivial.
+  generalize (log2_up_nonneg a); order.
+ destruct (le_gt_cases a 1) as [Ha|Ha]. order.
+ rewrite 2 log2_up_eqn in H; try order.
+ rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H.
+ rewrite 2 lt_succ_pred with 1 in H; order.
+Qed.
+
+(** When left side is a power of 2, we have an equivalence for < *)
+
+Lemma log2_up_lt_pow2 : forall a b, 0<a -> (2^b<a <-> b < log2_up a).
+Proof.
+ intros a b Ha.
+ split; intros H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ generalize (log2_up_nonneg a); order.
+ apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg.
+ apply lt_le_trans with a; trivial.
+ apply (log2_up_spec a).
+ apply le_lt_trans with (2^b); trivial.
+ rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ now rewrite pow_neg_r.
+ rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel.
+Qed.
+
+(** When right side is a square, we have an equivalence for <= *)
+
+Lemma log2_up_le_pow2 : forall a b, 0<a -> (a<=2^b <-> log2_up a <= b).
+Proof.
+ intros a b Ha.
+ split; intros H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite pow_neg_r in H; order.
+ rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono.
+ transitivity (2^(log2_up a)).
+ now apply log2_log2_up_spec.
+ apply pow_le_mono_r; order'.
+Qed.
+
+(** Comparing [log2_up] and identity *)
+
+Lemma log2_up_lt_lin : forall a, 0<a -> log2_up a < a.
+Proof.
+ intros a Ha.
+ assert (H : S (P a) == a) by (now apply lt_succ_pred with 0).
+ rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial.
+ rewrite <- H at 1. apply le_succ_l.
+ apply pow_gt_lin_r. order'. apply lt_succ_r; order.
+Qed.
+
+Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a.
+Proof.
+ intros a Ha.
+ le_elim Ha.
+ now apply lt_le_incl, log2_up_lt_lin.
+ rewrite <- Ha, log2_up_nonpos; order.
+Qed.
+
+(** [log2_up] and multiplication. *)
+
+(** Due to rounding error, we don't have the usual
+    [log2_up (a*b) = log2_up a + log2_up b] but we may be off by 1 at most *)
+
+Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b ->
+  log2_up (a*b) <= log2_up a + log2_up b.
+Proof.
+ intros a b Ha Hb.
+ assert (Ha':=log2_up_nonneg a).
+ assert (Hb':=log2_up_nonneg b).
+ le_elim Ha.
+ le_elim Hb.
+ apply log2_up_le_pow2; try order_pos.
+ rewrite pow_add_r; trivial.
+ apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'.
+ rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos.
+ rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos.
+Qed.
+
+Lemma log2_up_mul_below : forall a b, 0<a -> 0<b ->
+ log2_up a + log2_up b <= S (log2_up (a*b)).
+Proof.
+ intros a b Ha Hb.
+ rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha.
+ rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb.
+ assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial).
+ assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial).
+ rewrite <- (lt_succ_pred 0 (log2_up a)); trivial.
+ rewrite <- (lt_succ_pred 0 (log2_up b)); trivial.
+ nzsimpl. rewrite <- succ_le_mono, le_succ_l.
+ apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg.
+ rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial).
+ apply lt_le_trans with (a*b).
+ apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec.
+ apply log2_up_spec.
+ setoid_replace 1 with (1*1) by now nzsimpl.
+ apply mul_lt_mono_nonneg; order'.
+ rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r.
+ rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r.
+Qed.
+
+(** And we can't find better approximations in general.
+    - The upper bound is exact for powers of 2.
+    - Concerning the lower bound, for any c>1, take a=b=2^c+1,
+      then [log2_up (a*b) = c+c +1] while [(log2_up a) = (log2_up b) = c+1]
+*)
+
+(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *)
+
+Lemma log2_up_mul_pow2 : forall a b, 0<a -> 0<=b ->
+ log2_up (a*2^b) == b + log2_up a.
+Proof.
+ intros a b Ha Hb.
+ rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha.
+ apply log2_up_unique. apply add_nonneg_pos; trivial. now apply log2_up_pos.
+ split.
+ assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)).
+ rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial.
+ apply mul_lt_mono_pos_r. order_pos. now apply log2_up_spec.
+ rewrite <- lt_succ_r, EQ. now apply log2_up_pos.
+ rewrite pow_add_r, mul_comm; trivial.
+ apply mul_le_mono_nonneg_l. order_pos. now apply log2_up_spec.
+ apply log2_up_nonneg.
+ now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2.
+Qed.
+
+Lemma log2_up_double : forall a, 0<a -> log2_up (2*a) == S (log2_up a).
+Proof.
+ intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'.
+Qed.
+
+(** Two numbers with same [log2_up] cannot be far away. *)
+
+Lemma log2_up_same : forall a b, 0<a -> 0<b -> log2_up a == log2_up b -> a < 2*b.
+Proof.
+ intros a b Ha Hb H.
+ apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial.
+ apply lt_succ_diag_r.
+Qed.
+
+(** [log2_up] and successor :
+    - the [log2_up] function climbs by at most 1 at a time
+    - otherwise it stays at the same value
+    - the +1 steps occur after powers of two
+*)
+
+Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a).
+Proof.
+ intros a.
+ destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]].
+ rewrite 2 log2_up_eqn; trivial.
+ rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1.
+ apply log2_succ_le.
+ apply lt_succ_r; order.
+ rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'.
+ rewrite 2 log2_up_eqn0. order_pos. order'. now rewrite le_succ_l.
+Qed.
+
+Lemma log2_up_succ_or : forall a,
+ log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a.
+Proof.
+ intros.
+ destruct (le_gt_cases (log2_up (S a)) (log2_up a)).
+ right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order.
+ left. apply le_succ_l in H. generalize (log2_up_succ_le a); order.
+Qed.
+
+Lemma log2_up_eq_succ_is_pow2 : forall a,
+ log2_up (S a) == S (log2_up a) -> exists b, a == 2^b.
+Proof.
+ intros a H.
+ destruct (le_gt_cases a 0) as [Ha|Ha].
+ rewrite 2 (proj2 (log2_up_null _)) in H. generalize (lt_succ_diag_r 0); order.
+ order'. apply le_succ_l. order'.
+ assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono).
+ exists (log2_up a).
+ generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)).
+ rewrite H, pred_succ, lt_succ_r. order.
+Qed.
+
+Lemma log2_up_eq_succ_iff_pow2 : forall a, 0<a ->
+ (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b).
+Proof.
+ intros a Ha.
+ split. apply log2_up_eq_succ_is_pow2.
+ intros (b,Hb).
+ destruct (lt_ge_cases b 0) as [Hb'|Hb'].
+  rewrite pow_neg_r in Hb; order.
+ rewrite Hb, log2_up_pow2; try order'.
+ now rewrite log2_up_succ_pow2.
+Qed.
+
+Lemma log2_up_succ_double : forall a, 0<a ->
+ log2_up (2*a+1) == 2 + log2 a.
+Proof.
+ intros a Ha.
+ rewrite log2_up_eqn. rewrite add_1_r, pred_succ, log2_double; now nzsimpl'.
+ apply le_lt_trans with (0+1). now nzsimpl'.
+ apply add_lt_mono_r. order_pos.
+Qed.
+
+(** [log2_up] and addition *)
+
+Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 ->
+ log2_up (a+b) <= log2_up a + log2_up b.
+Proof.
+ intros a b Ha Hb.
+ destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|].
+ rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono.
+ rewrite one_succ, lt_succ_r in Ha'.
+ rewrite <- (add_0_l b) at 2. now apply add_le_mono.
+ destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|].
+ rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono.
+ rewrite one_succ, lt_succ_r in Hb'.
+ rewrite <- (add_0_r a) at 2. now apply add_le_mono.
+ clear Ha Hb.
+ transitivity (log2_up (a*b)).
+ now apply log2_up_le_mono, add_le_mul.
+ apply log2_up_mul_above; order'.
+Qed.
+
+(** The sum of two [log2_up] is less than twice the [log2_up] of the sum.
+    The large inequality is obvious thanks to monotonicity.
+    The strict one requires some more work. This is almost
+    a convexity inequality for points [2a], [2b] and their middle [a+b] :
+    ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b].
+    Here, we cannot do better: consider for instance a=3 b=5, then 2+3<2*3
+*)
+
+Lemma add_log2_up_lt : forall a b, 0<a -> 0<b ->
+ log2_up a + log2_up b < 2 * log2_up (a+b).
+Proof.
+ intros a b Ha Hb. nzsimpl'.
+ assert (H : log2_up a <= log2_up (a+b)).
+  apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order.
+ assert (H' : log2_up b <= log2_up (a+b)).
+  apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
+ le_elim H.
+ apply lt_le_trans with (log2_up (a+b) + log2_up b).
+  now apply add_lt_mono_r. now apply add_le_mono_l.
+ rewrite <- H at 1. apply add_lt_mono_l.
+ le_elim H'. trivial.
+ symmetry in H. apply log2_up_same in H; try order_pos.
+ symmetry in H'. apply log2_up_same in H'; try order_pos.
+ revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order.
+Qed.
+
+End NZLog2UpProp.
+
diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v
index b1adcea9..2b5a1cf3 100644
--- a/theories/Numbers/NatInt/NZMul.v
+++ b/theories/Numbers/NatInt/NZMul.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,13 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms NZBase NZAdd.
 
-Module Type NZMulPropSig
- (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ).
-Include NZAddPropSig NZ NZBase.
+Module Type NZMulProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ).
+Include NZAddProp NZ NZBase.
 
 Theorem mul_0_r : forall n, n * 0 == 0.
 Proof.
@@ -59,12 +56,34 @@ Qed.
 
 Theorem mul_1_l : forall n, 1 * n == n.
 Proof.
-intro n. now nzsimpl.
+intro n. now nzsimpl'.
 Qed.
 
 Theorem mul_1_r : forall n, n * 1 == n.
 Proof.
-intro n. now nzsimpl.
+intro n. now nzsimpl'.
+Qed.
+
+Hint Rewrite mul_1_l mul_1_r : nz.
+
+Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m.
+Proof.
+intros n m p. now rewrite <- 2 mul_assoc, (mul_comm m).
+Qed.
+
+Theorem mul_shuffle1 : forall n m p q, (n * m) * (p * q) == (n * p) * (m * q).
+Proof.
+intros n m p q. now rewrite 2 mul_assoc, (mul_shuffle0 n).
+Qed.
+
+Theorem mul_shuffle2 : forall n m p q, (n * m) * (p * q) == (n * q) * (m * p).
+Proof.
+intros n m p q. rewrite (mul_comm p). apply mul_shuffle1.
+Qed.
+
+Theorem mul_shuffle3 : forall n m p, n * (m * p) == m * (n * p).
+Proof.
+intros n m p. now rewrite mul_assoc, (mul_comm n), mul_assoc.
 Qed.
 
-End NZMulPropSig.
+End NZMulProp.
diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v
index 09e468ff..97306f93 100644
--- a/theories/Numbers/NatInt/NZMulOrder.v
+++ b/theories/Numbers/NatInt/NZMulOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,13 +8,11 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms.
 Require Import NZAddOrder.
 
-Module Type NZMulOrderPropSig (Import NZ : NZOrdAxiomsSig').
-Include NZAddOrderPropSig NZ.
+Module Type NZMulOrderProp (Import NZ : NZOrdAxiomsSig').
+Include NZAddOrderProp NZ.
 
 Theorem mul_lt_pred :
   forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
@@ -26,17 +24,16 @@ Qed.
 
 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 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).
+intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). solve_proper.
+intros. now nzsimpl.
+clear p Hp. intros p Hp IH n m. nzsimpl.
+assert (LR : forall n m, n < m -> p * n + n < p * m + m)
+ by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH).
+split; intros H.
+now apply LR.
+destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
+rewrite EQ in H. order.
+apply LR in GT. order.
 Qed.
 
 Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p).
@@ -48,19 +45,19 @@ Qed.
 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 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.
+order.
+intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order.
+intros p Hp IH n m _. apply le_succ_l in Hp.
+le_elim Hp.
+assert (LR : forall n m, n < m -> p * m < p * n).
+ intros n1 m1 H. apply (le_lt_add_lt n1 m1).
+ now apply lt_le_incl. rewrite <- 2 mul_succ_l. now rewrite <- IH.
+split; intros H.
+now apply LR.
+destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
+rewrite EQ in H. order.
+apply LR in GT. order.
+rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl.
 Qed.
 
 Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p).
@@ -72,7 +69,7 @@ Qed.
 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 lt_le_incl. now apply -> mul_lt_mono_pos_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.
@@ -80,7 +77,7 @@ Qed.
 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 lt_le_incl. now apply -> mul_lt_mono_neg_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.
@@ -99,20 +96,13 @@ Qed.
 
 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 (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 -> 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.
+intros n m p Hp; split; intro H; [|now f_equiv].
+apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp];
+ destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
+apply (mul_lt_mono_neg_l p) in LT; order.
+apply (mul_lt_mono_neg_l p) in GT; order.
+apply (mul_lt_mono_pos_l p) in LT; order.
+apply (mul_lt_mono_pos_l p) in GT; order.
 Qed.
 
 Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m).
@@ -183,17 +173,17 @@ Qed.
 
 Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m.
 Proof.
-intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_pos_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r.
 Qed.
 
 Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m.
 Proof.
-intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
 Qed.
 
 Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
 Qed.
 
 Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0.
@@ -206,9 +196,33 @@ Proof.
 intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order.
 Qed.
 
+Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m).
+Proof.
+intros n m Hn. rewrite <- (mul_0_r n) at 1.
+ symmetry. now apply mul_lt_mono_pos_l.
+Qed.
+
+Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n).
+Proof.
+intros n m Hn. rewrite <- (mul_0_l m) at 1.
+ symmetry. now apply mul_lt_mono_pos_r.
+Qed.
+
+Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m).
+Proof.
+intros n m Hn. rewrite <- (mul_0_r n) at 1.
+ symmetry. now apply mul_le_mono_pos_l.
+Qed.
+
+Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n).
+Proof.
+intros n m Hn. rewrite <- (mul_0_l m) at 1.
+ symmetry. now apply mul_le_mono_pos_r.
+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.
+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.
@@ -229,7 +243,7 @@ Qed.
 Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
 Proof.
 intros n m; split; intro H.
-intro H1; apply -> eq_mul_0 in H1. tauto.
+intro H1; apply eq_mul_0 in H1. tauto.
 split; intro H1; rewrite H1 in H;
 (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H.
 Qed.
@@ -241,16 +255,22 @@ Qed.
 
 Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0.
 Proof.
-intros n m H1 H2. apply -> eq_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 eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0.
 Proof.
-intros n m H1 H2; apply -> eq_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.
 
+(** Some alternative names: *)
+
+Definition mul_eq_0 := eq_mul_0.
+Definition mul_eq_0_l := eq_mul_0_l.
+Definition mul_eq_0_r := eq_mul_0_r.
+
 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]]].
@@ -283,25 +303,100 @@ Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m.
 Proof.
 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.
+destruct (lt_ge_cases n m) as [LT|LE]; trivial.
+apply square_le_mono_nonneg in LE; order.
 Qed.
 
 Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m.
 Proof.
 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.
+destruct (le_gt_cases n m) as [LE|LT]; trivial.
+apply square_lt_mono_nonneg in LT; order.
+Qed.
+
+Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m.
+Proof.
+intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two).
+rewrite two_succ. nzsimpl. now rewrite le_succ_l.
+order'.
+Qed.
+
+Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b.
+Proof.
+ assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)).
+  intros a b Ha Hb.
+  nzsimpl. rewrite <- succ_le_mono. apply le_succ_l.
+  rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b).
+  apply add_lt_mono_r.
+  now apply mul_pos_pos.
+ intros a b Ha Hb.
+ assert (Ha' := lt_succ_pred 1 a Ha).
+ assert (Hb' := lt_succ_pred 1 b Hb).
+ rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order.
+Qed.
+
+(** A few results about squares *)
+
+Lemma square_nonneg : forall a, 0 <= a * a.
+Proof.
+ intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0).
+ now apply mul_le_mono_nonpos_l.
+ apply mul_le_mono_nonneg_l; order.
+Qed.
+
+Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b.
+Proof.
+ assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b).
+  intros a b (Ha,H).
+  destruct (le_exists_sub _ _ H) as (d & EQ & Hd).
+  rewrite EQ.
+  rewrite 2 mul_add_distr_r.
+  rewrite !add_assoc. apply add_le_mono_r.
+  rewrite add_comm. apply add_le_mono_l.
+  apply mul_le_mono_nonneg_l; trivial. order.
+ intros a b Ha Hb.
+ destruct (le_gt_cases a b).
+ apply AUX; split; order.
+ rewrite (add_comm (b*a)), (add_comm (a*a)).
+ apply AUX; split; order.
+Qed.
+
+Lemma add_square_le : forall a b, 0<=a -> 0<=b ->
+ a*a + b*b <= (a+b)*(a+b).
+Proof.
+ intros a b Ha Hb.
+ rewrite mul_add_distr_r, !mul_add_distr_l.
+ rewrite add_assoc.
+ apply add_le_mono_r.
+ rewrite <- add_assoc.
+ rewrite <- (add_0_r (a*a)) at 1.
+ apply add_le_mono_l.
+ apply add_nonneg_nonneg; now apply mul_nonneg_nonneg.
+Qed.
+
+Lemma square_add_le : forall a b, 0<=a -> 0<=b ->
+ (a+b)*(a+b) <= 2*(a*a + b*b).
+Proof.
+ intros a b Ha Hb.
+ rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'.
+ rewrite <- !add_assoc. apply add_le_mono_l.
+ rewrite !add_assoc. apply add_le_mono_r.
+ apply crossmul_le_addsquare; order.
 Qed.
 
-Theorem mul_2_mono_l : forall n m, n < m -> 1 + (1 + 1) * n < (1 + 1) * m.
+Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b ->
+ 2*2*a*b <= (a+b)*(a+b).
 Proof.
-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.
+ intros.
+ nzsimpl'.
+ rewrite !mul_add_distr_l, !mul_add_distr_r.
+ rewrite (add_comm _ (b*b)), add_assoc.
+ apply add_le_mono_r.
+ rewrite (add_shuffle0 (a*a)), (mul_comm b a).
+ apply add_le_mono_r.
+ rewrite (mul_comm a b) at 1.
+ now apply crossmul_le_addsquare.
 Qed.
 
-End NZMulOrderPropSig.
+End NZMulOrderProp.
diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v
index 07805772..8cf5b26f 100644
--- a/theories/Numbers/NatInt/NZOrder.v
+++ b/theories/Numbers/NatInt/NZOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,28 +8,26 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NZAxioms NZBase Decidable OrdersTac.
 
-Module Type NZOrderPropSig
- (Import NZ : NZOrdSig')(Import NZBase : NZBasePropSig NZ).
+Module Type NZOrderProp
+ (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ).
 
 Instance le_wd : Proper (eq==>eq==>iff) le.
 Proof.
-intros n n' Hn m m' Hm. rewrite !lt_eq_cases, !Hn, !Hm; auto with *.
+intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm.
 Qed.
 
 Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H].
 
 Theorem lt_le_incl : forall n m, n < m -> n <= m.
 Proof.
-intros; apply <- lt_eq_cases; now left.
+intros. apply lt_eq_cases. now left.
 Qed.
 
 Theorem le_refl : forall n, n <= n.
 Proof.
-intro; apply <- lt_eq_cases; now right.
+intro. apply lt_eq_cases. now right.
 Qed.
 
 Theorem lt_succ_diag_r : forall n, n < S n.
@@ -99,7 +97,7 @@ 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.
+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.
@@ -148,7 +146,8 @@ Definition lt_compat := lt_wd.
 Definition lt_total := lt_trichotomy.
 Definition le_lteq := lt_eq_cases.
 
-Module OrderElts <: TotalOrder.
+Module Private_OrderTac.
+Module Elts <: TotalOrder.
  Definition t := t.
  Definition eq := eq.
  Definition lt := lt.
@@ -158,9 +157,10 @@ Module OrderElts <: TotalOrder.
  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.
+End Elts.
+Module Tac := !MakeOrderTac Elts.
+End Private_OrderTac.
+Ltac order := Private_OrderTac.Tac.order.
 
 (** Some direct consequences of [order]. *)
 
@@ -208,12 +208,12 @@ Qed.
 
 Theorem lt_succ_l : forall n m, S n < m -> n < m.
 Proof.
-intros n m H; apply -> le_succ_l; order.
+intros n m H; apply le_succ_l; order.
 Qed.
 
 Theorem le_le_succ_r : forall n m, n <= m -> n <= S m.
 Proof.
-intros n m LE. rewrite <- lt_succ_r in LE. order.
+intros n m LE. apply lt_succ_r in LE. order.
 Qed.
 
 Theorem lt_lt_succ_r : forall n m, n < m -> n < S m.
@@ -233,19 +233,37 @@ Qed.
 
 Theorem lt_0_1 : 0 < 1.
 Proof.
-apply lt_succ_diag_r.
+rewrite one_succ. apply lt_succ_diag_r.
 Qed.
 
 Theorem le_0_1 : 0 <= 1.
 Proof.
-apply le_succ_diag_r.
+apply lt_le_incl, lt_0_1.
 Qed.
 
-Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
+Theorem lt_1_2 : 1 < 2.
+Proof.
+rewrite two_succ. apply lt_succ_diag_r.
+Qed.
+
+Theorem lt_0_2 : 0 < 2.
+Proof.
+transitivity 1. apply lt_0_1. apply lt_1_2.
+Qed.
+
+Theorem le_0_2 : 0 <= 2.
 Proof.
-intros n m H1 H2. apply <- le_succ_l in H1. order.
+apply lt_le_incl, lt_0_2.
 Qed.
 
+(** The order tactic enriched with some knowledge of 0,1,2 *)
+
+Ltac order' := generalize lt_0_1 lt_1_2; order.
+
+Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
+Proof.
+intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order.
+Qed.
 
 (** More Trichotomy, decidability and double negation elimination. *)
 
@@ -347,7 +365,7 @@ Proof.
 intro z; nzinduct n z.
 order.
 intro n; split; intros IH m H1 H2.
-apply -> le_succ_r in H2. destruct H2 as [H2 | H2].
+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.
@@ -359,6 +377,13 @@ intros z n H; apply lt_exists_pred_strong with (z := z) (n := n).
 assumption. apply le_refl.
 Qed.
 
+Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n.
+Proof.
+ intros z n H.
+ destruct (lt_exists_pred _ _ H) as (n' & EQ & LE).
+ rewrite EQ. now rewrite pred_succ.
+Qed.
+
 (** Stronger variant of induction with assumptions n >= 0 (n < 0)
 in the induction step *)
 
@@ -390,14 +415,14 @@ Qed.
 Lemma rs'_rs'' : right_step' -> right_step''.
 Proof.
 intros RS' n; split; intros H1 m H2 H3.
-apply -> lt_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 lt_lt_succ_r].
 Qed.
 
 Lemma rbase : A' z.
 Proof.
-intros m H1 H2. apply -> le_ngt in H1. false_hyp H2 H1.
+intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1.
 Qed.
 
 Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n.
@@ -449,28 +474,28 @@ Let left_step'' := forall n, A' n <-> A' (S n).
 Lemma ls_ls' :  A z -> left_step -> left_step'.
 Proof.
 intros Az LS n H1 H2. le_elim H1.
-apply LS; trivial. apply H2; [now apply <- le_succ_l | now apply eq_le_incl].
+apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl].
 rewrite H1; apply Az.
 Qed.
 
 Lemma ls'_ls'' : left_step' -> left_step''.
 Proof.
 intros LS' n; split; intros H1 m H2 H3.
-apply -> le_succ_l in H3. apply lt_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 <- le_succ_l in H3. now apply H1.
+apply le_succ_l in H3. now apply H1.
 rewrite <- H3 in *; now apply LS'.
 Qed.
 
 Lemma lbase : A' (S z).
 Proof.
-intros m H1 H2. apply -> le_succ_l in H2.
-apply -> le_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 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 eq_le_incl].
+intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl].
 Qed.
 
 Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n.
@@ -527,8 +552,8 @@ Theorem order_induction' :
     forall n, A n.
 Proof.
 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].
+intros m H1 H2. apply AP in H2; [|now apply le_succ_l].
+now rewrite pred_succ in H2.
 Qed.
 
 End Center.
@@ -555,11 +580,11 @@ Theorem lt_ind : forall (n : t),
    forall m, n < m -> A m.
 Proof.
 intros n H1 H2 m H3.
-apply right_induction with (S n); [assumption | | now apply <- le_succ_l].
-intros; apply H2; try assumption. now apply -> le_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 <= *)
+(** Elimination principle for <= *)
 
 Theorem le_ind : forall (n : t),
   A n ->
@@ -582,8 +607,8 @@ Section WF.
 
 Variable z : t.
 
-Let Rlt (n m : t) := z <= n /\ n < m.
-Let Rgt (n m : t) := m < n /\ n <= z.
+Let Rlt (n m : t) := z <= n < m.
+Let Rgt (n m : t) := m < n <= z.
 
 Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt.
 Proof.
@@ -595,25 +620,13 @@ Proof.
 intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2.
 Qed.
 
-Instance Acc_lt_wd : Proper (eq==>iff) (Acc Rlt).
-Proof.
-intros x1 x2 H; split; intro H1; destruct H1 as [H2];
-constructor; intros; apply H2; now (rewrite H || rewrite <- H).
-Qed.
-
-Instance Acc_gt_wd : Proper (eq==>iff) (Acc Rgt).
-Proof.
-intros x1 x2 H; split; intro H1; destruct H1 as [H2];
-constructor; intros; apply H2; now (rewrite H || rewrite <- H).
-Qed.
-
 Theorem lt_wf : well_founded Rlt.
 Proof.
 unfold well_founded.
 apply strong_right_induction' with (z := z).
-apply Acc_lt_wd.
+auto with typeclass_instances.
 intros n H; constructor; intros y [H1 H2].
-apply <- nle_gt in H2. elim H2. now apply le_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.
 
@@ -621,24 +634,20 @@ Theorem gt_wf : well_founded Rgt.
 Proof.
 unfold well_founded.
 apply strong_left_induction' with (z := z).
-apply Acc_gt_wd.
+auto with typeclass_instances.
 intros n H; constructor; intros y [H1 H2].
-apply <- nle_gt in H2. elim H2. now apply le_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 <- le_succ_l.
+apply H2. assumption. now apply le_succ_l.
 Qed.
 
 End WF.
 
-End NZOrderPropSig.
-
-Module NZOrderPropFunct (NZ : NZOrdSig) :=
- NZBasePropSig NZ <+ NZOrderPropSig NZ.
+End NZOrderProp.
 
 (** If we have moreover a [compare] function, we can build
     an [OrderedType] structure. *)
 
-Module NZOrderedTypeFunct (NZ : NZDecOrdSig')
-  <: DecidableTypeFull <: OrderedTypeFull :=
- NZ <+ NZOrderPropFunct <+ Compare2EqBool <+ HasEqBool2Dec.
-
+Module NZOrderedType (NZ : NZDecOrdSig')
+ <: DecidableTypeFull <: OrderedTypeFull
+ := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec.
diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v
new file mode 100644
index 00000000..29109ccb
--- /dev/null
+++ b/theories/Numbers/NatInt/NZParity.v
@@ -0,0 +1,263 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool NZAxioms NZMulOrder.
+
+(** Parity functions *)
+
+Module Type NZParity (Import A : NZAxiomsSig').
+ Parameter Inline even odd : t -> bool.
+ Definition Even n := exists m, n == 2*m.
+ Definition Odd n := exists m, n == 2*m+1.
+ Axiom even_spec : forall n, even n = true <-> Even n.
+ Axiom odd_spec : forall n, odd n = true <-> Odd n.
+End NZParity.
+
+Module Type NZParityProp
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZParity A)
+ (Import C : NZMulOrderProp A).
+
+(** Morphisms *)
+
+Instance Even_wd : Proper (eq==>iff) Even.
+Proof. unfold Even. solve_proper. Qed.
+
+Instance Odd_wd : Proper (eq==>iff) Odd.
+Proof. unfold Odd. solve_proper. Qed.
+
+Instance even_wd : Proper (eq==>Logic.eq) even.
+Proof.
+ intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv.
+Qed.
+
+Instance odd_wd : Proper (eq==>Logic.eq) odd.
+Proof.
+ intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv.
+Qed.
+
+(** Evenness and oddity are dual notions *)
+
+Lemma Even_or_Odd : forall x, Even x \/ Odd x.
+Proof.
+ nzinduct x.
+ left. exists 0. now nzsimpl.
+ intros x.
+ split; intros [(y,H)|(y,H)].
+ right. exists y. rewrite H. now nzsimpl.
+ left. exists (S y). rewrite H. now nzsimpl'.
+ right.
+ assert (LT : exists z, z<y).
+  destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x].
+  rewrite <- le_succ_l, H. nzsimpl'.
+  rewrite <- (add_0_r y) at 3. now apply add_le_mono_l.
+ destruct LT as (z,LT).
+ destruct (lt_exists_pred z y LT) as (y' & Hy' & _).
+ exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'.
+ left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl.
+Qed.
+
+Lemma double_below : forall n m, n<=m -> 2*n < 2*m+1.
+Proof.
+ intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono.
+Qed.
+
+Lemma double_above : forall n m, n<m -> 2*n+1 < 2*m.
+Proof.
+ intros. nzsimpl'.
+ rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r.
+ apply add_le_mono; now apply le_succ_l.
+Qed.
+
+Lemma Even_Odd_False : forall x, Even x -> Odd x -> False.
+Proof.
+intros x (y,E) (z,O). rewrite O in E; clear O.
+destruct (le_gt_cases y z) as [LE|GT].
+generalize (double_below _ _ LE); order.
+generalize (double_above _ _ GT); order.
+Qed.
+
+Lemma orb_even_odd : forall n, orb (even n) (odd n) = true.
+Proof.
+ intros.
+ destruct (Even_or_Odd n) as [H|H].
+ rewrite <- even_spec in H. now rewrite H.
+ rewrite <- odd_spec in H. now rewrite H, orb_true_r.
+Qed.
+
+Lemma negb_odd : forall n, negb (odd n) = even n.
+Proof.
+ intros.
+ generalize (Even_or_Odd n) (Even_Odd_False n).
+ rewrite <- even_spec, <- odd_spec.
+ destruct (odd n), (even n); simpl; intuition.
+Qed.
+
+Lemma negb_even : forall n, negb (even n) = odd n.
+Proof.
+ intros. rewrite <- negb_odd. apply negb_involutive.
+Qed.
+
+(** Constants *)
+
+Lemma even_0 : even 0 = true.
+Proof.
+ rewrite even_spec. exists 0. now nzsimpl.
+Qed.
+
+Lemma odd_0 : odd 0 = false.
+Proof.
+ now rewrite <- negb_even, even_0.
+Qed.
+
+Lemma odd_1 : odd 1 = true.
+Proof.
+ rewrite odd_spec. exists 0. now nzsimpl'.
+Qed.
+
+Lemma even_1 : even 1 = false.
+Proof.
+ now rewrite <- negb_odd, odd_1.
+Qed.
+
+Lemma even_2 : even 2 = true.
+Proof.
+ rewrite even_spec. exists 1. now nzsimpl'.
+Qed.
+
+Lemma odd_2 : odd 2 = false.
+Proof.
+ now rewrite <- negb_even, even_2.
+Qed.
+
+(** Parity and successor *)
+
+Lemma Odd_succ : forall n, Odd (S n) <-> Even n.
+Proof.
+ split; intros (m,H).
+ exists m. apply succ_inj. now rewrite add_1_r in H.
+ exists m. rewrite add_1_r. now f_equiv.
+Qed.
+
+Lemma odd_succ : forall n, odd (S n) = even n.
+Proof.
+ intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec.
+ apply Odd_succ.
+Qed.
+
+Lemma even_succ : forall n, even (S n) = odd n.
+Proof.
+ intros. now rewrite <- negb_odd, odd_succ, negb_even.
+Qed.
+
+Lemma Even_succ : forall n, Even (S n) <-> Odd n.
+Proof.
+ intros. now rewrite <- even_spec, even_succ, odd_spec.
+Qed.
+
+(** Parity and successor of successor *)
+
+Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n.
+Proof.
+ intros. now rewrite Even_succ, Odd_succ.
+Qed.
+
+Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n.
+Proof.
+ intros. now rewrite Odd_succ, Even_succ.
+Qed.
+
+Lemma even_succ_succ : forall n, even (S (S n)) = even n.
+Proof.
+ intros. now rewrite even_succ, odd_succ.
+Qed.
+
+Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n.
+Proof.
+ intros. now rewrite odd_succ, even_succ.
+Qed.
+
+(** Parity and addition *)
+
+Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m).
+Proof.
+ intros.
+ case_eq (even n); case_eq (even m);
+  rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec;
+  intros (m',Hm) (n',Hn).
+ exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm.
+ exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc.
+ exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0.
+ exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1.
+Qed.
+
+Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m).
+Proof.
+ intros. rewrite <- !negb_even. rewrite even_add.
+ now destruct (even n), (even m).
+Qed.
+
+(** Parity and multiplication *)
+
+Lemma even_mul : forall n m, even (mul n m) = even n || even m.
+Proof.
+ intros.
+ case_eq (even n); simpl; rewrite ?even_spec.
+ intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc.
+ case_eq (even m); simpl; rewrite ?even_spec.
+ intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2).
+ (* odd / odd *)
+ rewrite <- !negb_true_iff, !negb_even, !odd_spec.
+ intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m').
+ rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r.
+ now rewrite add_shuffle1, add_assoc, !mul_assoc.
+Qed.
+
+Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m.
+Proof.
+ intros. rewrite <- !negb_even. rewrite even_mul.
+ now destruct (even n), (even m).
+Qed.
+
+(** A particular case : adding by an even number *)
+
+Lemma even_add_even : forall n m, Even m -> even (n+m) = even n.
+Proof.
+ intros n m Hm. apply even_spec in Hm.
+ rewrite even_add, Hm. now destruct (even n).
+Qed.
+
+Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n.
+Proof.
+ intros n m Hm. apply even_spec in Hm.
+ rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n).
+Qed.
+
+Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n.
+Proof.
+ intros n m p Hm. apply even_spec in Hm.
+ apply even_add_even. apply even_spec. now rewrite even_mul, Hm.
+Qed.
+
+Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n.
+Proof.
+ intros n m p Hm. apply even_spec in Hm.
+ apply odd_add_even. apply even_spec. now rewrite even_mul, Hm.
+Qed.
+
+Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n.
+Proof.
+ intros. apply even_add_mul_even. apply even_spec, even_2.
+Qed.
+
+Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n.
+Proof.
+ intros. apply odd_add_mul_even. apply even_spec, even_2.
+Qed.
+
+End NZParityProp.
\ No newline at end of file
diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v
new file mode 100644
index 00000000..58704735
--- /dev/null
+++ b/theories/Numbers/NatInt/NZPow.v
@@ -0,0 +1,411 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Power Function *)
+
+Require Import NZAxioms NZMulOrder.
+
+(** Interface of a power function, then its specification on naturals *)
+
+Module Type Pow (Import A : Typ).
+ Parameters Inline pow : t -> t -> t.
+End Pow.
+
+Module Type PowNotation (A : Typ)(Import B : Pow A).
+ Infix "^" := pow.
+End PowNotation.
+
+Module Type Pow' (A : Typ) := Pow A <+ PowNotation A.
+
+Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A).
+ Declare Instance pow_wd : Proper (eq==>eq==>eq) pow.
+ Axiom pow_0_r : forall a, a^0 == 1.
+ Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
+ Axiom pow_neg_r : forall a b, b<0 -> a^b == 0.
+End NZPowSpec.
+
+(** The above [pow_neg_r] specification is useless (and trivially
+   provable) for N. Having it here allows to already derive
+   some slightly more general statements. *)
+
+Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A.
+Module Type NZPow' (A : NZOrdAxiomsSig) := Pow' A <+ NZPowSpec A.
+
+(** Derived properties of power *)
+
+Module Type NZPowProp
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZPow' A)
+ (Import C : NZMulOrderProp A).
+
+Hint Rewrite pow_0_r pow_succ_r : nz.
+
+(** Power and basic constants *)
+
+Lemma pow_0_l : forall a, 0<a -> 0^a == 0.
+Proof.
+ intros a Ha.
+ destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha').
+ rewrite EQ. now nzsimpl.
+Qed.
+
+Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0.
+Proof.
+ intros a Ha.
+ destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order.
+ now rewrite pow_neg_r.
+ now apply pow_0_l.
+Qed.
+
+Lemma pow_1_r : forall a, a^1 == a.
+Proof.
+ intros. now nzsimpl'.
+Qed.
+
+Lemma pow_1_l : forall a, 0<=a -> 1^a == 1.
+Proof.
+ apply le_ind; intros. solve_proper.
+ now nzsimpl.
+ now nzsimpl.
+Qed.
+
+Hint Rewrite pow_1_r pow_1_l : nz.
+
+Lemma pow_2_r : forall a, a^2 == a*a.
+Proof.
+ intros. rewrite two_succ. nzsimpl; order'.
+Qed.
+
+Hint Rewrite pow_2_r : nz.
+
+(** Power and nullity *)
+
+Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0.
+Proof.
+ intros a b Hb. apply le_ind with (4:=Hb).
+ solve_proper.
+ rewrite pow_0_r. order'.
+ clear b Hb. intros b Hb IH.
+ rewrite pow_succ_r by trivial.
+ intros H. apply eq_mul_0 in H. destruct H; trivial.
+ now apply IH.
+Qed.
+
+Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0.
+Proof.
+ intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b.
+Qed.
+
+Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0<b /\ a==0).
+Proof.
+ intros a b. split.
+ intros H.
+ destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]].
+ now left.
+ rewrite Hb, pow_0_r in H; order'.
+ right. split; trivial. apply pow_eq_0 with b; order.
+ intros [Hb|[Hb Ha]]. now rewrite pow_neg_r.
+ rewrite Ha. apply pow_0_l'. order.
+Qed.
+
+(** Power and addition, multiplication *)
+
+Lemma pow_add_r : forall a b c, 0<=b -> 0<=c ->
+  a^(b+c) == a^b * a^c.
+Proof.
+ intros a b c Hb. apply le_ind with (4:=Hb). solve_proper.
+ now nzsimpl.
+ clear b Hb. intros b Hb IH Hc.
+ nzsimpl; trivial.
+ rewrite IH; trivial. apply mul_assoc.
+ now apply add_nonneg_nonneg.
+Qed.
+
+Lemma pow_mul_l : forall a b c,
+  (a*b)^c == a^c * b^c.
+Proof.
+ intros a b c.
+ destruct (lt_ge_cases c 0) as [Hc|Hc].
+ rewrite !(pow_neg_r _ _ Hc). now nzsimpl.
+ apply le_ind with (4:=Hc). solve_proper.
+ now nzsimpl.
+ clear c Hc. intros c Hc IH.
+ nzsimpl; trivial.
+ rewrite IH; trivial. apply mul_shuffle1.
+Qed.
+
+Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c ->
+  a^(b*c) == (a^b)^c.
+Proof.
+ intros a b c Hb. apply le_ind with (4:=Hb). solve_proper.
+ intros. now nzsimpl.
+ clear b Hb. intros b Hb IH Hc.
+ nzsimpl; trivial.
+ rewrite pow_add_r, IH, pow_mul_l; trivial. apply mul_comm.
+ now apply mul_nonneg_nonneg.
+Qed.
+
+(** Positivity *)
+
+Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b.
+Proof.
+ intros a b Ha.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ now rewrite !(pow_neg_r _ _ Hb).
+ apply le_ind with (4:=Hb). solve_proper.
+ nzsimpl; order'.
+ clear b Hb. intros b Hb IH.
+ nzsimpl; trivial. now apply mul_nonneg_nonneg.
+Qed.
+
+Lemma pow_pos_nonneg : forall a b, 0<a -> 0<=b -> 0<a^b.
+Proof.
+ intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper.
+ nzsimpl; order'.
+ clear b Hb. intros b Hb IH.
+ nzsimpl; trivial. now apply mul_pos_pos.
+Qed.
+
+(** Monotonicity *)
+
+Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> a^c < b^c.
+Proof.
+ intros a b c Hc. apply lt_ind with (4:=Hc). solve_proper.
+ intros (Ha,H). nzsimpl; trivial; order.
+ clear c Hc. intros c Hc IH (Ha,H).
+ nzsimpl; try order.
+ apply mul_lt_mono_nonneg; trivial.
+ apply pow_nonneg; try order.
+ apply IH. now split.
+Qed.
+
+Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c.
+Proof.
+ intros a b c (Ha,H).
+ destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]].
+ rewrite !(pow_neg_r _ _ Hc); now nzsimpl.
+ rewrite Hc; now nzsimpl.
+ apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H].
+ apply lt_le_incl, pow_lt_mono_l; now try split.
+Qed.
+
+Lemma pow_gt_1 : forall a b, 1<a -> (0<b <-> 1<a^b).
+Proof.
+ intros a b Ha. split; intros Hb.
+ rewrite <- (pow_1_l b) by order.
+ apply pow_lt_mono_l; try split; order'.
+ destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial.
+ rewrite pow_neg_r in Hb; order'.
+ rewrite H, pow_0_r in Hb. order.
+Qed.
+
+Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> a^b < a^c.
+Proof.
+ intros a b c Ha Hc H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'.
+ assert (H' : b<=c) by order.
+ destruct (le_exists_sub _ _ H') as (d & EQ & Hd).
+ rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1.
+ apply mul_lt_mono_pos_r.
+ apply pow_pos_nonneg; order'.
+ apply pow_gt_1; trivial.
+ apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial.
+  rewrite <- EQ' in *. rewrite add_0_l in EQ. order.
+Qed.
+
+(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *)
+
+Lemma pow_le_mono_r : forall a b c, 0<a -> b<=c -> a^b <= a^c.
+Proof.
+ intros a b c Ha H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order.
+ apply le_succ_l in Ha; rewrite <- one_succ in Ha.
+ apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha].
+ apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H].
+ apply lt_le_incl, pow_lt_mono_r; order.
+ nzsimpl; order.
+Qed.
+
+Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d ->
+ a^b <= c^d.
+Proof.
+ intros. transitivity (a^d).
+ apply pow_le_mono_r; intuition order.
+ apply pow_le_mono_l; intuition order.
+Qed.
+
+Lemma pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d ->
+ a^b < c^d.
+Proof.
+ intros a b c d (Ha,Hac) (Hb,Hbd).
+ apply le_succ_l in Ha; rewrite <- one_succ in Ha.
+ apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha].
+ transitivity (a^d).
+ apply pow_lt_mono_r; intuition order.
+ apply pow_lt_mono_l; try split; order'.
+ nzsimpl; try order. apply pow_gt_1; order.
+Qed.
+
+(** Injectivity *)
+
+Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0<c ->
+ a^c == b^c -> a == b.
+Proof.
+ intros a b c Ha Hb Hc EQ.
+ destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial.
+ assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial).
+ order.
+ assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial).
+ order.
+Qed.
+
+Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c ->
+ a^b == a^c -> b == c.
+Proof.
+ intros a b c Ha Hb Hc EQ.
+ destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial.
+ assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial).
+ order.
+ assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial).
+ order.
+Qed.
+
+(** Monotonicity results, both ways *)
+
+Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c ->
+  (a<b <-> a^c < b^c).
+Proof.
+ intros a b c Ha Hb Hc.
+ split; intro LT.
+ apply pow_lt_mono_l; try split; trivial.
+ destruct (le_gt_cases b a) as [LE|GT]; trivial.
+ assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order).
+ order.
+Qed.
+
+Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c ->
+  (a<=b <-> a^c <= b^c).
+Proof.
+ intros a b c Ha Hb Hc.
+ split; intro LE.
+ apply pow_le_mono_l; try split; trivial.
+ destruct (le_gt_cases a b) as [LE'|GT]; trivial.
+ assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial).
+ order.
+Qed.
+
+Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c ->
+  (b<c <-> a^b < a^c).
+Proof.
+ intros a b c Ha Hc.
+ split; intro LT.
+ now apply pow_lt_mono_r.
+ destruct (le_gt_cases c b) as [LE|GT]; trivial.
+ assert (a^c <= a^b) by (apply pow_le_mono_r; order').
+ order.
+Qed.
+
+Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c ->
+  (b<=c <-> a^b <= a^c).
+Proof.
+ intros a b c Ha Hc.
+ split; intro LE.
+ apply pow_le_mono_r; order'.
+ destruct (le_gt_cases b c) as [LE'|GT]; trivial.
+ assert (a^c < a^b) by (apply pow_lt_mono_r; order').
+ order.
+Qed.
+
+(** For any a>1, the a^x function is above the identity function *)
+
+Lemma pow_gt_lin_r : forall a b, 1<a -> 0<=b -> b < a^b.
+Proof.
+ intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper.
+ nzsimpl. order'.
+ clear b Hb. intros b Hb IH. nzsimpl; trivial.
+ rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha.
+ transitivity (2*(S b)).
+  nzsimpl'. rewrite <- 2 succ_le_mono.
+  rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
+ apply mul_le_mono_nonneg; trivial.
+ order'.
+ now apply lt_le_incl, lt_succ_r.
+Qed.
+
+(** Someday, we should say something about the full Newton formula.
+    In the meantime, we can at least provide some inequalities about
+    (a+b)^c.
+*)
+
+Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0<c ->
+  a^c + b^c <= (a+b)^c.
+Proof.
+ intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper.
+ nzsimpl; order.
+ clear c Hc. intros c Hc IH.
+ assert (0<=c) by order'.
+ nzsimpl; trivial.
+ transitivity ((a+b)*(a^c + b^c)).
+ rewrite mul_add_distr_r, !mul_add_distr_l.
+ apply add_le_mono.
+ rewrite <- add_0_r at 1. apply add_le_mono_l.
+  apply mul_nonneg_nonneg; trivial.
+  apply pow_nonneg; trivial.
+ rewrite <- add_0_l at 1. apply add_le_mono_r.
+  apply mul_nonneg_nonneg; trivial.
+  apply pow_nonneg; trivial.
+ apply mul_le_mono_nonneg_l; trivial.
+ now apply add_nonneg_nonneg.
+Qed.
+
+(** This upper bound can also be seen as a convexity proof for x^c :
+    image of (a+b)/2 is below the middle of the images of a and b
+*)
+
+Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0<c ->
+  (a+b)^c <= 2^(pred c) * (a^c + b^c).
+Proof.
+ assert (aux : forall a b c, 0<=a<=b -> 0<c ->
+         (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)).
+ (* begin *)
+  intros a b c (Ha,H) Hc.
+  rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'.
+  rewrite <- !add_assoc. apply add_le_mono_l.
+  rewrite !add_assoc. apply add_le_mono_r.
+  destruct (le_exists_sub _ _ H) as (d & EQ & Hd).
+  rewrite EQ.
+  rewrite 2 mul_add_distr_r.
+  rewrite !add_assoc. apply add_le_mono_r.
+  rewrite add_comm. apply add_le_mono_l.
+  apply mul_le_mono_nonneg_l; trivial.
+  apply pow_le_mono_l; try split; order.
+ (* end *)
+ intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper.
+ nzsimpl; order.
+ clear c Hc. intros c Hc IH.
+ assert (0<=c) by order.
+ nzsimpl; trivial.
+ transitivity ((a+b)*(2^(pred c) * (a^c + b^c))).
+ apply mul_le_mono_nonneg_l; trivial.
+ now apply add_nonneg_nonneg.
+ rewrite mul_assoc. rewrite (mul_comm (a+b)).
+ assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order').
+ assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l).
+ assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order).
+ rewrite EQ', <- !mul_assoc.
+ apply mul_le_mono_nonneg_l.
+ apply pow_nonneg; order'.
+ destruct (le_gt_cases a b).
+ apply aux; try split; order'.
+ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)).
+ apply aux; try split; order'.
+Qed.
+
+End NZPowProp.
diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v
index 7279325d..13c26233 100644
--- a/theories/Numbers/NatInt/NZProperties.v
+++ b/theories/Numbers/NatInt/NZProperties.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,13 +8,11 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NZAxioms NZMulOrder.
 
 (** This functor summarizes all known facts about NZ.
-    For the moment it is only an alias to [NZMulOrderPropFunct], which
+    For the moment it is only an alias to [NZMulOrderProp], which
     subsumes all others.
 *)
 
-Module Type NZPropFunct := NZMulOrderPropSig.
+Module Type NZProp := NZMulOrderProp.
diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v
new file mode 100644
index 00000000..6e85c689
--- /dev/null
+++ b/theories/Numbers/NatInt/NZSqrt.v
@@ -0,0 +1,734 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Square Root Function *)
+
+Require Import NZAxioms NZMulOrder.
+
+(** Interface of a sqrt function, then its specification on naturals *)
+
+Module Type Sqrt (Import A : Typ).
+ Parameter Inline sqrt : t -> t.
+End Sqrt.
+
+Module Type SqrtNotation (A : Typ)(Import B : Sqrt A).
+ Notation "√ x" := (sqrt x) (at level 6).
+End SqrtNotation.
+
+Module Type Sqrt' (A : Typ) := Sqrt A <+ SqrtNotation A.
+
+Module Type NZSqrtSpec (Import A : NZOrdAxiomsSig')(Import B : Sqrt' A).
+ Axiom sqrt_spec : forall a, 0<=a -> √a * √a <= a < S (√a) * S (√a).
+ Axiom sqrt_neg : forall a, a<0 -> √a == 0.
+End NZSqrtSpec.
+
+Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A.
+Module Type NZSqrt' (A : NZOrdAxiomsSig) := Sqrt' A <+ NZSqrtSpec A.
+
+(** Derived properties of power *)
+
+Module Type NZSqrtProp
+ (Import A : NZOrdAxiomsSig')
+ (Import B : NZSqrt' A)
+ (Import C : NZMulOrderProp A).
+
+Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²").
+
+(** First, sqrt is non-negative *)
+
+Lemma sqrt_spec_nonneg : forall b,
+ b² < (S b)² -> 0 <= b.
+Proof.
+ intros b LT.
+ destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso.
+ assert ((S b)² < b²).
+  rewrite mul_succ_l, <- (add_0_r b²).
+  apply add_lt_le_mono.
+  apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r.
+  now apply le_succ_l.
+ order.
+Qed.
+
+Lemma sqrt_nonneg : forall a, 0<=√a.
+Proof.
+ intros. destruct (lt_ge_cases a 0) as [Ha|Ha].
+ now rewrite (sqrt_neg _ Ha).
+ apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order.
+Qed.
+
+(** The spec of sqrt indeed determines it *)
+
+Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b.
+Proof.
+ intros a b (LEb,LTb).
+ assert (Ha : 0<=a) by (transitivity b²; trivial using square_nonneg).
+ assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order).
+ assert (Ha': 0<=√a) by now apply sqrt_nonneg.
+ destruct (sqrt_spec a Ha) as (LEa,LTa).
+ assert (b <= √a).
+  apply lt_succ_r, square_lt_simpl_nonneg; [|order].
+  now apply lt_le_incl, lt_succ_r.
+ assert (√a <= b).
+  apply lt_succ_r, square_lt_simpl_nonneg; [|order].
+  now apply lt_le_incl, lt_succ_r.
+ order.
+Qed.
+
+(** Hence sqrt is a morphism *)
+
+Instance sqrt_wd : Proper (eq==>eq) sqrt.
+Proof.
+ intros x x' Hx.
+ destruct (lt_ge_cases x 0) as [H|H].
+ rewrite 2 sqrt_neg; trivial. reflexivity.
+ now rewrite <- Hx.
+ apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec.
+Qed.
+
+(** An alternate specification *)
+
+Lemma sqrt_spec_alt : forall a, 0<=a -> exists r,
+ a == (√a)² + r /\ 0 <= r <= 2*√a.
+Proof.
+ intros a Ha.
+ destruct (sqrt_spec _ Ha) as (LE,LT).
+ destruct (le_exists_sub _ _ LE) as (r & Hr & Hr').
+ exists r.
+ split. now rewrite add_comm.
+ split. trivial.
+ apply (add_le_mono_r _ _ (√a)²).
+ rewrite <- Hr, add_comm.
+ generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc.
+Qed.
+
+Lemma sqrt_unique' : forall a b c, 0<=c<=2*b ->
+ a == b² + c -> √a == b.
+Proof.
+ intros a b c (Hc,H) EQ.
+ apply sqrt_unique.
+ rewrite EQ.
+ split.
+ rewrite <- add_0_r at 1. now apply add_le_mono_l.
+ nzsimpl. apply lt_succ_r.
+ rewrite <- add_assoc. apply add_le_mono_l.
+ generalize H; now nzsimpl'.
+Qed.
+
+(** Sqrt is exact on squares *)
+
+Lemma sqrt_square : forall a, 0<=a -> √(a²) == a.
+Proof.
+ intros a Ha.
+ apply sqrt_unique' with 0.
+ split. order. apply mul_nonneg_nonneg; order'. now nzsimpl.
+Qed.
+
+(** Sqrt and predecessors of squares *)
+
+Lemma sqrt_pred_square : forall a, 0<a -> √(P a²) == P a.
+Proof.
+ intros a Ha.
+ apply sqrt_unique.
+ assert (EQ := lt_succ_pred 0 a Ha).
+ rewrite EQ. split.
+ apply lt_succ_r.
+ rewrite (lt_succ_pred 0).
+ assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ).
+ assert (P a < a) by (now rewrite <- le_succ_l, EQ).
+ apply mul_lt_mono_nonneg; trivial.
+ now apply mul_pos_pos.
+ apply le_succ_l.
+ rewrite (lt_succ_pred 0). reflexivity. now apply mul_pos_pos.
+Qed.
+
+(** Sqrt is a monotone function (but not a strict one) *)
+
+Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b.
+Proof.
+ intros a b Hab.
+ destruct (lt_ge_cases a 0) as [Ha|Ha].
+ rewrite (sqrt_neg _ Ha). apply sqrt_nonneg.
+ assert (Hb : 0 <= b) by order.
+ destruct (sqrt_spec a Ha) as (LE,_).
+ destruct (sqrt_spec b Hb) as (_,LT).
+ apply lt_succ_r.
+ apply square_lt_simpl_nonneg; try order.
+ now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
+Qed.
+
+(** No reverse result for <=, consider for instance √2 <= √1 *)
+
+Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b.
+Proof.
+ intros a b H.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order.
+ destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|].
+ destruct (sqrt_spec a Ha) as (_,LT).
+ destruct (sqrt_spec b Hb) as (LE,_).
+ apply le_succ_l in H.
+ assert ((S (√a))² <= (√b)²).
+  apply mul_le_mono_nonneg; trivial.
+  now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
+  now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
+ order.
+Qed.
+
+(** When left side is a square, we have an equivalence for <= *)
+
+Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a).
+Proof.
+ intros a b Ha Hb. split; intros H.
+ rewrite <- (sqrt_square b); trivial.
+ now apply sqrt_le_mono.
+ destruct (sqrt_spec a Ha) as (LE,LT).
+ transitivity (√a)²; trivial.
+ now apply mul_le_mono_nonneg.
+Qed.
+
+(** When right side is a square, we have an equivalence for < *)
+
+Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a<b² <-> √a < b).
+Proof.
+ intros a b Ha Hb. split; intros H.
+ destruct (sqrt_spec a Ha) as (LE,_).
+ apply square_lt_simpl_nonneg; try order.
+ rewrite <- (sqrt_square b Hb) in H.
+ now apply sqrt_lt_cancel.
+Qed.
+
+(** Sqrt and basic constants *)
+
+Lemma sqrt_0 : √0 == 0.
+Proof.
+ rewrite <- (mul_0_l 0) at 1. now apply sqrt_square.
+Qed.
+
+Lemma sqrt_1 : √1 == 1.
+Proof.
+ rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'.
+Qed.
+
+Lemma sqrt_2 : √2 == 1.
+Proof.
+ apply sqrt_unique' with 1. nzsimpl; split; order'. now nzsimpl'.
+Qed.
+
+Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a.
+Proof.
+ intros a. split; intros Ha. apply sqrt_lt_cancel. now rewrite sqrt_0.
+ rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono.
+ now rewrite one_succ, le_succ_l.
+Qed.
+
+Lemma sqrt_lt_lin : forall a, 1<a -> √a<a.
+Proof.
+ intros a Ha. rewrite <- sqrt_lt_square; try order'.
+ rewrite <- (mul_1_r a) at 1.
+ rewrite <- mul_lt_mono_pos_l; order'.
+Qed.
+
+Lemma sqrt_le_lin : forall a, 0<=a -> √a<=a.
+Proof.
+ intros a Ha.
+ destruct (le_gt_cases a 0) as [H|H].
+ setoid_replace a with 0 by order. now rewrite sqrt_0.
+ destruct (le_gt_cases a 1) as [H'|H'].
+ rewrite <- le_succ_l, <- one_succ in H.
+ setoid_replace a with 1 by order. now rewrite sqrt_1.
+ now apply lt_le_incl, sqrt_lt_lin.
+Qed.
+
+(** Sqrt and multiplication. *)
+
+(** Due to rounding error, we don't have the usual √(a*b) = √a*√b
+    but only lower and upper bounds. *)
+
+Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b).
+Proof.
+ intros a b.
+ destruct (lt_ge_cases a 0) as [Ha|Ha].
+ rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+ rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg.
+ assert (Ha':=sqrt_nonneg a).
+ assert (Hb':=sqrt_nonneg b).
+ apply sqrt_le_square; try now apply mul_nonneg_nonneg.
+ rewrite mul_shuffle1.
+ apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg.
+  now apply sqrt_spec.
+  now apply sqrt_spec.
+Qed.
+
+Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b).
+Proof.
+ intros a b Ha Hb.
+ apply sqrt_lt_square.
+ now apply mul_nonneg_nonneg.
+ apply mul_nonneg_nonneg.
+ now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
+ now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
+ rewrite mul_shuffle1.
+ apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec.
+Qed.
+
+(** And we can't find better approximations in general.
+    - The lower bound is exact for squares
+    - Concerning the upper bound, for any c>0, take a=b=c²-1,
+      then √(a*b) = c² -1 while S √a = S √b = c
+*)
+
+(** Sqrt and successor :
+    - the sqrt function climbs by at most 1 at a time
+    - otherwise it stays at the same value
+    - the +1 steps occur for squares
+*)
+
+Lemma sqrt_succ_le : forall a, 0<=a -> √(S a) <= S (√a).
+Proof.
+ intros a Ha.
+ apply lt_succ_r.
+ apply sqrt_lt_square.
+ now apply le_le_succ_r.
+ apply le_le_succ_r, le_le_succ_r, sqrt_nonneg.
+ rewrite <- (add_1_l (S (√a))).
+ apply lt_le_trans with (1²+(S (√a))²).
+ rewrite mul_1_l, add_1_l, <- succ_lt_mono.
+ now apply sqrt_spec.
+ apply add_square_le. order'. apply le_le_succ_r, sqrt_nonneg.
+Qed.
+
+Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a.
+Proof.
+ intros a Ha.
+ destruct (le_gt_cases (√(S a)) (√a)) as [H|H].
+ right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order.
+ left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order.
+Qed.
+
+Lemma sqrt_eq_succ_iff_square : forall a, 0<=a ->
+ (√(S a) == S (√a) <-> exists b, 0<b /\ S a == b²).
+Proof.
+ intros a Ha. split.
+ intros EQ. exists (S (√a)).
+ split. apply lt_succ_r, sqrt_nonneg.
+ generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l.
+ assert (Ha' : 0 <= S a) by now apply le_le_succ_r.
+ generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order.
+ intros (b & Hb & H).
+ rewrite H. rewrite sqrt_square; try order.
+ symmetry.
+ rewrite <- (lt_succ_pred 0 b Hb). f_equiv.
+ rewrite <- (lt_succ_pred 0 b²) in H. apply succ_inj in H.
+ now rewrite H, sqrt_pred_square.
+ now apply mul_pos_pos.
+Qed.
+
+(** Sqrt and addition *)
+
+Lemma sqrt_add_le : forall a b, √(a+b) <= √a + √b.
+Proof.
+ assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b).
+  intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl.
+  apply sqrt_le_mono.
+  rewrite <- (add_0_l b) at 2.
+  apply add_le_mono_r; order.
+ intros a b.
+ destruct (lt_ge_cases a 0) as [Ha|Ha]. now apply AUX.
+ destruct (lt_ge_cases b 0) as [Hb|Hb].
+  rewrite (add_comm a), (add_comm (√a)); now apply AUX.
+ assert (Ha':=sqrt_nonneg a).
+ assert (Hb':=sqrt_nonneg b).
+ rewrite <- lt_succ_r.
+ apply sqrt_lt_square.
+  now apply add_nonneg_nonneg.
+  now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg.
+ destruct (sqrt_spec a Ha) as (_,LTa).
+ destruct (sqrt_spec b Hb) as (_,LTb).
+ revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r.
+ intros LTa LTb.
+ assert (H:=add_le_mono _ _ _ _ LTa LTb).
+ etransitivity; [eexact H|]. clear LTa LTb H.
+ rewrite <- (add_assoc _ (√a) (√a)).
+ rewrite <- (add_assoc _ (√b) (√b)).
+ rewrite add_shuffle1.
+ rewrite <- (add_assoc _ (√a + √b)).
+ rewrite (add_shuffle1 (√a) (√b)).
+ apply add_le_mono_r.
+ now apply add_square_le.
+Qed.
+
+(** convexity inequality for sqrt: sqrt of middle is above middle
+    of square roots. *)
+
+Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> √a + √b <= √(2*(a+b)).
+Proof.
+ intros a b Ha Hb.
+ assert (Ha':=sqrt_nonneg a).
+ assert (Hb':=sqrt_nonneg b).
+ apply sqrt_le_square.
+  apply mul_nonneg_nonneg. order'. now apply add_nonneg_nonneg.
+  now apply add_nonneg_nonneg.
+ transitivity (2*((√a)² + (√b)²)).
+ now apply square_add_le.
+ apply mul_le_mono_nonneg_l. order'.
+ apply add_le_mono; now apply sqrt_spec.
+Qed.
+
+End NZSqrtProp.
+
+Module Type NZSqrtUpProp
+ (Import A : NZDecOrdAxiomsSig')
+ (Import B : NZSqrt' A)
+ (Import C : NZMulOrderProp A)
+ (Import D : NZSqrtProp A B C).
+
+(** * [sqrt_up] : a square root that rounds up instead of down *)
+
+Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²").
+
+(** For once, we define instead of axiomatizing, thanks to sqrt *)
+
+Definition sqrt_up a :=
+ match compare 0 a with
+  | Lt => S √(P a)
+  | _ => 0
+ end.
+
+Local Notation "√° a" := (sqrt_up a) (at level 6, no associativity).
+
+Lemma sqrt_up_eqn0 : forall a, a<=0 -> √°a == 0.
+Proof.
+ intros a Ha. unfold sqrt_up. case compare_spec; try order.
+Qed.
+
+Lemma sqrt_up_eqn : forall a, 0<a -> √°a == S √(P a).
+Proof.
+ intros a Ha. unfold sqrt_up. case compare_spec; try order.
+Qed.
+
+Lemma sqrt_up_spec : forall a, 0<a -> (P √°a)² < a <= (√°a)².
+Proof.
+ intros a Ha.
+ rewrite sqrt_up_eqn, pred_succ; trivial.
+ assert (Ha' := lt_succ_pred 0 a Ha).
+ rewrite <- Ha' at 3 4.
+ rewrite le_succ_l, lt_succ_r.
+ apply sqrt_spec.
+ now rewrite <- lt_succ_r, Ha'.
+Qed.
+
+(** First, [sqrt_up] is non-negative *)
+
+Lemma sqrt_up_nonneg : forall a, 0<=√°a.
+Proof.
+ intros. destruct (le_gt_cases a 0) as [Ha|Ha].
+ now rewrite sqrt_up_eqn0.
+ rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg.
+Qed.
+
+(** [sqrt_up] is a morphism *)
+
+Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up.
+Proof.
+ assert (Proper (eq==>eq==>Logic.eq) compare).
+  intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order.
+ intros x x' Hx. unfold sqrt_up. rewrite Hx. case compare; now rewrite ?Hx.
+Qed.
+
+(** The spec of [sqrt_up] indeed determines it *)
+
+Lemma sqrt_up_unique : forall a b, 0<b -> (P b)² < a <= b² -> √°a == b.
+Proof.
+ intros a b Hb (LEb,LTb).
+ assert (Ha : 0<a)
+  by (apply le_lt_trans with (P b)²; trivial using square_nonneg).
+ rewrite sqrt_up_eqn; trivial.
+ assert (Hb' := lt_succ_pred 0 b Hb).
+ rewrite <- Hb'. f_equiv. apply sqrt_unique.
+ rewrite <- le_succ_l, <- lt_succ_r, Hb'.
+ rewrite (lt_succ_pred 0 a Ha). now split.
+Qed.
+
+(** [sqrt_up] is exact on squares *)
+
+Lemma sqrt_up_square : forall a, 0<=a -> √°(a²) == a.
+Proof.
+ intros a Ha.
+ le_elim Ha.
+ rewrite sqrt_up_eqn by (now apply mul_pos_pos).
+ rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial.
+ rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl.
+Qed.
+
+(** [sqrt_up] and successors of squares *)
+
+Lemma sqrt_up_succ_square : forall a, 0<=a -> √°(S a²) == S a.
+Proof.
+ intros a Ha.
+ rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg).
+ now rewrite pred_succ, sqrt_square.
+Qed.
+
+(** Basic constants *)
+
+Lemma sqrt_up_0 : √°0 == 0.
+Proof.
+ rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square.
+Qed.
+
+Lemma sqrt_up_1 : √°1 == 1.
+Proof.
+ rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'.
+Qed.
+
+Lemma sqrt_up_2 : √°2 == 2.
+Proof.
+ rewrite sqrt_up_eqn by order'.
+ now rewrite two_succ, pred_succ, sqrt_1.
+Qed.
+
+(**  Links between sqrt and [sqrt_up] *)
+
+Lemma le_sqrt_sqrt_up : forall a, √a <= √°a.
+Proof.
+ intros a. unfold sqrt_up. case compare_spec; intros H.
+ rewrite <- H, sqrt_0. order.
+ rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le.
+ apply lt_succ_r. now rewrite (lt_succ_pred 0 a H).
+ now rewrite sqrt_neg.
+Qed.
+
+Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a).
+Proof.
+ intros a. unfold sqrt_up.
+ case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg.
+ rewrite <- succ_le_mono. apply sqrt_le_mono.
+ rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r.
+Qed.
+
+Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)².
+Proof.
+ intros a H. split.
+ now apply sqrt_spec.
+ le_elim H.
+ now apply sqrt_up_spec.
+ now rewrite <-H, sqrt_up_0, mul_0_l.
+Qed.
+
+Lemma sqrt_sqrt_up_exact :
+ forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²).
+Proof.
+ intros a Ha.
+ split. intros. exists √a.
+  split. apply sqrt_nonneg.
+  generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order.
+ intros (b & Hb & Hb'). rewrite Hb'.
+ now rewrite sqrt_square, sqrt_up_square.
+Qed.
+
+(** [sqrt_up] is a monotone function (but not a strict one) *)
+
+Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases a 0) as [Ha|Ha].
+ rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg.
+ rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono.
+ apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order.
+Qed.
+
+(** No reverse result for <=, consider for instance √°3 <= √°2 *)
+
+Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b.
+Proof.
+ intros a b H.
+ destruct (le_gt_cases b 0) as [Hb|Hb].
+ rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order.
+ destruct (le_gt_cases a 0) as [Ha|Ha]; [order|].
+ rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono.
+ apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn.
+Qed.
+
+(** When left side is a square, we have an equivalence for < *)
+
+Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a).
+Proof.
+ intros a b Ha Hb. split; intros H.
+ destruct (sqrt_up_spec a) as (LE,LT).
+ apply le_lt_trans with b²; trivial using square_nonneg.
+ apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg.
+ apply sqrt_up_lt_cancel. now rewrite sqrt_up_square.
+Qed.
+
+(** When right side is a square, we have an equivalence for <= *)
+
+Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b).
+Proof.
+ intros a b Ha Hb. split; intros H.
+ rewrite <- (sqrt_up_square b Hb).
+ now apply sqrt_up_le_mono.
+ apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg].
+ transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec.
+Qed.
+
+Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a.
+Proof.
+ intros a. split; intros Ha. apply sqrt_up_lt_cancel. now rewrite sqrt_up_0.
+ rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono.
+ now rewrite one_succ, le_succ_l.
+Qed.
+
+Lemma sqrt_up_lt_lin : forall a, 2<a -> √°a < a.
+Proof.
+ intros a Ha.
+ rewrite sqrt_up_eqn by order'.
+ assert (Ha' := lt_succ_pred 2 a Ha).
+ rewrite <- Ha' at 2. rewrite <- succ_lt_mono.
+ apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ.
+Qed.
+
+Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a.
+Proof.
+ intros a Ha.
+ le_elim Ha.
+ rewrite sqrt_up_eqn; trivial. apply le_succ_l.
+ apply le_lt_trans with (P a). apply sqrt_le_lin.
+ now rewrite <- lt_succ_r, (lt_succ_pred 0).
+ rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r.
+ now rewrite <- Ha, sqrt_up_0.
+Qed.
+
+(** [sqrt_up] and multiplication. *)
+
+(** Due to rounding error, we don't have the usual [√(a*b) = √a*√b]
+    but only lower and upper bounds. *)
+
+Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √°b.
+Proof.
+ intros a b Ha Hb.
+ apply sqrt_up_le_square.
+ now apply mul_nonneg_nonneg.
+ apply mul_nonneg_nonneg; apply sqrt_up_nonneg.
+ rewrite mul_shuffle1.
+ apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec.
+Qed.
+
+Lemma sqrt_up_mul_below : forall a b, 0<a -> 0<b -> (P √°a)*(P √°b) < √°(a*b).
+Proof.
+ intros a b Ha Hb.
+ apply sqrt_up_lt_square.
+ apply mul_nonneg_nonneg; order.
+ apply mul_nonneg_nonneg; apply lt_succ_r.
+ rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos.
+ rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos.
+ rewrite mul_shuffle1.
+ apply mul_lt_mono_nonneg; trivial using square_nonneg;
+  now apply sqrt_up_spec.
+Qed.
+
+(** And we can't find better approximations in general.
+    - The upper bound is exact for squares
+    - Concerning the lower bound, for any c>0, take [a=b=c²+1],
+      then [√°(a*b) = c²+1] while [P √°a = P √°b = c]
+*)
+
+(** [sqrt_up] and successor :
+    - the [sqrt_up] function climbs by at most 1 at a time
+    - otherwise it stays at the same value
+    - the +1 steps occur after squares
+*)
+
+Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a).
+Proof.
+ intros a Ha.
+ apply sqrt_up_le_square.
+ now apply le_le_succ_r.
+ apply le_le_succ_r, sqrt_up_nonneg.
+ rewrite <- (add_1_l (√°a)).
+ apply le_trans with (1²+(√°a)²).
+ rewrite mul_1_l, add_1_l, <- succ_le_mono.
+ now apply sqrt_sqrt_up_spec.
+ apply add_square_le. order'. apply sqrt_up_nonneg.
+Qed.
+
+Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a.
+Proof.
+ intros a Ha.
+ destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H].
+ right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order.
+ left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order.
+Qed.
+
+Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a ->
+ (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²).
+Proof.
+ intros a Ha. split.
+ intros EQ.
+ le_elim Ha.
+ exists (√°a). split. apply sqrt_up_nonneg.
+ generalize (proj2 (sqrt_up_spec a Ha)).
+ assert (Ha' : 0 < S a) by (apply lt_succ_r; order').
+ generalize (proj1 (sqrt_up_spec (S a) Ha')).
+ rewrite EQ, pred_succ, lt_succ_r. order.
+ exists 0. nzsimpl. now split.
+ intros (b & Hb & H).
+ now rewrite H, sqrt_up_succ_square, sqrt_up_square.
+Qed.
+
+(** [sqrt_up] and addition *)
+
+Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b.
+Proof.
+ assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b).
+  intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl.
+  apply sqrt_up_le_mono.
+  rewrite <- (add_0_l b) at 2.
+  apply add_le_mono_r; order.
+ intros a b.
+ destruct (le_gt_cases a 0) as [Ha|Ha]. now apply AUX.
+ destruct (le_gt_cases b 0) as [Hb|Hb].
+  rewrite (add_comm a), (add_comm (√°a)); now apply AUX.
+ rewrite 2 sqrt_up_eqn; trivial.
+ nzsimpl. rewrite <- succ_le_mono.
+ transitivity (√(P a) + √b).
+ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le.
+ apply add_le_mono_l.
+ apply le_sqrt_sqrt_up.
+ now apply add_pos_pos.
+Qed.
+
+(** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle
+    of square roots. We cannot say more, for instance take a=b=2, then
+    2+2 <= S 3 *)
+
+Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)).
+Proof.
+ intros a b Ha Hb.
+ le_elim Ha.
+ le_elim Hb.
+ rewrite 3 sqrt_up_eqn; trivial.
+ nzsimpl. rewrite <- 2 succ_le_mono.
+ etransitivity; [eapply add_sqrt_le|].
+ apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha).
+ apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb).
+ apply sqrt_le_mono.
+ apply lt_succ_r. rewrite (lt_succ_pred 0).
+ apply mul_lt_mono_pos_l. order'.
+ apply add_lt_mono.
+ apply le_succ_l. now rewrite (lt_succ_pred 0).
+ apply le_succ_l. now rewrite (lt_succ_pred 0).
+ apply mul_pos_pos. order'. now apply add_pos_pos.
+ apply mul_pos_pos. order'. now apply add_pos_pos.
+ rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono.
+ rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'.
+ rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono.
+ rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'.
+Qed.
+
+End NZSqrtUpProp.
diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v
index 4185de95..72e09f15 100644
--- a/theories/Numbers/Natural/Abstract/NAdd.v
+++ b/theories/Numbers/Natural/Abstract/NAdd.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NBase.
 
-Module NAddPropFunct (Import N : NAxiomsSig').
-Include NBasePropFunct N.
+Module NAddProp (Import N : NAxiomsMiniSig').
+Include NBaseProp N.
 
 (** 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 *)
@@ -24,9 +22,9 @@ intros n m; induct n.
 nzsimpl; intuition.
 intros n IH. nzsimpl.
 setoid_replace (S (n + m) == 0) with False by
- (apply -> neg_false; apply neq_succ_0).
+ (apply neg_false; apply neq_succ_0).
 setoid_replace (S n == 0) with False by
- (apply -> neg_false; apply neq_succ_0). tauto.
+ (apply neg_false; apply neq_succ_0). tauto.
 Qed.
 
 Theorem eq_add_succ :
@@ -47,13 +45,13 @@ Qed.
 Theorem eq_add_1 : forall n m,
   n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1.
 Proof.
-intros n m H.
+intros n m. rewrite one_succ. intro H.
 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]].
+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.
+apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split.
 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.
+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, m ~= S (n + m).
@@ -77,5 +75,5 @@ intros n m H; rewrite (add_comm n (P m));
 rewrite (add_comm n m); now apply add_pred_l.
 Qed.
 
-End NAddPropFunct.
+End NAddProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v
index 0282a6b8..da41886f 100644
--- a/theories/Numbers/Natural/Abstract/NAddOrder.v
+++ b/theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NOrder.
 
-Module NAddOrderPropFunct (Import N : NAxiomsSig').
-Include NOrderPropFunct N.
+Module NAddOrderProp (Import N : NAxiomsMiniSig').
+Include NOrderProp N.
 
 (** Theorems true for natural numbers, not for integers *)
 
@@ -45,4 +43,4 @@ Proof.
 intros; apply add_nonneg_pos. apply le_0_l. assumption.
 Qed.
 
-End NAddOrderPropFunct.
+End NAddOrderProp.
diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v
index d1cc9972..ca6ccc1b 100644
--- a/theories/Numbers/Natural/Abstract/NAxioms.v
+++ b/theories/Numbers/Natural/Abstract/NAxioms.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,32 +8,60 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Export Bool NZAxioms NZParity NZPow NZSqrt NZLog NZDiv NZGcd NZBits.
 
-Require Export NZAxioms.
+(** From [NZ], we obtain natural numbers just by stating that [pred 0] == 0 *)
 
-Set Implicit Arguments.
+Module Type NAxiom (Import NZ : NZDomainSig').
+ Axiom pred_0 : P 0 == 0.
+End NAxiom.
 
-Module Type NAxioms (Import NZ : NZDomainSig').
+Module Type NAxiomsMiniSig := NZOrdAxiomsSig <+ NAxiom.
+Module Type NAxiomsMiniSig' := NZOrdAxiomsSig' <+ NAxiom.
 
-Axiom pred_0 : P 0 == 0.
+(** Let's now add some more functions and their specification *)
 
-Parameter Inline recursion : forall A : Type, A -> (t -> A -> A) -> t -> A.
-Implicit Arguments recursion [A].
+(** Division Function : we reuse NZDiv.DivMod and NZDiv.NZDivCommon,
+    and add to that a N-specific constraint. *)
 
-Declare Instance recursion_wd (A : Type) (Aeq : relation A) :
- Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
+Module Type NDivSpecific (Import N : NAxiomsMiniSig')(Import DM : DivMod' N).
+ Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b.
+End NDivSpecific.
+
+(** For all other functions, the NZ axiomatizations are enough. *)
+
+(** We now group everything together. *)
+
+Module Type NAxiomsSig := NAxiomsMiniSig <+ OrderFunctions
+  <+ NZParity.NZParity <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2
+  <+ NZGcd.NZGcd <+ NZDiv.NZDiv <+ NZBits.NZBits <+ NZSquare.
+
+Module Type NAxiomsSig' := NAxiomsMiniSig' <+ OrderFunctions'
+  <+ NZParity.NZParity <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2
+  <+ NZGcd.NZGcd' <+ NZDiv.NZDiv' <+ NZBits.NZBits' <+ NZSquare.
+
+
+(** It could also be interesting to have a constructive recursor function. *)
+
+Module Type NAxiomsRec (Import NZ : NZDomainSig').
+
+Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A.
+
+Declare Instance recursion_wd {A : Type} (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
 
 Axiom recursion_0 :
-  forall (A : Type) (a : A) (f : t -> A -> A), recursion a f 0 = a.
+  forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a.
 
 Axiom recursion_succ :
-  forall (A : Type) (Aeq : relation A) (a : A) (f : t -> A -> A),
+  forall {A} (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)).
 
-End NAxioms.
+End NAxiomsRec.
 
-Module Type NAxiomsSig := NZOrdAxiomsSig <+ NAxioms.
-Module Type NAxiomsSig' := NZOrdAxiomsSig' <+ NAxioms.
+Module Type NAxiomsRecSig := NAxiomsMiniSig <+ NAxiomsRec.
+Module Type NAxiomsRecSig' := NAxiomsMiniSig' <+ NAxiomsRec.
 
+Module Type NAxiomsFullSig := NAxiomsSig <+ NAxiomsRec.
+Module Type NAxiomsFullSig' := NAxiomsSig' <+ NAxiomsRec.
diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v
index efaba960..ac8a0522 100644
--- a/theories/Numbers/Natural/Abstract/NBase.v
+++ b/theories/Numbers/Natural/Abstract/NBase.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,48 +8,23 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Decidable.
 Require Export NAxioms.
 Require Import NZProperties.
 
-Module NBasePropFunct (Import N : NAxiomsSig').
+Module NBaseProp (Import N : NAxiomsMiniSig').
 (** First, we import all known facts about both natural numbers and integers. *)
-Include NZPropFunct N.
-
-(** 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 : Type) (a b : A) (n : N.t) : A :=
-  recursion a (fun _ _ => b) n.
-
-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.
-repeat red; intros. apply recursion_wd; auto. repeat red; auto.
-Qed.
-
-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.
+Include NZProp N.
 
-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.
-Qed.
+(** From [pred_0] and order facts, we can prove that 0 isn't a successor. *)
 
 Theorem neq_succ_0 : forall n, S n ~= 0.
 Proof.
-intros n H.
-generalize (Logic.eq_refl (if_zero false true 0)).
-rewrite <- H at 1. rewrite if_zero_0, if_zero_succ; discriminate.
+ intros n EQ.
+ assert (EQ' := pred_succ n).
+ rewrite EQ, pred_0 in EQ'.
+ rewrite <- EQ' in EQ.
+ now apply (neq_succ_diag_l 0).
 Qed.
 
 Theorem neq_0_succ : forall n, 0 ~= S n.
@@ -66,7 +41,7 @@ nzinduct n.
 now apply eq_le_incl.
 intro n; split.
 apply le_le_succ_r.
-intro H; apply -> le_succ_r in H; destruct H as [H | H].
+intro H; apply le_succ_r in H; destruct H as [H | H].
 assumption.
 symmetry in H; false_hyp H neq_succ_0.
 Qed.
@@ -119,12 +94,11 @@ Qed.
 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.
-split; intro H; [symmetry in H; false_hyp H neq_succ_0 | elim H].
+rewrite pred_0. now split; [left|].
 intro n. rewrite pred_succ.
-setoid_replace (S n == 0) with False using relation iff by
-  (apply -> neg_false; apply neq_succ_0).
-rewrite succ_inj_wd. tauto.
+split. intros H; right. now rewrite H, one_succ.
+intros [H|H]. elim (neq_succ_0 _ H).
+apply succ_inj_wd. now rewrite <- one_succ.
 Qed.
 
 Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n.
@@ -155,6 +129,7 @@ Theorem pair_induction :
   A 0 -> A 1 ->
     (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n.
 Proof.
+rewrite one_succ.
 intros until 3.
 assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))].
 induct n; [ | intros n [IH1 IH2]]; auto.
@@ -204,7 +179,7 @@ Ltac double_induct n m :=
   try intros until n;
   try intros until m;
   pattern n, m; apply double_induction; clear n m;
-  [solve_relation_wd | | | ].
+  [solve_proper | | | ].
 
-End NBasePropFunct.
+End NBaseProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v
new file mode 100644
index 00000000..c66f003e
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NBits.v
@@ -0,0 +1,1463 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool NAxioms NSub NPow NDiv NParity NLog.
+
+(** Derived properties of bitwise operations *)
+
+Module Type NBitsProp
+ (Import A : NAxiomsSig')
+ (Import B : NSubProp A)
+ (Import C : NParityProp A B)
+ (Import D : NPowProp A B C)
+ (Import E : NDivProp A B)
+ (Import F : NLog2Prop A B C D).
+
+Include BoolEqualityFacts A.
+
+Ltac order_nz := try apply pow_nonzero; order'.
+Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz.
+
+(** Some properties of power and division *)
+
+Lemma pow_sub_r : forall a b c, a~=0 -> c<=b -> a^(b-c) == a^b / a^c.
+Proof.
+ intros a b c Ha H.
+ apply div_unique with 0.
+ generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'.
+ nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add.
+Qed.
+
+Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 ->
+ (a/b)^c == a^c / b^c.
+Proof.
+ intros a b c Hb H.
+ apply div_unique with 0.
+ generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'.
+ nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact.
+Qed.
+
+(** An injection from bits [true] and [false] to numbers 1 and 0.
+    We declare it as a (local) coercion for shorter statements. *)
+
+Definition b2n (b:bool) := if b then 1 else 0.
+Local Coercion b2n : bool >-> t.
+
+Instance b2n_proper : Proper (Logic.eq ==> eq) b2n.
+Proof. solve_proper. Qed.
+
+Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b.
+Proof.
+ elim (Even_or_Odd a); [intros (a',H)| intros (a',H)].
+ exists a'. exists false. now nzsimpl.
+ exists a'. exists true. now simpl.
+Qed.
+
+(** We can compact [testbit_odd_0] [testbit_even_0]
+    [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *)
+
+Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b.
+Proof.
+ destruct b; simpl; rewrite ?add_0_r.
+ apply testbit_odd_0.
+ apply testbit_even_0.
+Qed.
+
+Lemma testbit_succ_r a (b:bool) n :
+ testbit (2*a+b) (succ n) = testbit a n.
+Proof.
+ destruct b; simpl; rewrite ?add_0_r.
+ apply testbit_odd_succ, le_0_l.
+ apply testbit_even_succ, le_0_l.
+Qed.
+
+(** Alternative caracterisations of [testbit] *)
+
+(** This concise equation could have been taken as specification
+   for testbit in the interface, but it would have been hard to
+   implement with little initial knowledge about div and mod *)
+
+Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2.
+Proof.
+ revert a. induct n.
+ intros a. nzsimpl.
+ destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
+ rewrite testbit_0_r. apply mod_unique with a'; trivial.
+ destruct b; order'.
+ intros n IH a.
+ destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
+ rewrite testbit_succ_r, IH. f_equiv.
+ rewrite pow_succ_r', <- div_div by order_nz. f_equiv.
+ apply div_unique with b; trivial.
+ destruct b; order'.
+Qed.
+
+(** This caracterisation that uses only basic operations and
+   power was initially taken as specification for testbit.
+   We describe [a] as having a low part and a high part, with
+   the corresponding bit in the middle. This caracterisation
+   is moderatly complex to implement, but also moderately
+   usable... *)
+
+Lemma testbit_spec a n :
+  exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n.
+Proof.
+ exists (a mod 2^n). exists (a / 2^n / 2). split.
+ split; [apply le_0_l | apply mod_upper_bound; order_nz].
+ rewrite add_comm, mul_comm, (add_comm a.[n]).
+ rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv.
+ rewrite testbit_spec'. apply div_mod. order'.
+Qed.
+
+Lemma testbit_true : forall a n,
+ a.[n] = true <-> (a / 2^n) mod 2 == 1.
+Proof.
+ intros a n.
+ rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'.
+Qed.
+
+Lemma testbit_false : forall a n,
+ a.[n] = false <-> (a / 2^n) mod 2 == 0.
+Proof.
+ intros a n.
+ rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'.
+Qed.
+
+Lemma testbit_eqb : forall a n,
+ a.[n] = eqb ((a / 2^n) mod 2) 1.
+Proof.
+ intros a n.
+ apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq.
+Qed.
+
+(** Results about the injection [b2n] *)
+
+Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0.
+Proof.
+ intros [|] [|]; simpl; trivial; order'.
+Qed.
+
+Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a.
+Proof.
+ intros a0 a. rewrite mul_comm, div_add by order'.
+ now rewrite div_small, add_0_l by (destruct a0; order').
+Qed.
+
+Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0.
+Proof.
+ intros a0 a. apply b2n_inj.
+ rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'.
+ now rewrite mod_small by (destruct a0; order').
+Qed.
+
+Lemma b2n_div2 : forall (a0:bool), a0/2 == 0.
+Proof.
+ intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl.
+Qed.
+
+Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0.
+Proof.
+ intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl.
+Qed.
+
+(** The specification of testbit by low and high parts is complete *)
+
+Lemma testbit_unique : forall a n (a0:bool) l h,
+ l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0.
+Proof.
+ intros a n a0 l h Hl EQ.
+ apply b2n_inj. rewrite testbit_spec' by trivial.
+ symmetry. apply mod_unique with h. destruct a0; simpl; order'.
+ symmetry. apply div_unique with l; trivial.
+ now rewrite add_comm, (add_comm _ a0), mul_comm.
+Qed.
+
+(** All bits of number 0 are 0 *)
+
+Lemma bits_0 : forall n, 0.[n] = false.
+Proof.
+ intros n. apply testbit_false. nzsimpl; order_nz.
+Qed.
+
+(** Various ways to refer to the lowest bit of a number *)
+
+Lemma bit0_odd : forall a, a.[0] = odd a.
+Proof.
+ intros. symmetry.
+ destruct (exists_div2 a) as (a' & b & EQ).
+ rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2.
+ destruct b; simpl; apply odd_1 || apply odd_0.
+Qed.
+
+Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1.
+Proof.
+ intros a. rewrite testbit_eqb. now nzsimpl.
+Qed.
+
+Lemma bit0_mod : forall a, a.[0] == a mod 2.
+Proof.
+ intros a. rewrite testbit_spec'. now nzsimpl.
+Qed.
+
+(** Hence testing a bit is equivalent to shifting and testing parity *)
+
+Lemma testbit_odd : forall a n, a.[n] = odd (a>>n).
+Proof.
+ intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l.
+Qed.
+
+(** [log2] gives the highest nonzero bit *)
+
+Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true.
+Proof.
+ intros a Ha.
+ assert (Ha' : 0 < a) by (generalize (le_0_l a); order).
+ destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)).
+ rewrite EQ at 1.
+ rewrite testbit_true, add_comm.
+ rewrite <- (mul_1_l (2^log2 a)) at 1.
+ rewrite div_add by order_nz.
+ rewrite div_small by trivial.
+ rewrite add_0_l. apply mod_small. order'.
+Qed.
+
+Lemma bits_above_log2 : forall a n, log2 a < n ->
+ a.[n] = false.
+Proof.
+ intros a n H.
+ rewrite testbit_false.
+ rewrite div_small. nzsimpl; order'.
+ apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l.
+Qed.
+
+(** Hence the number of bits of [a] is [1+log2 a]
+    (see [Psize] and [Psize_pos]).
+*)
+
+(** Testing bits after division or multiplication by a power of two *)
+
+Lemma div2_bits : forall a n, (a/2).[n] = a.[S n].
+Proof.
+ intros. apply eq_true_iff_eq.
+ rewrite 2 testbit_true.
+ rewrite pow_succ_r by apply le_0_l.
+ now rewrite div_div by order_nz.
+Qed.
+
+Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n].
+Proof.
+ intros a n. revert a. induct n.
+ intros a m. now nzsimpl.
+ intros n IH a m. nzsimpl; try apply le_0_l.
+ rewrite <- div_div by order_nz.
+ now rewrite IH, div2_bits.
+Qed.
+
+Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n].
+Proof.
+ intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'.
+Qed.
+
+Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m].
+Proof.
+ intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz.
+Qed.
+
+Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n].
+Proof.
+ intros.
+ rewrite <- (sub_add n m) at 1 by order'.
+ now rewrite mul_pow2_bits_add.
+Qed.
+
+Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false.
+Proof.
+ intros. apply testbit_false.
+ rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc.
+ rewrite div_mul by order_nz.
+ rewrite <- (succ_pred (n-m)). rewrite pow_succ_r.
+ now rewrite (mul_comm 2), mul_assoc, mod_mul by order'.
+ apply lt_le_pred.
+ apply sub_gt in H. generalize (le_0_l (n-m)); order.
+ now apply sub_gt.
+Qed.
+
+(** Selecting the low part of a number can be done by a modulo *)
+
+Lemma mod_pow2_bits_high : forall a n m, n<=m ->
+ (a mod 2^n).[m] = false.
+Proof.
+ intros a n m H.
+ destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT].
+ now rewrite EQ, bits_0.
+ apply bits_above_log2.
+ apply lt_le_trans with n; trivial.
+ apply log2_lt_pow2; trivial.
+ apply mod_upper_bound; order_nz.
+Qed.
+
+Lemma mod_pow2_bits_low : forall a n m, m<n ->
+ (a mod 2^n).[m] = a.[m].
+Proof.
+ intros a n m H.
+ rewrite testbit_eqb.
+ rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'.
+ rewrite <- div_add by order_nz.
+ rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred
+   by now apply sub_gt.
+ rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add
+   by order.
+ rewrite add_comm, <- div_mod by order_nz.
+ symmetry. apply testbit_eqb.
+Qed.
+
+(** We now prove that having the same bits implies equality.
+    For that we use a notion of equality over functional
+    streams of bits. *)
+
+Definition eqf (f g:t -> bool) := forall n:t, f n = g n.
+
+Instance eqf_equiv : Equivalence eqf.
+Proof.
+ split; congruence.
+Qed.
+
+Local Infix "===" := eqf (at level 70, no associativity).
+
+Instance testbit_eqf : Proper (eq==>eqf) testbit.
+Proof.
+ intros a a' Ha n. now rewrite Ha.
+Qed.
+
+(** Only zero corresponds to the always-false stream. *)
+
+Lemma bits_inj_0 :
+ forall a, (forall n, a.[n] = false) -> a == 0.
+Proof.
+ intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial.
+ apply bit_log2 in NEQ. now rewrite H in NEQ.
+Qed.
+
+(** If two numbers produce the same stream of bits, they are equal. *)
+
+Lemma bits_inj : forall a b, testbit a === testbit b -> a == b.
+Proof.
+ intros a. pattern a.
+ apply strong_right_induction with 0;[solve_proper|clear a|apply le_0_l].
+ intros a _ IH b H.
+ destruct (eq_0_gt_0_cases a) as [EQ|LT].
+ rewrite EQ in H |- *. symmetry. apply bits_inj_0.
+ intros n. now rewrite <- H, bits_0.
+ rewrite (div_mod a 2), (div_mod b 2) by order'.
+ f_equiv; [ | now rewrite <- 2 bit0_mod, H].
+ f_equiv.
+ apply IH; trivial using le_0_l.
+ apply div_lt; order'.
+ intro n. rewrite 2 div2_bits. apply H.
+Qed.
+
+Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b.
+Proof.
+ split. apply bits_inj. intros EQ; now rewrite EQ.
+Qed.
+
+Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise.
+
+Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise.
+
+(** The streams of bits that correspond to a natural numbers are
+  exactly the ones that are always 0 after some point *)
+
+Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f ->
+ ((exists n, f === testbit n) <->
+  (exists k, forall m, k<=m -> f m = false)).
+Proof.
+ intros f Hf. split.
+ intros (a,H).
+  exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm.
+  rewrite H, bits_above_log2; trivial using lt_succ_diag_r.
+ intros (k,Hk).
+  revert f Hf Hk. induct k.
+  intros f Hf H0.
+  exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l.
+  intros k IH f Hf Hk.
+  destruct (IH (fun m => f (S m))) as (n, Hn).
+  solve_proper.
+  intros m Hm. apply Hk. now rewrite <- succ_le_mono.
+  exists (f 0 + 2*n). intros m.
+  destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm.
+  symmetry. apply add_b2n_double_bit0.
+  rewrite Hn, <- div2_bits.
+  rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'.
+Qed.
+
+(** Properties of shifts *)
+
+Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n].
+Proof.
+ intros. apply shiftr_spec. apply le_0_l.
+Qed.
+
+Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n].
+Proof.
+ intros. apply shiftl_spec_high; trivial. apply le_0_l.
+Qed.
+
+Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n.
+Proof.
+ intros. bitwise. rewrite shiftr_spec'.
+ symmetry. apply div_pow2_bits.
+Qed.
+
+Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n.
+Proof.
+ intros. bitwise.
+ destruct (le_gt_cases n m) as [H|H].
+ now rewrite shiftl_spec_high', mul_pow2_bits_high.
+ now rewrite shiftl_spec_low, mul_pow2_bits_low.
+Qed.
+
+Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m].
+Proof.
+ intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add.
+Qed.
+
+Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr.
+Proof.
+ intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb.
+Qed.
+
+Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl.
+Proof.
+ intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb.
+Qed.
+
+Lemma shiftl_shiftl : forall a n m,
+ (a << n) << m == a << (n+m).
+Proof.
+ intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc.
+Qed.
+
+Lemma shiftr_shiftr : forall a n m,
+ (a >> n) >> m == a >> (n+m).
+Proof.
+ intros.
+ now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz.
+Qed.
+
+Lemma shiftr_shiftl_l : forall a n m, m<=n ->
+ (a << n) >> m == a << (n-m).
+Proof.
+ intros.
+ rewrite shiftr_div_pow2, !shiftl_mul_pow2.
+ rewrite <- (sub_add m n) at 1 by trivial.
+ now rewrite pow_add_r, mul_assoc, div_mul by order_nz.
+Qed.
+
+Lemma shiftr_shiftl_r : forall a n m, n<=m ->
+ (a << n) >> m == a >> (m-n).
+Proof.
+ intros.
+ rewrite !shiftr_div_pow2, shiftl_mul_pow2.
+ rewrite <- (sub_add n m) at 1 by trivial.
+ rewrite pow_add_r, (mul_comm (2^(m-n))).
+ now rewrite <- div_div, div_mul by order_nz.
+Qed.
+
+(** shifts and constants *)
+
+Lemma shiftl_1_l : forall n, 1 << n == 2^n.
+Proof.
+ intros. now rewrite shiftl_mul_pow2, mul_1_l.
+Qed.
+
+Lemma shiftl_0_r : forall a, a << 0 == a.
+Proof.
+ intros. rewrite shiftl_mul_pow2. now nzsimpl.
+Qed.
+
+Lemma shiftr_0_r : forall a, a >> 0 == a.
+Proof.
+ intros. rewrite shiftr_div_pow2. now nzsimpl.
+Qed.
+
+Lemma shiftl_0_l : forall n, 0 << n == 0.
+Proof.
+ intros. rewrite shiftl_mul_pow2. now nzsimpl.
+Qed.
+
+Lemma shiftr_0_l : forall n, 0 >> n == 0.
+Proof.
+ intros. rewrite shiftr_div_pow2. nzsimpl; order_nz.
+Qed.
+
+Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0.
+Proof.
+ intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split.
+ intros [H | H]; trivial. contradict H; order_nz.
+ intros H. now left.
+Qed.
+
+Lemma shiftr_eq_0_iff : forall a n,
+ a >> n == 0 <-> a==0 \/ (0<a /\ log2 a < n).
+Proof.
+ intros a n.
+ rewrite shiftr_div_pow2, div_small_iff by order_nz.
+ destruct (eq_0_gt_0_cases a) as [EQ|LT].
+ rewrite EQ. split. now left. intros _.
+  assert (H : 2~=0) by order'.
+  generalize (pow_nonzero 2 n H) (le_0_l (2^n)); order.
+ rewrite log2_lt_pow2; trivial.
+ split. right; split; trivial. intros [H|[_ H]]; now order.
+Qed.
+
+Lemma shiftr_eq_0 : forall a n, log2 a < n -> a >> n == 0.
+Proof.
+ intros a n H. rewrite shiftr_eq_0_iff.
+ destruct (eq_0_gt_0_cases a) as [EQ|LT]. now left. right; now split.
+Qed.
+
+(** Properties of [div2]. *)
+
+Lemma div2_div : forall a, div2 a == a/2.
+Proof.
+ intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl.
+Qed.
+
+Instance div2_wd : Proper (eq==>eq) div2.
+Proof.
+ intros a a' Ha. now rewrite 2 div2_div, Ha.
+Qed.
+
+Lemma div2_odd : forall a, a == 2*(div2 a) + odd a.
+Proof.
+ intros a. rewrite div2_div, <- bit0_odd, bit0_mod.
+ apply div_mod. order'.
+Qed.
+
+(** Properties of [lxor] and others, directly deduced
+    from properties of [xorb] and others. *)
+
+Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance land_wd : Proper (eq ==> eq ==> eq) land.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance lor_wd : Proper (eq ==> eq ==> eq) lor.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff.
+Proof.
+ intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
+Qed.
+
+Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'.
+Proof.
+ intros a a' H. bitwise. apply xorb_eq.
+ now rewrite <- lxor_spec, H, bits_0.
+Qed.
+
+Lemma lxor_nilpotent : forall a, lxor a a == 0.
+Proof.
+ intros. bitwise. apply xorb_nilpotent.
+Qed.
+
+Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'.
+Proof.
+ split. apply lxor_eq. intros EQ; rewrite EQ; apply lxor_nilpotent.
+Qed.
+
+Lemma lxor_0_l : forall a, lxor 0 a == a.
+Proof.
+ intros. bitwise. apply xorb_false_l.
+Qed.
+
+Lemma lxor_0_r : forall a, lxor a 0 == a.
+Proof.
+ intros. bitwise. apply xorb_false_r.
+Qed.
+
+Lemma lxor_comm : forall a b, lxor a b == lxor b a.
+Proof.
+ intros. bitwise. apply xorb_comm.
+Qed.
+
+Lemma lxor_assoc :
+ forall a b c, lxor (lxor a b) c == lxor a (lxor b c).
+Proof.
+ intros. bitwise. apply xorb_assoc.
+Qed.
+
+Lemma lor_0_l : forall a, lor 0 a == a.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma lor_0_r : forall a, lor a 0 == a.
+Proof.
+ intros. bitwise. apply orb_false_r.
+Qed.
+
+Lemma lor_comm : forall a b, lor a b == lor b a.
+Proof.
+ intros. bitwise. apply orb_comm.
+Qed.
+
+Lemma lor_assoc :
+ forall a b c, lor a (lor b c) == lor (lor a b) c.
+Proof.
+ intros. bitwise. apply orb_assoc.
+Qed.
+
+Lemma lor_diag : forall a, lor a a == a.
+Proof.
+ intros. bitwise. apply orb_diag.
+Qed.
+
+Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0.
+Proof.
+ intros a b H. bitwise.
+ apply (orb_false_iff a.[m] b.[m]).
+ now rewrite <- lor_spec, H, bits_0.
+Qed.
+
+Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0.
+Proof.
+ intros a b. split.
+ split. now apply lor_eq_0_l in H.
+ rewrite lor_comm in H. now apply lor_eq_0_l in H.
+ intros (EQ,EQ'). now rewrite EQ, lor_0_l.
+Qed.
+
+Lemma land_0_l : forall a, land 0 a == 0.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma land_0_r : forall a, land a 0 == 0.
+Proof.
+ intros. bitwise. apply andb_false_r.
+Qed.
+
+Lemma land_comm : forall a b, land a b == land b a.
+Proof.
+ intros. bitwise. apply andb_comm.
+Qed.
+
+Lemma land_assoc :
+ forall a b c, land a (land b c) == land (land a b) c.
+Proof.
+ intros. bitwise. apply andb_assoc.
+Qed.
+
+Lemma land_diag : forall a, land a a == a.
+Proof.
+ intros. bitwise. apply andb_diag.
+Qed.
+
+Lemma ldiff_0_l : forall a, ldiff 0 a == 0.
+Proof.
+ intros. bitwise. trivial.
+Qed.
+
+Lemma ldiff_0_r : forall a, ldiff a 0 == a.
+Proof.
+ intros. bitwise. now rewrite andb_true_r.
+Qed.
+
+Lemma ldiff_diag : forall a, ldiff a a == 0.
+Proof.
+ intros. bitwise. apply andb_negb_r.
+Qed.
+
+Lemma lor_land_distr_l : forall a b c,
+ lor (land a b) c == land (lor a c) (lor b c).
+Proof.
+ intros. bitwise. apply orb_andb_distrib_l.
+Qed.
+
+Lemma lor_land_distr_r : forall a b c,
+ lor a (land b c) == land (lor a b) (lor a c).
+Proof.
+ intros. bitwise. apply orb_andb_distrib_r.
+Qed.
+
+Lemma land_lor_distr_l : forall a b c,
+ land (lor a b) c == lor (land a c) (land b c).
+Proof.
+ intros. bitwise. apply andb_orb_distrib_l.
+Qed.
+
+Lemma land_lor_distr_r : forall a b c,
+ land a (lor b c) == lor (land a b) (land a c).
+Proof.
+ intros. bitwise. apply andb_orb_distrib_r.
+Qed.
+
+Lemma ldiff_ldiff_l : forall a b c,
+ ldiff (ldiff a b) c == ldiff a (lor b c).
+Proof.
+ intros. bitwise. now rewrite negb_orb, andb_assoc.
+Qed.
+
+Lemma lor_ldiff_and : forall a b,
+ lor (ldiff a b) (land a b) == a.
+Proof.
+ intros. bitwise.
+ now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r.
+Qed.
+
+Lemma land_ldiff : forall a b,
+ land (ldiff a b) b == 0.
+Proof.
+ intros. bitwise.
+ now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r.
+Qed.
+
+(** Properties of [setbit] and [clearbit] *)
+
+Definition setbit a n := lor a (1<<n).
+Definition clearbit a n := ldiff a (1<<n).
+
+Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n).
+Proof.
+ intros. unfold setbit. now rewrite shiftl_1_l.
+Qed.
+
+Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n).
+Proof.
+ intros. unfold clearbit. now rewrite shiftl_1_l.
+Qed.
+
+Instance setbit_wd : Proper (eq==>eq==>eq) setbit.
+Proof. unfold setbit. solve_proper. Qed.
+
+Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit.
+Proof. unfold clearbit. solve_proper. Qed.
+
+Lemma pow2_bits_true : forall n, (2^n).[n] = true.
+Proof.
+ intros. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2.
+ now rewrite mul_pow2_bits_add, bit0_odd, odd_1.
+Qed.
+
+Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false.
+Proof.
+ intros.
+ rewrite <- (mul_1_l (2^n)).
+ destruct (le_gt_cases n m).
+ rewrite mul_pow2_bits_high; trivial.
+ rewrite <- (succ_pred (m-n)) by (apply sub_gt; order).
+ now rewrite <- div2_bits, div_small, bits_0 by order'.
+ rewrite mul_pow2_bits_low; trivial.
+Qed.
+
+Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m.
+Proof.
+ intros. apply eq_true_iff_eq. rewrite eqb_eq. split.
+ destruct (eq_decidable n m) as [H|H]. trivial.
+ now rewrite (pow2_bits_false _ _ H).
+ intros EQ. rewrite EQ. apply pow2_bits_true.
+Qed.
+
+Lemma setbit_eqb : forall a n m,
+ (setbit a n).[m] = eqb n m || a.[m].
+Proof.
+ intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm.
+Qed.
+
+Lemma setbit_iff : forall a n m,
+ (setbit a n).[m] = true <-> n==m \/ a.[m] = true.
+Proof.
+ intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq.
+Qed.
+
+Lemma setbit_eq : forall a n, (setbit a n).[n] = true.
+Proof.
+ intros. apply setbit_iff. now left.
+Qed.
+
+Lemma setbit_neq : forall a n m, n~=m ->
+ (setbit a n).[m] = a.[m].
+Proof.
+ intros a n m H. rewrite setbit_eqb.
+ rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H.
+Qed.
+
+Lemma clearbit_eqb : forall a n m,
+ (clearbit a n).[m] = a.[m] && negb (eqb n m).
+Proof.
+ intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb.
+Qed.
+
+Lemma clearbit_iff : forall a n m,
+ (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m.
+Proof.
+ intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq.
+ now rewrite negb_true_iff, not_true_iff_false.
+Qed.
+
+Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false.
+Proof.
+ intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)).
+ apply andb_false_r.
+Qed.
+
+Lemma clearbit_neq : forall a n m, n~=m ->
+ (clearbit a n).[m] = a.[m].
+Proof.
+ intros a n m H. rewrite clearbit_eqb.
+ rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H.
+ apply andb_true_r.
+Qed.
+
+(** Shifts of bitwise operations *)
+
+Lemma shiftl_lxor : forall a b n,
+ (lxor a b) << n == lxor (a << n) (b << n).
+Proof.
+ intros. bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite !shiftl_spec_high', lxor_spec.
+ now rewrite !shiftl_spec_low.
+Qed.
+
+Lemma shiftr_lxor : forall a b n,
+ (lxor a b) >> n == lxor (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec', lxor_spec.
+Qed.
+
+Lemma shiftl_land : forall a b n,
+ (land a b) << n == land (a << n) (b << n).
+Proof.
+ intros. bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite !shiftl_spec_high', land_spec.
+ now rewrite !shiftl_spec_low.
+Qed.
+
+Lemma shiftr_land : forall a b n,
+ (land a b) >> n == land (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec', land_spec.
+Qed.
+
+Lemma shiftl_lor : forall a b n,
+ (lor a b) << n == lor (a << n) (b << n).
+Proof.
+ intros. bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite !shiftl_spec_high', lor_spec.
+ now rewrite !shiftl_spec_low.
+Qed.
+
+Lemma shiftr_lor : forall a b n,
+ (lor a b) >> n == lor (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec', lor_spec.
+Qed.
+
+Lemma shiftl_ldiff : forall a b n,
+ (ldiff a b) << n == ldiff (a << n) (b << n).
+Proof.
+ intros. bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite !shiftl_spec_high', ldiff_spec.
+ now rewrite !shiftl_spec_low.
+Qed.
+
+Lemma shiftr_ldiff : forall a b n,
+ (ldiff a b) >> n == ldiff (a >> n) (b >> n).
+Proof.
+ intros. bitwise. now rewrite !shiftr_spec', ldiff_spec.
+Qed.
+
+(** We cannot have a function complementing all bits of a number,
+    otherwise it would have an infinity of bit 1. Nonetheless,
+    we can design a bounded complement *)
+
+Definition ones n := P (1 << n).
+
+Definition lnot a n := lxor a (ones n).
+
+Instance ones_wd : Proper (eq==>eq) ones.
+Proof. unfold ones. solve_proper. Qed.
+
+Instance lnot_wd : Proper (eq==>eq==>eq) lnot.
+Proof. unfold lnot. solve_proper. Qed.
+
+Lemma ones_equiv : forall n, ones n == P (2^n).
+Proof.
+ intros; unfold ones; now rewrite shiftl_1_l.
+Qed.
+
+Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m.
+Proof.
+ intros n m. rewrite !ones_equiv.
+ rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r.
+ rewrite add_sub_assoc, sub_add. reflexivity.
+ apply pow_le_mono_r. order'.
+ rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l.
+ rewrite <- (pow_0_r 2). apply pow_le_mono_r. order'. apply le_0_l.
+Qed.
+
+Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m).
+Proof.
+ intros n m H. symmetry. apply div_unique with (ones m).
+ rewrite ones_equiv.
+ apply le_succ_l. rewrite succ_pred; order_nz.
+ rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m).
+ apply ones_add.
+Qed.
+
+Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m.
+Proof.
+ intros n m H. symmetry. apply mod_unique with (ones (n-m)).
+ rewrite ones_equiv.
+ apply le_succ_l. rewrite succ_pred; order_nz.
+ rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m).
+ apply ones_add.
+Qed.
+
+Lemma ones_spec_low : forall n m, m<n -> (ones n).[m] = true.
+Proof.
+ intros. apply testbit_true. rewrite ones_div_pow2 by order.
+ rewrite <- (pow_1_r 2). rewrite ones_mod_pow2.
+ rewrite ones_equiv. now nzsimpl'.
+ apply le_add_le_sub_r. nzsimpl. now apply le_succ_l.
+Qed.
+
+Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false.
+Proof.
+ intros.
+ destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv.
+ now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0.
+ apply bits_above_log2.
+ rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order.
+Qed.
+
+Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m<n.
+Proof.
+ intros. split. intros H.
+ apply lt_nge. intro H'. apply ones_spec_high in H'.
+ rewrite H in H'; discriminate.
+ apply ones_spec_low.
+Qed.
+
+Lemma lnot_spec_low : forall a n m, m<n ->
+ (lnot a n).[m] = negb a.[m].
+Proof.
+ intros. unfold lnot. now rewrite lxor_spec, ones_spec_low.
+Qed.
+
+Lemma lnot_spec_high : forall a n m, n<=m ->
+ (lnot a n).[m] = a.[m].
+Proof.
+ intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r.
+Qed.
+
+Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a.
+Proof.
+ intros a n. bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite 2 lnot_spec_high.
+ now rewrite 2 lnot_spec_low, negb_involutive.
+Qed.
+
+Lemma lnot_0_l : forall n, lnot 0 n == ones n.
+Proof.
+ intros. unfold lnot. apply lxor_0_l.
+Qed.
+
+Lemma lnot_ones : forall n, lnot (ones n) n == 0.
+Proof.
+ intros. unfold lnot. apply lxor_nilpotent.
+Qed.
+
+(** Bounded complement and other operations *)
+
+Lemma lor_ones_low : forall a n, log2 a < n ->
+ lor a (ones n) == ones n.
+Proof.
+ intros a n H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now rewrite ones_spec_low, orb_true_r.
+Qed.
+
+Lemma land_ones : forall a n, land a (ones n) == a mod 2^n.
+Proof.
+ intros a n. bitwise. destruct (le_gt_cases n m).
+ now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r.
+ now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r.
+Qed.
+
+Lemma land_ones_low : forall a n, log2 a < n ->
+ land a (ones n) == a.
+Proof.
+ intros; rewrite land_ones. apply mod_small.
+ apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l.
+Qed.
+
+Lemma ldiff_ones_r : forall a n,
+ ldiff a (ones n) == (a >> n) << n.
+Proof.
+ intros a n. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial.
+ rewrite sub_add; trivial. apply andb_true_r.
+ now rewrite ones_spec_low, shiftl_spec_low, andb_false_r.
+Qed.
+
+Lemma ldiff_ones_r_low : forall a n, log2 a < n ->
+ ldiff a (ones n) == 0.
+Proof.
+ intros a n H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now rewrite ones_spec_low, andb_false_r.
+Qed.
+
+Lemma ldiff_ones_l_low : forall a n, log2 a < n ->
+ ldiff (ones n) a == lnot a n.
+Proof.
+ intros a n H. bitwise. destruct (le_gt_cases n m).
+ rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now rewrite ones_spec_low, lnot_spec_low.
+Qed.
+
+Lemma lor_lnot_diag : forall a n,
+ lor a (lnot a n) == lor a (ones n).
+Proof.
+ intros a n. bitwise.
+ destruct (le_gt_cases n m).
+ rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m].
+ rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m].
+Qed.
+
+Lemma lor_lnot_diag_low : forall a n, log2 a < n ->
+ lor a (lnot a n) == ones n.
+Proof.
+ intros a n H. now rewrite lor_lnot_diag, lor_ones_low.
+Qed.
+
+Lemma land_lnot_diag : forall a n,
+ land a (lnot a n) == ldiff a (ones n).
+Proof.
+ intros a n. bitwise.
+ destruct (le_gt_cases n m).
+ rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m].
+ rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m].
+Qed.
+
+Lemma land_lnot_diag_low : forall a n, log2 a < n ->
+ land a (lnot a n) == 0.
+Proof.
+ intros. now rewrite land_lnot_diag, ldiff_ones_r_low.
+Qed.
+
+Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n ->
+ lnot (lor a b) n == land (lnot a n) (lnot b n).
+Proof.
+ intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now apply lt_le_trans with n.
+ now rewrite !lnot_spec_low, lor_spec, negb_orb.
+Qed.
+
+Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n ->
+ lnot (land a b) n == lor (lnot a n) (lnot b n).
+Proof.
+ intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now apply lt_le_trans with n.
+ now rewrite !lnot_spec_low, land_spec, negb_andb.
+Qed.
+
+Lemma ldiff_land_low : forall a b n, log2 a < n ->
+ ldiff a b == land a (lnot b n).
+Proof.
+ intros a b n Ha. bitwise. destruct (le_gt_cases n m).
+ rewrite (bits_above_log2 a m). trivial.
+ now apply lt_le_trans with n.
+ rewrite !lnot_spec_low; trivial.
+Qed.
+
+Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n ->
+ lnot (ldiff a b) n == lor (lnot a n) b.
+Proof.
+ intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial.
+ now apply lt_le_trans with n.
+ now apply lt_le_trans with n.
+ now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive.
+Qed.
+
+Lemma lxor_lnot_lnot : forall a b n,
+ lxor (lnot a n) (lnot b n) == lxor a b.
+Proof.
+ intros a b n. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high; trivial.
+ rewrite !lnot_spec_low, xorb_negb_negb; trivial.
+Qed.
+
+Lemma lnot_lxor_l : forall a b n,
+ lnot (lxor a b) n == lxor (lnot a n) b.
+Proof.
+ intros a b n. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high, lxor_spec; trivial.
+ rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial.
+Qed.
+
+Lemma lnot_lxor_r : forall a b n,
+ lnot (lxor a b) n == lxor a (lnot b n).
+Proof.
+ intros a b n. bitwise. destruct (le_gt_cases n m).
+ rewrite !lnot_spec_high, lxor_spec; trivial.
+ rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial.
+Qed.
+
+Lemma lxor_lor : forall a b, land a b == 0 ->
+ lxor a b == lor a b.
+Proof.
+ intros a b H. bitwise.
+ assert (a.[m] && b.[m] = false)
+   by now rewrite <- land_spec, H, bits_0.
+ now destruct a.[m], b.[m].
+Qed.
+
+(** Bitwise operations and log2 *)
+
+Lemma log2_bits_unique : forall a n,
+ a.[n] = true ->
+ (forall m, n<m -> a.[m] = false) ->
+ log2 a == n.
+Proof.
+ intros a n H H'.
+ destruct (eq_0_gt_0_cases a) as [Ha|Ha].
+ now rewrite Ha, bits_0 in H.
+ apply le_antisymm; apply le_ngt; intros LT.
+ specialize (H' _ LT). now rewrite bit_log2 in H' by order.
+ now rewrite bits_above_log2 in H by order.
+Qed.
+
+Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n.
+Proof.
+ intros a n.
+ destruct (eq_0_gt_0_cases a) as [Ha|Ha].
+ now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order.
+ destruct (lt_ge_cases (log2 a) n).
+ rewrite shiftr_eq_0, log2_nonpos by order.
+ symmetry. rewrite sub_0_le; order.
+ apply log2_bits_unique.
+ now rewrite shiftr_spec', sub_add, bit_log2 by order.
+ intros m Hm.
+ rewrite shiftr_spec'; trivial. apply bits_above_log2; try order.
+ now apply lt_sub_lt_add_r.
+Qed.
+
+Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n.
+Proof.
+ intros a n Ha.
+ rewrite shiftl_mul_pow2, add_comm by trivial.
+ apply log2_mul_pow2. generalize (le_0_l a); order. apply le_0_l.
+Qed.
+
+Lemma log2_lor : forall a b,
+ log2 (lor a b) == max (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b).
+  intros a b H.
+  destruct (eq_0_gt_0_cases a) as [Ha|Ha]. now rewrite Ha, lor_0_l.
+  apply log2_bits_unique.
+  now rewrite lor_spec, bit_log2, orb_true_r by order.
+  intros m Hm. assert (H' := log2_le_mono _ _ H).
+  now rewrite lor_spec, 2 bits_above_log2 by order.
+ (* main *)
+ intros a b. destruct (le_ge_cases a b) as [H|H].
+ rewrite max_r by now apply log2_le_mono.
+ now apply AUX.
+ rewrite max_l by now apply log2_le_mono.
+ rewrite lor_comm. now apply AUX.
+Qed.
+
+Lemma log2_land : forall a b,
+ log2 (land a b) <= min (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a).
+  intros a b H.
+  apply le_ngt. intros H'.
+  destruct (eq_decidable (land a b) 0) as [EQ|NEQ].
+  rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order.
+  generalize (bit_log2 (land a b) NEQ).
+  now rewrite land_spec, bits_above_log2.
+ (* main *)
+ intros a b.
+ destruct (le_ge_cases a b) as [H|H].
+ rewrite min_l by now apply log2_le_mono. now apply AUX.
+ rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX.
+Qed.
+
+Lemma log2_lxor : forall a b,
+ log2 (lxor a b) <= max (log2 a) (log2 b).
+Proof.
+ assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b).
+  intros a b H.
+  apply le_ngt. intros H'.
+  destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ].
+  rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order.
+  generalize (bit_log2 (lxor a b) NEQ).
+  rewrite lxor_spec, 2 bits_above_log2; try order. discriminate.
+  apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono.
+ (* main *)
+ intros a b.
+ destruct (le_ge_cases a b) as [H|H].
+ rewrite max_r by now apply log2_le_mono. now apply AUX.
+ rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX.
+Qed.
+
+(** Bitwise operations and arithmetical operations *)
+
+Local Notation xor3 a b c := (xorb (xorb a b) c).
+Local Notation lxor3 a b c := (lxor (lxor a b) c).
+
+Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))).
+Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))).
+
+Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0].
+Proof.
+ intros. now rewrite !bit0_odd, odd_add.
+Qed.
+
+Lemma add3_bit0 : forall a b c,
+ (a+b+c).[0] = xor3 a.[0] b.[0] c.[0].
+Proof.
+ intros. now rewrite !add_bit0.
+Qed.
+
+Lemma add3_bits_div2 : forall (a0 b0 c0 : bool),
+ (a0 + b0 + c0)/2 == nextcarry a0 b0 c0.
+Proof.
+ assert (H : 1+1 == 2) by now nzsimpl'.
+ intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H;
+  (apply div_same; order') || (apply div_small; order') || idtac.
+ symmetry. apply div_unique with 1. order'. now nzsimpl'.
+Qed.
+
+Lemma add_carry_div2 : forall a b (c0:bool),
+ (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0.
+Proof.
+ intros.
+ rewrite <- add3_bits_div2.
+ rewrite (add_comm ((a/2)+_)).
+ rewrite <- div_add by order'.
+ f_equiv.
+ rewrite <- !div2_div, mul_comm, mul_add_distr_l.
+ rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]).
+ rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]).
+ rewrite add_shuffle1.
+ rewrite <-(add_assoc _ _ c0). apply add_comm.
+Qed.
+
+(** The main result concerning addition: we express the bits of the sum
+  in term of bits of [a] and [b] and of some carry stream which is also
+  recursively determined by another equation.
+*)
+
+Lemma add_carry_bits : forall a b (c0:bool), exists c,
+ a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0.
+Proof.
+ intros a b c0.
+ (* induction over some n such that [a<2^n] and [b<2^n] *)
+ set (n:=max a b).
+ assert (Ha : a<2^n).
+  apply lt_le_trans with (2^a). apply pow_gt_lin_r, lt_1_2.
+  apply pow_le_mono_r. order'. unfold n.
+  destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'.
+ assert (Hb : b<2^n).
+  apply lt_le_trans with (2^b). apply pow_gt_lin_r, lt_1_2.
+  apply pow_le_mono_r. order'. unfold n.
+  destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'.
+ clearbody n.
+ revert a b c0 Ha Hb. induct n.
+ (*base*)
+ intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb.
+ exists c0.
+ setoid_replace a with 0 by (generalize (le_0_l a); order').
+ setoid_replace b with 0 by (generalize (le_0_l b); order').
+ rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r.
+ rewrite b2n_div2, b2n_bit0; now repeat split.
+ (*step*)
+ intros n IH a b c0 Ha Hb.
+ set (c1:=nextcarry a.[0] b.[0] c0).
+ destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH.
+ apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'.
+ apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'.
+ exists (c0 + 2*c). repeat split.
+ (* - add *)
+ bitwise.
+ destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ.
+ now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0.
+ rewrite <- !div2_bits, <- 2 lxor_spec.
+ f_equiv.
+ rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2.
+ (* - carry *)
+ rewrite add_b2n_double_div2.
+ bitwise.
+ destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ.
+ now rewrite add_b2n_double_bit0.
+ rewrite <- !div2_bits, IH2. autorewrite with bitwise.
+ now rewrite add_b2n_double_div2.
+ (* - carry0 *)
+ apply add_b2n_double_bit0.
+Qed.
+
+(** Particular case : the second bit of an addition *)
+
+Lemma add_bit1 : forall a b,
+ (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]).
+Proof.
+ intros a b.
+ destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
+ simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
+ autorewrite with bitwise. f_equal.
+ rewrite one_succ, <- div2_bits, EQ2.
+ autorewrite with bitwise.
+ rewrite Hc. simpl. apply orb_false_r.
+Qed.
+
+(** In an addition, there will be no carries iff there is
+  no common bits in the numbers to add *)
+
+Lemma nocarry_equiv : forall a b c,
+ c/2 == lnextcarry a b c -> c.[0] = false ->
+ (c == 0 <-> land a b == 0).
+Proof.
+ intros a b c H H'.
+ split. intros EQ; rewrite EQ in *.
+ rewrite div_0_l in H by order'.
+ symmetry in H. now apply lor_eq_0_l in H.
+ intros EQ. rewrite EQ, lor_0_l in H.
+ apply bits_inj_0.
+ induct n. trivial.
+ intros n IH.
+ rewrite <- div2_bits, H.
+ autorewrite with bitwise.
+ now rewrite IH.
+Qed.
+
+(** When there is no common bits, the addition is just a xor *)
+
+Lemma add_nocarry_lxor : forall a b, land a b == 0 ->
+ a+b == lxor a b.
+Proof.
+ intros a b H.
+ destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
+ simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
+ apply (nocarry_equiv a b c) in H; trivial.
+ rewrite H. now rewrite lxor_0_r.
+Qed.
+
+(** A null [ldiff] implies being smaller *)
+
+Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b.
+Proof.
+ cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b).
+ intros H a b. apply (H a), pow_gt_lin_r; order'.
+ induct n.
+ intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha.
+ assert (Ha' : a == 0) by (generalize (le_0_l a); order').
+ rewrite Ha'. apply le_0_l.
+ intros n IH a b Ha H.
+ assert (NEQ : 2 ~= 0) by order'.
+ rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ).
+ apply add_le_mono.
+ apply mul_le_mono_l.
+ apply IH.
+ apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'.
+ rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2.
+ now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l.
+ rewrite <- 2 bit0_mod.
+ apply bits_inj_iff in H. specialize (H 0).
+ rewrite ldiff_spec, bits_0 in H.
+ destruct a.[0], b.[0]; try discriminate; simpl; order'.
+Qed.
+
+(** Subtraction can be a ldiff when the opposite ldiff is null. *)
+
+Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 ->
+ a-b == ldiff a b.
+Proof.
+ intros a b H.
+ apply add_cancel_r with b.
+ rewrite sub_add.
+ symmetry.
+ rewrite add_nocarry_lxor.
+ bitwise.
+ apply bits_inj_iff in H. specialize (H m).
+ rewrite ldiff_spec, bits_0 in H.
+ now destruct a.[m], b.[m].
+ apply land_ldiff.
+ now apply ldiff_le.
+Qed.
+
+(** We can express lnot in term of subtraction *)
+
+Lemma add_lnot_diag_low : forall a n, log2 a < n ->
+ a + lnot a n == ones n.
+Proof.
+ intros a n H.
+ assert (H' := land_lnot_diag_low a n H).
+ rewrite add_nocarry_lxor, lxor_lor by trivial.
+ now apply lor_lnot_diag_low.
+Qed.
+
+Lemma lnot_sub_low : forall a n, log2 a < n ->
+ lnot a n == ones n - a.
+Proof.
+ intros a n H.
+ now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub.
+Qed.
+
+(** Adding numbers with no common bits cannot lead to a much bigger number *)
+
+Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 ->
+ a < 2^n -> b < 2^n -> a+b < 2^n.
+Proof.
+ intros a b n H Ha Hb.
+ rewrite add_nocarry_lxor by trivial.
+ apply div_small_iff. order_nz.
+ rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2.
+ rewrite 2 div_small by trivial.
+ apply lxor_0_l.
+Qed.
+
+Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 ->
+ a mod 2^n + b mod 2^n < 2^n.
+Proof.
+ intros a b n H.
+ apply add_nocarry_lt_pow2.
+ bitwise.
+ destruct (le_gt_cases n m).
+ now rewrite mod_pow2_bits_high.
+ now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0.
+ apply mod_upper_bound; order_nz.
+ apply mod_upper_bound; order_nz.
+Qed.
+
+End NBitsProp.
diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v
index 7b38c148..ad7a9f3a 100644
--- a/theories/Numbers/Natural/Abstract/NDefOps.v
+++ b/theories/Numbers/Natural/Abstract/NDefOps.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,14 +8,41 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NDefOps.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Bool. (* To get the orb and negb function *)
 Require Import RelationPairs.
 Require Export NStrongRec.
 
-Module NdefOpsPropFunct (Import N : NAxiomsSig').
-Include NStrongRecPropFunct N.
+(** In this module, we derive generic implementations of usual operators
+   just via the use of a [recursion] function. *)
+
+Module NdefOpsProp (Import N : NAxiomsRecSig').
+Include NStrongRecProp N.
+
+(** Nullity Test *)
+
+Definition if_zero (A : Type) (a b : A) (n : N.t) : A :=
+  recursion a (fun _ _ => b) n.
+
+Arguments if_zero [A] a b n.
+
+Instance if_zero_wd (A : Type) :
+ Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A).
+Proof.
+unfold if_zero. (* TODO : solve_proper : SLOW + BUG *)
+f_equiv'.
+Qed.
+
+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 : Type) (a b : A) (n : N.t), if_zero a b (S n) = b.
+Proof.
+intros; unfold if_zero.
+now rewrite recursion_succ.
+Qed.
 
 (*****************************************************)
 (**                   Addition                       *)
@@ -24,17 +51,9 @@ Definition def_add (x y : N.t) := recursion y (fun _ => S) x.
 
 Local Infix "+++" := def_add (at level 50, left associativity).
 
-Instance def_add_prewd : Proper (N.eq==>N.eq==>N.eq) (fun _ => S).
-Proof.
-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.
+unfold def_add. f_equiv'.
 Qed.
 
 Theorem def_add_0_l : forall y, 0 +++ y == y.
@@ -45,7 +64,7 @@ Qed.
 Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y).
 Proof.
 intros x y; unfold def_add.
-rewrite recursion_succ; auto with *.
+rewrite recursion_succ; f_equiv'.
 Qed.
 
 Theorem def_add_add : forall n m, n +++ m == n + m.
@@ -62,18 +81,10 @@ Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y.
 
 Local Infix "**" := def_mul (at level 40, left associativity).
 
-Instance def_mul_prewd :
- Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun x _ p => p +++ x).
-Proof.
-repeat red; intros; now apply def_add_wd.
-Qed.
-
 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; auto with *.
-now apply def_mul_prewd.
+unfold def_mul. (* TODO : solve_proper SLOW + BUG *)
+f_equiv'.
 Qed.
 
 Theorem def_mul_0_r : forall x, x ** 0 == 0.
@@ -85,7 +96,7 @@ Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x.
 Proof.
 intros x y; unfold def_mul.
 rewrite recursion_succ; auto with *.
-now apply def_mul_prewd.
+f_equiv'.
 Qed.
 
 Theorem def_mul_mul : forall n m, n ** m == n * m.
@@ -106,25 +117,9 @@ recursion
 
 Local Infix "<<" := ltb (at level 70, no associativity).
 
-Instance ltb_prewd1 : Proper (N.eq==>Logic.eq) (if_zero false true).
-Proof.
-red; intros; apply if_zero_wd; auto.
-Qed.
-
-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.
-repeat red; intros; simpl.
-apply recursion_wd; auto with *.
-repeat red; auto.
-Qed.
-
 Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb.
 Proof.
-unfold ltb.
-intros n n' Hn m m' Hm.
-apply f_equiv; auto with *.
-apply recursion_wd; auto; [ apply ltb_prewd1 | apply ltb_prewd2 ].
+unfold ltb. f_equiv'.
 Qed.
 
 Theorem ltb_base : forall n, 0 << n = if_zero false true n.
@@ -136,11 +131,9 @@ Theorem ltb_step :
   forall m n, S m << n = recursion false (fun n' _ => m << n') n.
 Proof.
 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.
+f_equiv.
+rewrite recursion_succ; f_equiv'.
+reflexivity.
 Qed.
 
 (* Above, we rewrite applications of function. Is it possible to rewrite
@@ -162,8 +155,7 @@ Qed.
 Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m).
 Proof.
 intros n m.
-rewrite ltb_step. rewrite recursion_succ; try reflexivity.
-repeat red; intros; now apply ltb_wd.
+rewrite ltb_step. rewrite recursion_succ; f_equiv'.
 Qed.
 
 Theorem ltb_lt : forall n m, n << m = true <-> n < m.
@@ -188,9 +180,7 @@ Definition even (x : N.t) := recursion true (fun _ p => negb p) x.
 
 Instance even_wd : Proper (N.eq==>Logic.eq) even.
 Proof.
-intros n n' Hn. unfold even.
-apply recursion_wd; auto.
-congruence.
+unfold even. f_equiv'.
 Qed.
 
 Theorem even_0 : even 0 = true.
@@ -202,19 +192,12 @@ Qed.
 Theorem even_succ : forall x, even (S x) = negb (even x).
 Proof.
 unfold even.
-intro x; rewrite recursion_succ; try reflexivity.
-congruence.
+intro x; rewrite recursion_succ; f_equiv'.
 Qed.
 
 (*****************************************************)
 (**                Division by 2                     *)
 
-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_aux (x : N.t) : N.t * N.t :=
   recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x.
 
@@ -223,14 +206,14 @@ Definition half (x : N.t) := snd (half_aux x).
 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 *.
+f_equiv; trivial.
 intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *.
 rewrite Hu, Hv; auto with *.
 Qed.
 
 Instance half_wd : Proper (N.eq==>N.eq) half.
 Proof.
-intros x x' Hx. unfold half. rewrite Hx; auto with *.
+unfold half. f_equiv'.
 Qed.
 
 Lemma half_aux_0 : half_aux 0 = (0,0).
@@ -245,8 +228,7 @@ 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.
+rewrite recursion_succ, <- Heqh; simpl; f_equiv'.
 Qed.
 
 Theorem half_aux_spec : forall n,
@@ -258,7 +240,7 @@ 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.
+now f_equiv.
 Qed.
 
 Theorem half_aux_spec2 : forall n,
@@ -271,7 +253,7 @@ rewrite half_aux_0; simpl. auto with *.
 intros.
 rewrite half_aux_succ; simpl.
 destruct H; auto with *.
-right; apply succ_wd; auto with *.
+right; now f_equiv.
 Qed.
 
 Theorem half_0 : half 0 == 0.
@@ -281,14 +263,14 @@ Qed.
 
 Theorem half_1 : half 1 == 0.
 Proof.
-unfold half. rewrite half_aux_succ, half_aux_0; simpl; auto with *.
+unfold half. rewrite one_succ, 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.
+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.
@@ -319,24 +301,23 @@ 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).
+order'.
+order.
 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.
+destruct (half_double n) as [E|E]; rewrite E at 2; nzsimpl'.
 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_succ_l.
 rewrite <- add_0_l at 1.
 rewrite <- add_lt_mono_r.
-rewrite add_succ_l. apply lt_0_succ.
+apply lt_0_succ.
 Qed.
 
 
@@ -347,17 +328,9 @@ 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.
+unfold pow. f_equiv'.
 Qed.
 
 Lemma pow_0 : forall n, n^^0 == 1.
@@ -367,8 +340,7 @@ 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.
+intros. unfold pow. rewrite recursion_succ; f_equiv'.
 Qed.
 
 
@@ -389,15 +361,13 @@ Proof.
 intros g g' Hg n n' Hn.
 rewrite Hn.
 destruct (n' << 2); auto with *.
-apply succ_wd.
-apply Hg. rewrite Hn; auto with *.
+f_equiv. apply Hg. now f_equiv.
 Qed.
 
 Instance log_wd : Proper (N.eq==>N.eq) log.
 Proof.
 intros x x' Exx'. unfold log.
-apply strong_rec_wd; auto with *.
-apply log_prewd.
+apply strong_rec_wd; f_equiv'.
 Qed.
 
 Lemma log_good_step : forall n h1 h2,
@@ -408,9 +378,9 @@ 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.
+f_equiv. apply E, half_decrease.
+rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H.
+order'.
 Qed.
 Hint Resolve log_good_step.
 
@@ -441,14 +411,14 @@ 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.
+rewrite <- le_succ_l, <- one_succ in Hk2.
 le_elim Hk2.
-rewrite <- nle_gt, le_succ_l in LT. destruct LT; auto.
+rewrite two_succ, <- 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.
+rewrite two_succ, 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.
@@ -458,22 +428,13 @@ split.
 rewrite <- le_succ_l in IH1.
 apply mul_le_mono_l with (p:=2) in IH1.
 eapply lt_le_trans; eauto.
-nzsimpl.
+nzsimpl'.
 rewrite lt_succ_r.
 eapply le_trans; [ eapply half_lower_bound | ].
-nzsimpl; apply le_refl.
+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.
+End NdefOpsProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v
index 171530f0..6db8e448 100644
--- a/theories/Numbers/Natural/Abstract/NDiv.v
+++ b/theories/Numbers/Natural/Abstract/NDiv.v
@@ -1,40 +1,36 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Euclidean Division *)
+Require Import NAxioms NSub NZDiv.
 
-Require Import NAxioms NProperties NZDiv.
+(** Properties of Euclidean Division *)
 
-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 NDivProp (Import N : NAxiomsSig')(Import NP : NSubProp N).
 
-Module Type NDivSig := NAxiomsSig <+ DivMod <+ NZDivCommon <+ NDivSpecific.
-Module Type NDivSig' := NAxiomsSig' <+ DivMod' <+ NZDivCommon <+ NDivSpecific.
+(** We benefit from what already exists for NZ *)
+Module Import Private_NZDiv := Nop <+ NZDivProp N N NP.
 
-Module NDivPropFunct (Import N : NDivSig')(Import NP : NPropSig N).
+Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l.
 
-(** We benefit from what already exists for NZ *)
+(** Let's now state again theorems, but without useless hypothesis. *)
 
- 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.
+Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b.
+Proof. intros. apply mod_bound_pos; auto'. Qed.
 
- Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l.
+(** Another formulation of the main equation *)
 
-(** Let's now state again theorems, but without useless hypothesis. *)
+Lemma mod_eq :
+ forall a b, b~=0 -> a mod b == a - b*(a/b).
+Proof.
+intros.
+symmetry. apply add_sub_eq_l. symmetry.
+now apply div_mod.
+Qed.
 
 (** Uniqueness theorems *)
 
@@ -51,6 +47,9 @@ 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.
 
+Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b.
+Proof. intros. apply div_unique_exact; auto'. Qed.
+
 (** A division by itself returns 1 *)
 
 Lemma div_same : forall a, a~=0 -> a/a == 1.
@@ -223,6 +222,10 @@ Lemma div_div : forall a b c, b~=0 -> c~=0 ->
  (a/b)/c == a/(b*c).
 Proof. intros. apply div_div; auto'. Qed.
 
+Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 ->
+ a mod (b*c) == a mod b + b*((a/b) mod c).
+Proof. intros. apply mod_mul_r; auto'. Qed.
+
 (** A last inequality: *)
 
 Theorem div_mul_le:
@@ -235,5 +238,4 @@ 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.
-
+End NDivProp.
diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v
new file mode 100644
index 00000000..ece369d8
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NGcd.v
@@ -0,0 +1,213 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Properties of the greatest common divisor *)
+
+Require Import NAxioms NSub NZGcd.
+
+Module Type NGcdProp
+ (Import A : NAxiomsSig')
+ (Import B : NSubProp A).
+
+ Include NZGcdProp A A B.
+
+(** Results concerning divisibility*)
+
+Definition divide_1_r n : (n | 1) -> n == 1
+ := divide_1_r_nonneg n (le_0_l n).
+
+Definition divide_antisym n m : (n | m) -> (m | n) -> n == m
+ := divide_antisym_nonneg n m (le_0_l n) (le_0_l m).
+
+Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p).
+Proof.
+ intros n m p (q,Hq) (r,Hr).
+ exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr.
+ now rewrite add_comm, add_sub.
+Qed.
+
+Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p).
+Proof.
+ intros n m p H H'.
+ destruct (le_ge_cases m p) as [LE|LE].
+ apply sub_0_le in LE. rewrite LE. apply divide_0_r.
+ apply divide_add_cancel_r with p; trivial.
+ now rewrite add_comm, sub_add.
+Qed.
+
+(** Properties of gcd *)
+
+Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n).
+Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n).
+Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n).
+Definition gcd_unique' n m p := gcd_unique n m p (le_0_l p).
+Definition gcd_unique_alt' n m p := gcd_unique_alt n m p (le_0_l p).
+Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n).
+
+Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m.
+Proof.
+ intros. apply gcd_unique_alt'.
+ intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial.
+ apply divide_add_r; trivial. now apply divide_mul_r.
+ apply divide_add_cancel_r with (p*n); trivial.
+ now apply divide_mul_r. now rewrite add_comm.
+Qed.
+
+Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m.
+Proof.
+ intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r.
+Qed.
+
+Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m.
+Proof.
+ intros n m H. symmetry.
+ rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r.
+Qed.
+
+(** On natural numbers, we should use a particular form
+  for the Bezout identity, since we don't have full subtraction. *)
+
+Definition Bezout n m p := exists a b, a*n == p + b*m.
+
+Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout.
+Proof.
+ unfold Bezout. intros x x' Hx y y' Hy z z' Hz.
+ setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz.
+Qed.
+
+Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1.
+Proof.
+ intros n m (q & r & H).
+ apply gcd_unique; trivial using divide_1_l, le_0_1.
+ intros p Hn Hm.
+ apply divide_add_cancel_r with (r*m).
+ now apply divide_mul_r.
+ rewrite add_comm, <- H. now apply divide_mul_r.
+Qed.
+
+(** For strictly positive numbers, we have Bezout in the two directions. *)
+
+Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m ->
+ Bezout n m (gcd n m) /\ Bezout m n (gcd n m).
+Proof.
+ intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn.
+ pattern n. apply strong_right_induction with (z:=1); trivial.
+ unfold Bezout. solve_proper.
+ clear n Hn. intros n Hn IHn.
+ intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm.
+ pattern m. apply strong_right_induction with (z:=1); trivial.
+ unfold Bezout. solve_proper.
+ clear m Hm. intros m Hm IHm.
+ destruct (lt_trichotomy n m) as [LT|[EQ|LT]].
+ (* n < m *)
+ destruct (IHm (m-n)) as ((a & b & EQ), (a' & b' & EQ')).
+ rewrite one_succ, le_succ_l.
+ apply lt_add_lt_sub_l; now nzsimpl.
+ apply sub_lt; order'.
+ split.
+ exists (a+b). exists b.
+ rewrite mul_add_distr_r, EQ, mul_sub_distr_l, <- add_assoc.
+ rewrite gcd_sub_diag_r by order.
+ rewrite sub_add. reflexivity. apply mul_le_mono_l; order.
+ exists a'. exists (a'+b').
+ rewrite gcd_sub_diag_r in EQ' by order.
+ rewrite (add_comm a'), mul_add_distr_r, add_assoc, <- EQ'.
+ rewrite mul_sub_distr_l, sub_add. reflexivity. apply mul_le_mono_l; order.
+ (* n = m *)
+ rewrite EQ. rewrite gcd_diag.
+ split.
+ exists 1. exists 0. now nzsimpl.
+ exists 1. exists 0. now nzsimpl.
+ (* m < n *)
+ rewrite gcd_comm, and_comm.
+ apply IHn; trivial.
+ now rewrite <- le_succ_l, <- one_succ.
+Qed.
+
+Lemma gcd_bezout_pos : forall n m, 0<n -> Bezout n m (gcd n m).
+Proof.
+ intros n m Hn.
+ destruct (eq_0_gt_0_cases m) as [EQ|LT].
+ rewrite EQ, gcd_0_r. exists 1. exists 0. now nzsimpl.
+ now apply gcd_bezout_pos_pos.
+Qed.
+
+(** For arbitrary natural numbers, we could only say that at least
+  one of the Bezout identities holds. *)
+
+Lemma gcd_bezout : forall n m,
+ Bezout n m (gcd n m) \/ Bezout m n (gcd n m).
+Proof.
+ intros n m.
+ destruct (eq_0_gt_0_cases n) as [EQ|LT].
+ right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl.
+ left. now apply gcd_bezout_pos.
+Qed.
+
+Lemma gcd_mul_mono_l :
+  forall n m p, gcd (p * n) (p * m) == p * gcd n m.
+Proof.
+ intros n m p.
+ apply gcd_unique'.
+ apply mul_divide_mono_l, gcd_divide_l.
+ apply mul_divide_mono_l, gcd_divide_r.
+ intros q H H'.
+ destruct (eq_0_gt_0_cases n) as [EQ|LT].
+ rewrite EQ in *. now rewrite gcd_0_l.
+ destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
+ apply divide_add_cancel_r with (p*m*b).
+ now apply divide_mul_l.
+ rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ.
+ rewrite (mul_comm a), mul_assoc.
+ now apply divide_mul_l.
+Qed.
+
+Lemma gcd_mul_mono_r :
+ forall n m p, gcd (n*p) (m*p) == gcd n m * p.
+Proof.
+ intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l.
+Qed.
+
+Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p).
+Proof.
+ intros n m p H G.
+ destruct (eq_0_gt_0_cases n) as [EQ|LT].
+ rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G.
+ destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
+ rewrite G in EQ.
+ apply divide_add_cancel_r with (m*p*b).
+ now apply divide_mul_l.
+ rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2.
+ rewrite <- mul_add_distr_r, add_comm, <- EQ.
+ now apply divide_mul_l, divide_factor_r.
+Qed.
+
+Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) ->
+ exists q r, n == q*r /\ (q | m) /\ (r | p).
+Proof.
+ intros n m p Hn H.
+ assert (G := gcd_nonneg n m). le_elim G.
+ destruct (gcd_divide_l n m) as (q,Hq).
+ exists (gcd n m). exists q.
+ split. now rewrite mul_comm.
+ split. apply gcd_divide_r.
+ destruct (gcd_divide_r n m) as (r,Hr).
+ rewrite Hr in H. rewrite Hq in H at 1.
+ rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order].
+ apply gauss with r; trivial.
+ apply mul_cancel_r with (gcd n m); [order|].
+ rewrite mul_1_l.
+ rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order.
+ symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order.
+Qed.
+
+(** TODO : relation between gcd and division and modulo *)
+
+(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *)
+
+End NGcdProp.
diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v
index d484a625..bcf746a7 100644
--- a/theories/Numbers/Natural/Abstract/NIso.v
+++ b/theories/Numbers/Natural/Abstract/NIso.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,9 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NIso.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import NBase.
 
-Module Homomorphism (N1 N2 : NAxiomsSig).
+Module Homomorphism (N1 N2 : NAxiomsRecSig).
 
 Local Notation "n == m" := (N2.eq n m) (at level 70, no associativity).
 
@@ -25,11 +23,8 @@ Definition natural_isomorphism : N1.t -> N2.t :=
 Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism.
 Proof.
 unfold natural_isomorphism.
-intros n m Eqxy.
-apply N1.recursion_wd.
-reflexivity.
-intros _ _ _ y' y'' H. now apply N2.succ_wd.
-assumption.
+repeat red; intros. f_equiv; trivial.
+repeat red; intros. now f_equiv.
 Qed.
 
 Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero.
@@ -42,7 +37,7 @@ Theorem natural_isomorphism_succ :
 Proof.
 unfold natural_isomorphism.
 intro n. rewrite N1.recursion_succ; auto with *.
-repeat red; intros. apply N2.succ_wd; auto.
+repeat red; intros. now f_equiv.
 Qed.
 
 Theorem hom_nat_iso : homomorphism natural_isomorphism.
@@ -53,9 +48,9 @@ Qed.
 
 End Homomorphism.
 
-Module Inverse (N1 N2 : NAxiomsSig).
+Module Inverse (N1 N2 : NAxiomsRecSig).
 
-Module Import NBasePropMod1 := NBasePropFunct N1.
+Module Import NBasePropMod1 := NBaseProp N1.
 (* This makes the tactic induct available. Since it is taken from
 (NBasePropFunct NAxiomsMod1), it refers to induction on N1. *)
 
@@ -76,7 +71,7 @@ Qed.
 
 End Inverse.
 
-Module Isomorphism (N1 N2 : NAxiomsSig).
+Module Isomorphism (N1 N2 : NAxiomsRecSig).
 
 Module Hom12 := Homomorphism N1 N2.
 Module Hom21 := Homomorphism N2 N1.
diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v
new file mode 100644
index 00000000..1e8e678c
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NLcm.v
@@ -0,0 +1,290 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import NAxioms NSub NDiv NGcd.
+
+(** * Least Common Multiple *)
+
+(** Unlike other functions around, we will define lcm below instead of
+  axiomatizing it. Indeed, there is no "prior art" about lcm in the
+  standard library to be compliant with, and the generic definition
+  of lcm via gcd is quite reasonable.
+
+  By the way, we also state here some combined properties of div/mod
+  and gcd.
+*)
+
+Module Type NLcmProp
+ (Import A : NAxiomsSig')
+ (Import B : NSubProp A)
+ (Import C : NDivProp A B)
+ (Import D : NGcdProp A B).
+
+(** Divibility and modulo *)
+
+Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
+Proof.
+ intros a b Hb. split.
+ intros Hab. exists (a/b). rewrite mul_comm.
+  rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
+ intros (c,Hc). rewrite Hc. now apply mod_mul.
+Qed.
+
+Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
+ (c*a)/b == c*(a/b).
+Proof.
+ intros a b c Hb H.
+ apply mul_cancel_l with b; trivial.
+ rewrite mul_assoc, mul_shuffle0.
+ assert (H':=H). apply mod_divide, div_exact in H'; trivial.
+ rewrite <- H', (mul_comm a c).
+ symmetry. apply div_exact; trivial.
+ apply mod_divide; trivial.
+ now apply divide_mul_r.
+Qed.
+
+(** Gcd of divided elements, for exact divisions *)
+
+Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) ->
+ gcd (a/c) (b/c) == (gcd a b)/c.
+Proof.
+ intros a b c Hc Ha Hb.
+ apply mul_cancel_l with c; try order.
+ assert (H:=gcd_greatest _ _ _ Ha Hb).
+ apply mod_divide, div_exact in H; try order.
+ rewrite <- H.
+ rewrite <- gcd_mul_mono_l; try order.
+ f_equiv; symmetry; apply div_exact; try order;
+  apply mod_divide; trivial; try order.
+Qed.
+
+Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
+ gcd (a/g) (b/g) == 1.
+Proof.
+ intros a b g NZ EQ. rewrite gcd_div_factor.
+ now rewrite <- EQ, div_same.
+ generalize (gcd_nonneg a b); order.
+ rewrite EQ; apply gcd_divide_l.
+ rewrite EQ; apply gcd_divide_r.
+Qed.
+
+(** The following equality is crucial for Euclid algorithm *)
+
+Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
+Proof.
+ intros a b Hb. rewrite (gcd_comm _ b).
+ rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)).
+ now rewrite add_comm, mul_comm, <- div_mod.
+Qed.
+
+(** We now define lcm thanks to gcd:
+
+    lcm a b = a * (b / gcd a b)
+            = (a / gcd a b) * b
+            = (a*b) / gcd a b
+
+   Nota: [lcm 0 0] should be 0, which isn't garantee with the third
+   equation above.
+*)
+
+Definition lcm a b := a*(b/gcd a b).
+
+Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
+Proof. unfold lcm. solve_proper. Qed.
+
+Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
+  a * (b / gcd a b) == (a*b)/gcd a b.
+Proof.
+ intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
+Qed.
+
+Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
+  (a / gcd a b) * b == (a*b)/gcd a b.
+Proof.
+ intros a b H. rewrite 2 (mul_comm _ b).
+ rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
+Qed.
+
+Lemma gcd_div_swap : forall a b,
+ (a / gcd a b) * b == a * (b / gcd a b).
+Proof.
+ intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
+ apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
+ now rewrite lcm_equiv1, <-lcm_equiv2.
+Qed.
+
+Lemma divide_lcm_l : forall a b, (a | lcm a b).
+Proof.
+ unfold lcm. intros a b. apply divide_factor_l.
+Qed.
+
+Lemma divide_lcm_r : forall a b, (b | lcm a b).
+Proof.
+ unfold lcm. intros a b. rewrite <- gcd_div_swap.
+ apply divide_factor_r.
+Qed.
+
+Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
+Proof.
+ intros a b c Ha Hb (c',Hc). exists c'.
+ now rewrite <- divide_div_mul_exact, Hc.
+Qed.
+
+Lemma lcm_least : forall a b c,
+ (a | c) -> (b | c) -> (lcm a b | c).
+Proof.
+ intros a b c Ha Hb. unfold lcm.
+ destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
+ apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
+ assert (Ga := gcd_divide_l a b).
+ assert (Gb := gcd_divide_r a b).
+ set (g:=gcd a b) in *.
+ assert (Ha' := divide_div g a c NEQ Ga Ha).
+ assert (Hb' := divide_div g b c NEQ Gb Hb).
+ destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'.
+ apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
+ destruct Hb' as (b',Hb').
+ exists b'.
+ rewrite mul_shuffle3, <- Hb'.
+ rewrite (proj2 (div_exact c g NEQ)).
+ rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv.
+ symmetry. apply div_exact; trivial.
+ apply mod_divide; trivial.
+ apply mod_divide; trivial. transitivity a; trivial.
+Qed.
+
+Lemma lcm_comm : forall a b, lcm a b == lcm b a.
+Proof.
+ intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
+ now rewrite <- gcd_div_swap.
+Qed.
+
+Lemma lcm_divide_iff : forall n m p,
+  (lcm n m | p) <-> (n | p) /\ (m | p).
+Proof.
+ intros. split. split.
+ transitivity (lcm n m); trivial using divide_lcm_l.
+ transitivity (lcm n m); trivial using divide_lcm_r.
+ intros (H,H'). now apply lcm_least.
+Qed.
+
+Lemma lcm_unique : forall n m p,
+ 0<=p -> (n|p) -> (m|p) ->
+ (forall q, (n|q) -> (m|q) -> (p|q)) ->
+ lcm n m == p.
+Proof.
+ intros n m p Hp Hn Hm H.
+ apply divide_antisym; trivial.
+ now apply lcm_least.
+ apply H. apply divide_lcm_l. apply divide_lcm_r.
+Qed.
+
+Lemma lcm_unique_alt : forall n m p, 0<=p ->
+ (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
+ lcm n m == p.
+Proof.
+ intros n m p Hp H.
+ apply lcm_unique; trivial.
+ apply H, divide_refl.
+ apply H, divide_refl.
+ intros. apply H. now split.
+Qed.
+
+Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
+Proof.
+ intros. apply lcm_unique_alt. apply le_0_l.
+ intros. now rewrite !lcm_divide_iff, and_assoc.
+Qed.
+
+Lemma lcm_0_l : forall n, lcm 0 n == 0.
+Proof.
+ intros. apply lcm_unique; trivial. order.
+ apply divide_refl.
+ apply divide_0_r.
+Qed.
+
+Lemma lcm_0_r : forall n, lcm n 0 == 0.
+Proof.
+ intros. now rewrite lcm_comm, lcm_0_l.
+Qed.
+
+Lemma lcm_1_l : forall n, lcm 1 n == n.
+Proof.
+ intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl.
+Qed.
+
+Lemma lcm_1_r : forall n, lcm n 1 == n.
+Proof.
+ intros. now rewrite lcm_comm, lcm_1_l.
+Qed.
+
+Lemma lcm_diag : forall n, lcm n n == n.
+Proof.
+ intros. apply lcm_unique; trivial using divide_refl, le_0_l.
+Qed.
+
+Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
+Proof.
+ intros. split.
+ intros EQ.
+ apply eq_mul_0.
+ apply divide_0_l. rewrite <- EQ. apply lcm_least.
+  apply divide_factor_l. apply divide_factor_r.
+ destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
+Qed.
+
+Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m.
+Proof.
+ intros n m H. apply lcm_unique_alt; trivial using le_0_l.
+ intros q. split. split; trivial. now transitivity m.
+ now destruct 1.
+Qed.
+
+Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m.
+Proof.
+ intros n m. split. now apply divide_lcm_eq_r.
+ intros EQ. rewrite <- EQ. apply divide_lcm_l.
+Qed.
+
+Lemma lcm_mul_mono_l :
+  forall n m p, lcm (p * n) (p * m) == p * lcm n m.
+Proof.
+ intros n m p.
+ destruct (eq_decidable p 0) as [Hp|Hp].
+  rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl.
+ destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
+  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
+  nzsimpl. rewrite lcm_0_l. now nzsimpl.
+ unfold lcm.
+ rewrite gcd_mul_mono_l.
+ rewrite mul_assoc. f_equiv.
+ now rewrite div_mul_cancel_l.
+Qed.
+
+Lemma lcm_mul_mono_r :
+ forall n m p, lcm (n * p) (m * p) == lcm n m * p.
+Proof.
+ intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
+Qed.
+
+Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
+ (gcd n m == 1 <-> lcm n m == n*m).
+Proof.
+ intros n m Hn Hm. split; intros H.
+ unfold lcm. rewrite H. now rewrite div_1_r.
+ unfold lcm in *.
+ apply mul_cancel_l in H; trivial.
+ assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
+ assert (H' := gcd_divide_r n m).
+ apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
+ rewrite H in H'.
+ rewrite <- (mul_1_l m) in H' at 1.
+ now apply mul_cancel_r in H'.
+Qed.
+
+End NLcmProp.
diff --git a/theories/Numbers/Natural/Abstract/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v
new file mode 100644
index 00000000..74827c6e
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NLog.v
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Base-2 Logarithm Properties *)
+
+Require Import NAxioms NSub NPow NParity NZLog.
+
+Module Type NLog2Prop
+ (A : NAxiomsSig)
+ (B : NSubProp A)
+ (C : NParityProp A B)
+ (D : NPowProp A B C).
+
+ (** For the moment we simply reuse NZ properties *)
+
+ Include NZLog2Prop A A A B D.Private_NZPow.
+ Include NZLog2UpProp A A A B D.Private_NZPow.
+End NLog2Prop.
diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v
new file mode 100644
index 00000000..cdff6dbc
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NMaxMin.v
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import NAxioms NSub GenericMinMax.
+
+(** * Properties of minimum and maximum specific to natural numbers *)
+
+Module Type NMaxMinProp (Import N : NAxiomsMiniSig').
+Include NSubProp N.
+
+(** Zero *)
+
+Lemma max_0_l : forall n, max 0 n == n.
+Proof.
+ intros. apply max_r. apply le_0_l.
+Qed.
+
+Lemma max_0_r : forall n, max n 0 == n.
+Proof.
+ intros. apply max_l. apply le_0_l.
+Qed.
+
+Lemma min_0_l : forall n, min 0 n == 0.
+Proof.
+ intros. apply min_l. apply le_0_l.
+Qed.
+
+Lemma min_0_r : forall n, min n 0 == 0.
+Proof.
+ intros. apply min_r. apply le_0_l.
+Qed.
+
+(** The following results are concrete instances of [max_monotone]
+    and similar lemmas. *)
+
+(** Succ *)
+
+Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono.
+Qed.
+
+Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m).
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono.
+Qed.
+
+(** Add *)
+
+Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l.
+Qed.
+
+Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r.
+Qed.
+
+Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l.
+Qed.
+
+Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r.
+Qed.
+
+(** Mul *)
+
+Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l.
+Qed.
+
+Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r.
+Qed.
+
+Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l.
+Qed.
+
+Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r.
+Qed.
+
+(** Sub *)
+
+Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l.
+ rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l.
+Qed.
+
+Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r.
+Qed.
+
+Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m.
+Proof.
+ intros. destruct (le_ge_cases n m).
+ rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l.
+ rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l.
+Qed.
+
+Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p.
+Proof.
+ intros. destruct (le_ge_cases n m);
+  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r.
+Qed.
+
+End NMaxMinProp.
diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v
index bdd4b674..1d6e8ba0 100644
--- a/theories/Numbers/Natural/Abstract/NMulOrder.v
+++ b/theories/Numbers/Natural/Abstract/NMulOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NAddOrder.
 
-Module NMulOrderPropFunct (Import N : NAxiomsSig').
-Include NAddOrderPropFunct N.
+Module NMulOrderProp (Import N : NAxiomsMiniSig').
+Include NAddOrderProp N.
 
 (** Theorems that are either not valid on Z or have different proofs
     on N and Z *)
@@ -55,7 +53,7 @@ Qed.
 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 -> lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split.
+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.
@@ -67,14 +65,18 @@ Proof.
 intros n m.
 split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l].
 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.
+apply lt_1_r in H1. rewrite H1, mul_0_l in H. order'.
 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.
+rewrite H2, mul_0_r in H. order'.
+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 m).
 rewrite H in H3; false_hyp H3 lt_irrefl.
 Qed.
 
-End NMulOrderPropFunct.
+(** Alternative name : *)
+
+Definition mul_eq_1 := eq_mul_1.
+
+End NMulOrderProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v
index 17dd3466..8bba7d72 100644
--- a/theories/Numbers/Natural/Abstract/NOrder.v
+++ b/theories/Numbers/Natural/Abstract/NOrder.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,18 +8,16 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NAdd.
 
-Module NOrderPropFunct (Import N : NAxiomsSig').
-Include NAddPropFunct N.
+Module NOrderProp (Import N : NAxiomsMiniSig').
+Include NAddProp N.
 
 (* 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 => 0 <= n /\ n < m).
+setoid_replace lt with (fun n m => 0 <= n < m).
 apply lt_wf.
 intros x y; split.
 intro H; split; [apply le_0_l | assumption]. now intros [_ H].
@@ -29,12 +27,12 @@ Defined.
 
 Theorem nlt_0_r : forall n, ~ n < 0.
 Proof.
-intro n; apply -> le_ngt. apply le_0_l.
+intro n; apply le_ngt. apply le_0_l.
 Qed.
 
 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.
+intros n H; apply le_succ_l in H; false_hyp H nlt_0_r.
 Qed.
 
 Theorem le_0_r : forall n, n <= 0 <-> n == 0.
@@ -65,6 +63,7 @@ Qed.
 
 Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n.
 Proof.
+setoid_rewrite one_succ.
 induct n. now left.
 cases n. intros; right; now left.
 intros n IH. destruct IH as [H | [H | H]].
@@ -75,6 +74,7 @@ Qed.
 
 Theorem lt_1_r : forall n, n < 1 <-> n == 0.
 Proof.
+setoid_rewrite one_succ.
 cases n.
 split; intro; [reflexivity | apply lt_succ_diag_r].
 intros n. rewrite <- succ_lt_mono.
@@ -83,6 +83,7 @@ Qed.
 
 Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1.
 Proof.
+setoid_rewrite one_succ.
 cases n.
 split; intro; [now left | apply le_succ_diag_r].
 intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd.
@@ -117,9 +118,9 @@ Proof.
 intros Base Step; induct n.
 intros; apply Base.
 intros n IH m H. elim H using le_ind.
-solve_predicate_wd.
+solve_proper.
 apply Step; [| apply IH]; now apply eq_le_incl.
-intros k H1 H2. apply -> le_succ_l in H1. apply lt_le_incl in H1. auto.
+intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto.
 Qed.
 
 Theorem lt_ind_rel :
@@ -131,7 +132,7 @@ intros Base Step; induct n.
 intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]].
 rewrite H; apply Base.
 intros n IH m H. elim H using lt_ind.
-solve_predicate_wd.
+solve_proper.
 apply Step; [| apply IH]; now apply lt_succ_diag_r.
 intros k H1 H2. apply lt_succ_l in H1. auto.
 Qed.
@@ -175,7 +176,7 @@ Theorem lt_le_pred : forall n m, n < m -> n <= P m.
 Proof.
 intro n; cases m.
 intro H; false_hyp H nlt_0_r.
-intros m IH. rewrite pred_succ; now apply -> lt_succ_r.
+intros m IH. rewrite pred_succ; now apply lt_succ_r.
 Qed.
 
 Theorem lt_pred_le : forall n m, P n < m -> n <= m.
@@ -183,7 +184,7 @@ Theorem lt_pred_le : forall n m, P n < m -> n <= m.
 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.
+intros n IH. rewrite pred_succ in IH. now apply le_succ_l.
 Qed.
 
 Theorem lt_pred_lt : forall n m, n < P m -> n < m.
@@ -200,7 +201,7 @@ 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.
+solve_proper.
 intro; rewrite pred_0; apply le_0_l.
 intros p q H1 _; now do 2 rewrite pred_succ.
 Qed.
@@ -208,12 +209,12 @@ Qed.
 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.
+assert (m ~= 0). apply neq_0_lt_0. now apply lt_lt_0 with n.
 now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ;
-[apply <- succ_lt_mono | | |].
-assert (m ~= 0). apply <- neq_0_lt_0. apply lt_lt_0 with (P n).
+[apply succ_lt_mono | | |].
+assert (m ~= 0). apply neq_0_lt_0. apply lt_lt_0 with (P n).
 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.
+apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2.
 Qed.
 
 Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
@@ -224,13 +225,13 @@ Qed.
 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.
+intros n m H. apply lt_le_pred. now apply le_succ_l.
 Qed.
 
 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.
+intros n m H. apply lt_succ_r. now apply lt_pred_le.
 Qed.
 
 Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m.
@@ -240,5 +241,5 @@ rewrite pred_0. split; intro H; apply le_0_l.
 intro n. rewrite pred_succ. apply succ_le_mono.
 Qed.
 
-End NOrderPropFunct.
+End NOrderProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v
new file mode 100644
index 00000000..6a1e20ce
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NParity.v
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool NSub NZParity.
+
+(** Some additionnal properties of [even], [odd]. *)
+
+Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N).
+
+Include NZParityProp N N NP.
+
+Lemma odd_pred : forall n, n~=0 -> odd (P n) = even n.
+Proof.
+ intros. rewrite <- (succ_pred n) at 2 by trivial.
+ symmetry. apply even_succ.
+Qed.
+
+Lemma even_pred : forall n, n~=0 -> even (P n) = odd n.
+Proof.
+ intros. rewrite <- (succ_pred n) at 2 by trivial.
+ symmetry. apply odd_succ.
+Qed.
+
+Lemma even_sub : forall n m, m<=n -> even (n-m) = Bool.eqb (even n) (even m).
+Proof.
+ intros.
+ case_eq (even n); case_eq (even m);
+  rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec;
+  intros (m',Hm) (n',Hn).
+ exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm.
+ exists (n'-m'-1).
+  rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r.
+  rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr.
+  symmetry. apply sub_add.
+  apply le_add_le_sub_l.
+  rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1.
+  rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'.
+  rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r.
+  destruct (le_gt_cases n' m') as [LE|GT]; trivial.
+  generalize (double_below _ _ LE). order.
+ exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm.
+  apply add_sub_swap.
+  apply mul_le_mono_pos_l; try order'.
+  destruct (le_gt_cases m' n') as [LE|GT]; trivial.
+  generalize (double_above _ _ GT). order.
+ exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l.
+  rewrite sub_add_distr. rewrite add_sub_swap. apply add_sub.
+  apply succ_le_mono.
+  rewrite add_1_r in Hm,Hn. order.
+Qed.
+
+Lemma odd_sub : forall n m, m<=n -> odd (n-m) = xorb (odd n) (odd m).
+Proof.
+ intros. rewrite <- !negb_even. rewrite even_sub by trivial.
+ now destruct (even n), (even m).
+Qed.
+
+End NParityProp.
diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v
new file mode 100644
index 00000000..07aee9c6
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NPow.v
@@ -0,0 +1,160 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Properties of the power function *)
+
+Require Import Bool NAxioms NSub NParity NZPow.
+
+(** Derived properties of power, specialized on natural numbers *)
+
+Module Type NPowProp
+ (Import A : NAxiomsSig')
+ (Import B : NSubProp A)
+ (Import C : NParityProp A B).
+
+ Module Import Private_NZPow := Nop <+ NZPowProp A A B.
+
+Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
+Ltac wrap l := intros; apply l; auto'.
+
+Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b.
+Proof. wrap pow_succ_r. Qed.
+
+(** Power and basic constants *)
+
+Lemma pow_0_l : forall a, a~=0 -> 0^a == 0.
+Proof. wrap pow_0_l. Qed.
+
+Definition pow_1_r : forall a, a^1 == a
+ := pow_1_r.
+
+Lemma pow_1_l : forall a, 1^a == 1.
+Proof. wrap pow_1_l. Qed.
+
+Definition pow_2_r : forall a, a^2 == a*a
+ := pow_2_r.
+
+(** Power and addition, multiplication *)
+
+Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c.
+Proof. wrap pow_add_r. Qed.
+
+Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c.
+Proof. wrap pow_mul_l. Qed.
+
+Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c.
+Proof. wrap pow_mul_r. Qed.
+
+(** Power and nullity *)
+
+Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0.
+Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed.
+
+Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0.
+Proof. wrap pow_nonzero. Qed.
+
+Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0.
+Proof.
+ intros a b. split.
+ rewrite pow_eq_0_iff. intros [H |[H H']].
+  generalize (le_0_l b); order. split; order.
+ intros (Hb,Ha). rewrite Ha. now apply pow_0_l'.
+Qed.
+
+(** Monotonicity *)
+
+Lemma pow_lt_mono_l : forall a b c, c~=0 -> a<b -> a^c < b^c.
+Proof. wrap pow_lt_mono_l. Qed.
+
+Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c.
+Proof. wrap pow_le_mono_l. Qed.
+
+Lemma pow_gt_1 : forall a b, 1<a -> b~=0 -> 1<a^b.
+Proof. wrap pow_gt_1. Qed.
+
+Lemma pow_lt_mono_r : forall a b c, 1<a -> b<c -> a^b < a^c.
+Proof. wrap pow_lt_mono_r. Qed.
+
+(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *)
+
+Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c.
+Proof. wrap pow_le_mono_r. Qed.
+
+Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d ->
+ a^b <= c^d.
+Proof. wrap pow_le_mono. Qed.
+
+Definition pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d ->
+ a^b < c^d
+ := pow_lt_mono.
+
+(** Injectivity *)
+
+Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b.
+Proof. intros; eapply pow_inj_l; eauto; auto'. Qed.
+
+Lemma pow_inj_r : forall a b c, 1<a -> a^b == a^c -> b == c.
+Proof. intros; eapply pow_inj_r; eauto; auto'. Qed.
+
+(** Monotonicity results, both ways *)
+
+Lemma pow_lt_mono_l_iff : forall a b c, c~=0 ->
+  (a<b <-> a^c < b^c).
+Proof. wrap pow_lt_mono_l_iff. Qed.
+
+Lemma pow_le_mono_l_iff : forall a b c, c~=0 ->
+  (a<=b <-> a^c <= b^c).
+Proof. wrap pow_le_mono_l_iff. Qed.
+
+Lemma pow_lt_mono_r_iff : forall a b c, 1<a ->
+  (b<c <-> a^b < a^c).
+Proof. wrap pow_lt_mono_r_iff. Qed.
+
+Lemma pow_le_mono_r_iff : forall a b c, 1<a ->
+  (b<=c <-> a^b <= a^c).
+Proof. wrap pow_le_mono_r_iff. Qed.
+
+(** For any a>1, the a^x function is above the identity function *)
+
+Lemma pow_gt_lin_r : forall a b, 1<a -> b < a^b.
+Proof. wrap pow_gt_lin_r. Qed.
+
+(** Someday, we should say something about the full Newton formula.
+    In the meantime, we can at least provide some inequalities about
+    (a+b)^c.
+*)
+
+Lemma pow_add_lower : forall a b c, c~=0 ->
+  a^c + b^c <= (a+b)^c.
+Proof. wrap pow_add_lower. Qed.
+
+(** This upper bound can also be seen as a convexity proof for x^c :
+    image of (a+b)/2 is below the middle of the images of a and b
+*)
+
+Lemma pow_add_upper : forall a b c, c~=0 ->
+  (a+b)^c <= 2^(pred c) * (a^c + b^c).
+Proof. wrap pow_add_upper. Qed.
+
+(** Power and parity *)
+
+Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a.
+Proof.
+ intros a b Hb. rewrite neq_0_lt_0 in Hb.
+ apply lt_ind with (4:=Hb). solve_proper.
+ now nzsimpl.
+ clear b Hb. intros b Hb IH.
+ rewrite pow_succ_r', even_mul, IH. now destruct (even a).
+Qed.
+
+Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a.
+Proof.
+ intros. now rewrite <- !negb_even, even_pow.
+Qed.
+
+End NPowProp.
diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v
index c9e05113..1edb6b51 100644
--- a/theories/Numbers/Natural/Abstract/NProperties.v
+++ b/theories/Numbers/Natural/Abstract/NProperties.v
@@ -1,22 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Export NAxioms.
+Require Import NMaxMin NParity NPow NSqrt NLog NDiv NGcd NLcm NBits.
 
-Require Export NAxioms NSub.
+(** This functor summarizes all known facts about N. *)
 
-(** 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.
+Module Type NProp (N:NAxiomsSig) :=
+ NMaxMinProp N <+ NParityProp N <+ NPowProp N <+ NSqrtProp N
+  <+ NLog2Prop N <+ NDivProp N <+ NGcdProp N <+ NLcmProp N
+  <+ NBitsProp N.
diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v
new file mode 100644
index 00000000..34b7d011
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NSqrt.v
@@ -0,0 +1,75 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Properties of Square Root Function *)
+
+Require Import NAxioms NSub NZSqrt.
+
+Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A).
+
+ Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B.
+
+ Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
+ Ltac wrap l := intros; apply l; auto'.
+
+ (** We redefine NZSqrt's results, without the non-negative hyps *)
+
+Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a).
+Proof. wrap sqrt_spec. Qed.
+
+Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b
+ := sqrt_unique.
+
+Lemma sqrt_square : forall a, √(a*a) == a.
+Proof. wrap sqrt_square. Qed.
+
+Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b
+ := sqrt_le_mono.
+
+Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b
+ := sqrt_lt_cancel.
+
+Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a.
+Proof. wrap sqrt_le_square. Qed.
+
+Lemma sqrt_lt_square : forall a b, a<b*b <-> √a < b.
+Proof. wrap sqrt_lt_square. Qed.
+
+Definition sqrt_0 := sqrt_0.
+Definition sqrt_1 := sqrt_1.
+Definition sqrt_2 := sqrt_2.
+
+Definition sqrt_lt_lin : forall a, 1<a -> √a<a
+ := sqrt_lt_lin.
+
+Lemma sqrt_le_lin : forall a, √a<=a.
+Proof. wrap sqrt_le_lin. Qed.
+
+Definition sqrt_mul_below : forall a b, √a * √b <= √(a*b)
+ := sqrt_mul_below.
+
+Lemma sqrt_mul_above : forall a b, √(a*b) < S (√a) * S (√b).
+Proof. wrap sqrt_mul_above. Qed.
+
+Lemma sqrt_succ_le : forall a, √(S a) <= S (√a).
+Proof. wrap sqrt_succ_le. Qed.
+
+Lemma sqrt_succ_or : forall a, √(S a) == S (√a) \/ √(S a) == √a.
+Proof. wrap sqrt_succ_or. Qed.
+
+Definition sqrt_add_le : forall a b, √(a+b) <= √a + √b
+ := sqrt_add_le.
+
+Lemma add_sqrt_le : forall a b, √a + √b <= √(2*(a+b)).
+Proof. wrap add_sqrt_le. Qed.
+
+(** For the moment, we include stuff about [sqrt_up] with patching them. *)
+
+Include NZSqrtUpProp A A B Private_NZSqrt.
+
+End NSqrtProp.
diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v
index d9a2427d..607746d5 100644
--- a/theories/Numbers/Natural/Abstract/NStrongRec.v
+++ b/theories/Numbers/Natural/Abstract/NStrongRec.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,15 +8,15 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NStrongRec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file defined the strong (course-of-value, well-founded) recursion
 and proves its properties *)
 
 Require Export NSub.
 
-Module NStrongRecPropFunct (Import N : NAxiomsSig').
-Include NSubPropFunct N.
+Ltac f_equiv' := repeat progress (f_equiv; try intros ? ? ?; auto).
+
+Module NStrongRecProp (Import N : NAxiomsRecSig').
+Include NSubProp N.
 
 Section StrongRecursion.
 
@@ -51,30 +51,18 @@ Proof.
 reflexivity.
 Qed.
 
-(** 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.
+unfold strong_rec0; f_equiv'.
 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'.
-rewrite !strong_rec_alt.
-apply strong_rec0_wd; auto.
-now rewrite Enn'.
+rewrite !strong_rec_alt; f_equiv'.
 Qed.
 
 Section FixPoint.
@@ -92,18 +80,16 @@ 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. 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 *.
+f_equiv.
+rewrite recursion_succ; f_equiv'.
+reflexivity.
 Qed.
 
 Lemma strong_rec_0 : forall a,
  Aeq (strong_rec a f 0) (f (fun _ => a) 0).
 Proof.
-intros. rewrite strong_rec_alt, strong_rec0_succ.
-apply f_wd; auto with *.
-red; intros; rewrite strong_rec0_0; auto with *.
+intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'.
+rewrite strong_rec0_0. reflexivity.
 Qed.
 
 (* We need an assumption saying that for every n, the step function (f h n)
@@ -158,7 +144,7 @@ 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 *.
+f_equiv.
 intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *.
 Qed.
 
@@ -204,7 +190,7 @@ Qed.
 End FixPoint.
 End StrongRecursion.
 
-Implicit Arguments strong_rec [A].
+Arguments strong_rec [A] a f n.
 
-End NStrongRecPropFunct.
+End NStrongRecProp.
 
diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v
index c0be3114..d7143c67 100644
--- a/theories/Numbers/Natural/Abstract/NSub.v
+++ b/theories/Numbers/Natural/Abstract/NSub.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,10 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NSub.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NMulOrder.
 
-Module Type NSubPropFunct (Import N : NAxiomsSig').
-Include NMulOrderPropFunct N.
+Module Type NSubProp (Import N : NAxiomsMiniSig').
+Include NMulOrderProp N.
 
 Theorem sub_0_l : forall n, 0 - n == 0.
 Proof.
@@ -37,7 +35,7 @@ Qed.
 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.
+solve_proper.
 intro; rewrite sub_0_r; apply neq_succ_0.
 intros; now rewrite sub_succ.
 Qed.
@@ -47,8 +45,8 @@ Proof.
 intros n m p; induct p.
 intro; now do 2 rewrite sub_0_r.
 intros p IH H. do 2 rewrite sub_succ_r.
-rewrite <- IH by (apply lt_le_incl; now apply -> le_succ_l).
-rewrite add_pred_r by (apply sub_gt; now apply -> le_succ_l).
+rewrite <- IH by (apply lt_le_incl; now apply le_succ_l).
+rewrite add_pred_r by (apply sub_gt; now apply le_succ_l).
 reflexivity.
 Qed.
 
@@ -205,6 +203,26 @@ Proof.
 intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
 Qed.
 
+Theorem sub_lt : forall n m, m <= n -> 0 < m -> n - m < n.
+Proof.
+intros n m LE LT.
+assert (LE' := le_sub_l n m). rewrite lt_eq_cases in LE'.
+destruct LE' as [LT'|EQ]. assumption.
+apply add_sub_eq_nz in EQ; [|order].
+rewrite (add_lt_mono_r _ _ n), add_0_l in LT. order.
+Qed.
+
+Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p.
+Proof.
+ intros. rewrite le_sub_le_add_r. transitivity m. assumption. apply sub_add_le.
+Qed.
+
+Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n.
+Proof.
+ intros. rewrite le_sub_le_add_r.
+ transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l].
+Qed.
+
 (** Sub and mul *)
 
 Theorem mul_pred_r : forall n m, n * (P m) == n * m - n.
@@ -224,10 +242,10 @@ intros n IH. destruct (le_gt_cases m n) as [H | H].
 rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l.
 rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p).
 rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r.
-now apply <- add_cancel_l.
-assert (H1 : S n <= m); [now apply <- le_succ_l |].
-setoid_replace (S n - m) with 0 by now apply <- sub_0_le.
-setoid_replace ((S n * p) - m * p) with 0 by (apply <- sub_0_le; now apply mul_le_mono_r).
+now apply add_cancel_l.
+assert (H1 : S n <= m); [now apply le_succ_l |].
+setoid_replace (S n - m) with 0 by now apply sub_0_le.
+setoid_replace ((S n * p) - m * p) with 0 by (apply sub_0_le; now apply mul_le_mono_r).
 apply mul_0_l.
 Qed.
 
@@ -298,5 +316,5 @@ Theorem add_dichotomy :
   forall n m, (exists p, p + n == m) \/ (exists p, p + m == n).
 Proof. exact le_alt_dichotomy. Qed.
 
-End NSubPropFunct.
+End NSubProp.
 
diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v
index 7c480862..7f205b38 100644
--- a/theories/Numbers/Natural/BigN/BigN.v
+++ b/theories/Numbers/Natural/BigN/BigN.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,7 +12,7 @@
 
 Require Export Int31.
 Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake
-  NProperties NDiv GenericMinMax.
+  NProperties GenericMinMax.
 
 (** The following [BigN] module regroups both the operations and
     all the abstract properties:
@@ -21,73 +21,63 @@ Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake
        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].
+    - [NProp] adds all generic properties derived from [NAxioms]
     - [MinMax*Properties] provides properties of [min] and [max].
 
 *)
 
-Module BigN <: NType <: OrderedTypeFull <: TotalOrder :=
- NMake.Make Int31Cyclic <+ NTypeIsNAxioms
- <+ !NPropSig <+ !NDivPropFunct <+ HasEqBool2Dec
- <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
+Delimit Scope bigN_scope with bigN.
 
+Module BigN <: NType <: OrderedTypeFull <: TotalOrder.
+ Include NMake.Make Int31Cyclic [scope abstract_scope to bigN_scope].
+ Bind Scope bigN_scope with t t'.
+ Include NTypeIsNAxioms
+  <+ NProp [no inline]
+  <+ HasEqBool2Dec [no inline]
+  <+ MinMaxLogicalProperties [no inline]
+  <+ MinMaxDecProperties [no inline].
+End BigN.
+
+(** Nota concerning scopes : for the first Include, we cannot bind
+    the scope bigN_scope to a type that doesn't exists yet.
+    We hence need to explicitely declare the scope substitution.
+    For the next Include, the abstract type t (in scope abstract_scope)
+    gets substituted to concrete BigN.t (in scope bigN_scope),
+    and the corresponding argument scope are fixed automatically.
+*)
 
 (** Notations about [BigN] *)
 
-Notation bigN := BigN.t.
-
-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_.
-(* 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 Open Scope bigN_scope.
 
+Notation bigN := BigN.t.
+Bind Scope bigN_scope with bigN BigN.t BigN.t'.
+Arguments BigN.N0 _%int31.
 Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *)
 Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *)
+Local Notation "2" := BigN.two : 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.pow : bigN_scope.
 Infix "?=" := BigN.compare : bigN_scope.
+Infix "=?" := BigN.eqb (at level 70, no associativity) : bigN_scope.
+Infix "<=?" := BigN.leb (at level 70, no associativity) : bigN_scope.
+Infix "<?" := BigN.ltb (at level 70, no associativity) : 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.
+Notation "x != y" := (~x==y) (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 "x > y" := (y < x) (only parsing) : bigN_scope.
+Notation "x >= y" := (y <= x) (only parsing) : bigN_scope.
+Notation "x < y < z" := (x<y /\ y<z) : bigN_scope.
+Notation "x < y <= z" := (x<y /\ y<=z) : bigN_scope.
+Notation "x <= y < z" := (x<=y /\ y<z) : bigN_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z) : bigN_scope.
 Notation "[ i ]" := (BigN.to_Z i) : bigN_scope.
 Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope.
 
-Local Open Scope bigN_scope.
-
 (** Example of reasoning about [BigN] *)
 
 Theorem succ_pred: forall q : bigN,
@@ -107,24 +97,24 @@ 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.
+Lemma BigNeqb_correct : forall x y, (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.
+Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow.
 Proof.
 constructor.
-intros. red. rewrite BigN.spec_power. unfold id.
-destruct Zpower_theory as [EQ]. rewrite EQ.
+intros. red. rewrite BigN.spec_pow, BigN.spec_of_N.
+rewrite Zpower_theory.(rpow_pow_N).
 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).
+ (fun a b => if 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).
+case Z.eqb_spec.
 BigN.zify. auto with zarith.
 intros NEQ.
 generalize (BigN.spec_div_eucl a b).
@@ -163,6 +153,7 @@ Ltac isBigNcst t :=
    end
  | BigN.zero => constr:true
  | BigN.one => constr:true
+ | BigN.two => constr:true
  | _ => constr:false
  end.
 
@@ -172,6 +163,12 @@ Ltac BigNcst t :=
  | false => constr:NotConstant
  end.
 
+Ltac BigN_to_N t :=
+ match isBigNcst t with
+ | true => eval vm_compute in (BigN.to_N t)
+ | false => constr:NotConstant
+ end.
+
 Ltac Ncst t :=
  match isNcst t with
  | true => constr:t
@@ -183,11 +180,11 @@ Ltac Ncst t :=
 Add Ring BigNr : BigNring
  (decidable BigNeqb_correct,
   constants [BigNcst],
-  power_tac BigNpower [Ncst],
+  power_tac BigNpower [BigN_to_N],
   div BigNdiv).
 
 Section TestRing.
-Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
+Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
 intros. ring_simplify. reflexivity.
 Qed.
 End TestRing.
diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v
index 2b70f1bb..952f6183 100644
--- a/theories/Numbers/Natural/BigN/NMake.v
+++ b/theories/Numbers/Natural/BigN/NMake.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,18 +16,176 @@
     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.
+Require Import Bool BigNumPrelude ZArith Nnat Ndigits CyclicAxioms DoubleType
+  Nbasic Wf_nat StreamMemo NSig NMake_gen.
 
-Module Make (Import W0:CyclicType) <: NType.
+Module Make (W0:CyclicType) <: NType.
 
- (** Macro-generated part *)
+ (** Let's include the macro-generated part. Even if we can't functorize
+     things (due to Eval red_t below), the rest of the module only uses
+     elements mentionned in interface [NAbstract]. *)
 
  Include NMake_gen.Make W0.
 
+ Open Scope Z_scope.
+
+ Local Notation "[ x ]" := (to_Z x).
+
+ Definition eq (x y : t) := [x] = [y].
+
+ Declare Reduction red_t :=
+  lazy beta iota delta
+   [iter_t reduce same_level mk_t mk_t_S succ_t dom_t dom_op].
+
+ Ltac red_t :=
+  match goal with |- ?u => let v := (eval red_t in u) in change v end.
+
+ (** * Generic results *)
+
+ Tactic Notation "destr_t" constr(x) "as" simple_intropattern(pat) :=
+  destruct (destr_t x) as pat; cbv zeta;
+  rewrite ?iter_mk_t, ?spec_mk_t, ?spec_reduce.
+
+ Lemma spec_same_level : forall A (P:Z->Z->A->Prop)
+  (f : forall n, dom_t n -> dom_t n -> A),
+  (forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)) ->
+  forall x y, P [x] [y] (same_level f x y).
+ Proof.
+ intros. apply spec_same_level_dep with (P:=fun _ => P); auto.
+ Qed.
+
+ Theorem spec_pos: forall x, 0 <= [x].
+ Proof.
+ intros x. destr_t x as (n,x). now case (ZnZ.spec_to_Z x).
+ Qed.
+
+ Lemma digits_dom_op_incr : forall n m, (n<=m)%nat ->
+  (ZnZ.digits (dom_op n) <= ZnZ.digits (dom_op m))%positive.
+ Proof.
+ intros.
+ change (Zpos (ZnZ.digits (dom_op n)) <= Zpos (ZnZ.digits (dom_op m))).
+ rewrite !digits_dom_op, !Pshiftl_nat_Zpower.
+ apply Zmult_le_compat_l; auto with zarith.
+ apply Zpower_le_monotone2; auto with zarith.
+ Qed.
+
+ Definition to_N (x : t) := Z.to_N (to_Z x).
+
+ (** * Zero, One *)
+
+ Definition zero := mk_t O ZnZ.zero.
+ Definition one := mk_t O ZnZ.one.
+
+ Theorem spec_0: [zero] = 0.
+ Proof.
+ unfold zero. rewrite spec_mk_t. exact ZnZ.spec_0.
+ Qed.
+
+ Theorem spec_1: [one] = 1.
+ Proof.
+ unfold one. rewrite spec_mk_t. exact ZnZ.spec_1.
+ Qed.
+
+ (** * Successor *)
+
+ (** NB: it is crucial here and for the rest of this file to preserve
+     the let-in's. They allow to pre-compute once and for all the
+     field access to Z/nZ initial structures (when n=0..6). *)
+
+ Local Notation succn := (fun n =>
+  let op := dom_op n in
+  let succ_c := ZnZ.succ_c in
+  let one := ZnZ.one in
+  fun x => match succ_c x with
+   | C0 r => mk_t n r
+   | C1 r => mk_t_S n (WW one r)
+  end).
+
+ Definition succ : t -> t := Eval red_t in iter_t succn.
+
+ Lemma succ_fold : succ = iter_t succn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_succ: forall n, [succ n] = [n] + 1.
+ Proof.
+  intros x. rewrite succ_fold. destr_t x as (n,x).
+  generalize (ZnZ.spec_succ_c x); case ZnZ.succ_c.
+  intros. rewrite spec_mk_t. assumption.
+  intros. unfold interp_carry in *.
+  rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_1. assumption.
+ Qed.
+
+ (** Two *)
+
+ (** Not really pretty, but since W0 might be Z/2Z, we're not sure
+     there's a proper 2 there. *)
+
+ Definition two := succ one.
+
+ Lemma spec_2 : [two] = 2.
+ Proof.
+  unfold two. now rewrite spec_succ, spec_1.
+ Qed.
+
+ (** * Addition *)
+
+ Local Notation addn := (fun n =>
+  let op := dom_op n in
+  let add_c := ZnZ.add_c in
+  let one := ZnZ.one in
+  fun x y =>match add_c x y with
+  | C0 r => mk_t n r
+  | C1 r => mk_t_S n (WW one r)
+  end).
+
+ Definition add : t -> t -> t := Eval red_t in same_level addn.
+
+ Lemma add_fold : add = same_level addn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_add: forall x y, [add x y] = [x] + [y].
+ Proof.
+  intros x y. rewrite add_fold. apply spec_same_level; clear x y.
+  intros n x y. simpl.
+  generalize (ZnZ.spec_add_c x y); case ZnZ.add_c; intros z H.
+  rewrite spec_mk_t. assumption.
+  rewrite spec_mk_t_S. unfold interp_carry in H.
+  simpl. rewrite ZnZ.spec_1. assumption.
+ Qed.
 
  (** * Predecessor *)
 
+ Local Notation predn := (fun n =>
+  let pred_c := ZnZ.pred_c in
+  fun x => match pred_c x with
+   | C0 r => reduce n r
+   | C1 _ => zero
+  end).
+
+ Definition pred : t -> t := Eval red_t in iter_t predn.
+
+ Lemma pred_fold : pred = iter_t predn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1.
+ Proof.
+  intros x. rewrite pred_fold. destr_t x as (n,x). intros H.
+  generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'.
+  rewrite spec_reduce. assumption.
+  exfalso. unfold interp_carry in *.
+  generalize (ZnZ.spec_to_Z x) (ZnZ.spec_to_Z y); auto with zarith.
+ Qed.
+
+ Theorem spec_pred0 : forall x, [x] = 0 -> [pred x] = 0.
+ Proof.
+  intros x. rewrite pred_fold. destr_t x as (n,x). intros H.
+  generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'.
+  rewrite spec_reduce.
+  unfold interp_carry in H'.
+  generalize (ZnZ.spec_to_Z y); auto with zarith.
+  exact spec_0.
+ Qed.
+
  Lemma spec_pred : forall x, [pred x] = Zmax 0 ([x]-1).
  Proof.
  intros. destruct (Zle_lt_or_eq _ _ (spec_pos x)).
@@ -36,9 +194,42 @@ Module Make (Import W0:CyclicType) <: NType.
  rewrite <- H; apply spec_pred0; auto.
  Qed.
 
-
  (** * Subtraction *)
 
+ Local Notation subn := (fun n =>
+  let sub_c := ZnZ.sub_c in
+  fun x y => match sub_c x y with
+  | C0 r => reduce n r
+  | C1 r => zero
+  end).
+
+ Definition sub : t -> t -> t := Eval red_t in same_level subn.
+
+ Lemma sub_fold : sub = same_level subn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y].
+ Proof.
+  intros x y. rewrite sub_fold. apply spec_same_level. clear x y.
+  intros n x y. simpl.
+  generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE.
+  rewrite spec_reduce. assumption.
+  unfold interp_carry in H.
+  exfalso.
+  generalize (ZnZ.spec_to_Z z); auto with zarith.
+ Qed.
+
+ Theorem spec_sub0 : forall x y, [x] < [y] -> [sub x y] = 0.
+ Proof.
+  intros x y. rewrite sub_fold. apply spec_same_level. clear x y.
+  intros n x y. simpl.
+  generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE.
+  rewrite spec_reduce.
+  unfold interp_carry in H.
+  generalize (ZnZ.spec_to_Z z); auto with zarith.
+  exact spec_0.
+ Qed.
+
  Lemma spec_sub : forall x y, [sub x y] = Zmax 0 ([x]-[y]).
  Proof.
  intros. destruct (Zle_or_lt [y] [x]).
@@ -48,35 +239,112 @@ Module Make (Import W0:CyclicType) <: NType.
 
  (** * Comparison *)
 
- Theorem spec_compare : forall x y, compare x y = Zcompare [x] [y].
+ Definition comparen_m n :
+  forall m, word (dom_t n) (S m) -> dom_t n -> comparison :=
+  let op := dom_op n in
+  let zero := @ZnZ.zero _ op in
+  let compare := @ZnZ.compare _ op in
+  let compare0 := compare zero in
+  fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m).
+
+ Let spec_comparen_m:
+  forall n m (x : word (dom_t n) (S m)) (y : dom_t n),
+   comparen_m n m x y = Zcompare (eval n (S m) x) (ZnZ.to_Z y).
+ Proof.
+  intros n m x y.
+  unfold comparen_m, eval.
+  rewrite nmake_double.
+  apply spec_compare_mn_1.
+  exact ZnZ.spec_0.
+  intros. apply ZnZ.spec_compare.
+  exact ZnZ.spec_to_Z.
+  exact ZnZ.spec_compare.
+  exact ZnZ.spec_compare.
+  exact ZnZ.spec_to_Z.
+ Qed.
+
+ Definition comparenm n m wx wy :=
+    let mn := Max.max n m in
+    let d := diff n m in
+    let op := make_op mn in
+    ZnZ.compare
+       (castm (diff_r n m) (extend_tr wx (snd d)))
+       (castm (diff_l n m) (extend_tr wy (fst d))).
+
+ Local Notation compare_folded :=
+   (iter_sym _
+      (fun n => @ZnZ.compare _ (dom_op n))
+      comparen_m
+      comparenm
+      CompOpp).
+
+ Definition compare : t -> t -> comparison :=
+  Eval lazy beta iota delta [iter_sym dom_op dom_t comparen_m] in
+  compare_folded.
+
+ Lemma compare_fold : compare = compare_folded.
  Proof.
- intros x y. generalize (spec_compare_aux x y); destruct compare;
- intros; symmetry; try rewrite Zcompare_Eq_iff_eq; assumption.
+ lazy beta iota delta [iter_sym dom_op dom_t comparen_m]. reflexivity.
  Qed.
 
- Definition eq_bool x y :=
+(** TODO: no need for ZnZ.Spec_rect , Spec_ind, and so on... *)
+
+ Theorem spec_compare : forall x y,
+   compare x y = Zcompare [x] [y].
+ Proof.
+  intros x y. rewrite compare_fold. apply spec_iter_sym; clear x y.
+  intros. apply ZnZ.spec_compare.
+  intros. cbv beta zeta. apply spec_comparen_m.
+  intros n m x y; unfold comparenm.
+  rewrite (spec_cast_l n m x), (spec_cast_r n m y).
+  unfold to_Z; apply ZnZ.spec_compare.
+  intros. subst. apply Zcompare_antisym.
+ Qed.
+
+ Definition eqb (x y : t) : bool :=
   match compare x y with
   | Eq => true
   | _  => false
   end.
 
- Theorem spec_eq_bool : forall x y, eq_bool x y = Zeq_bool [x] [y].
+ Theorem spec_eqb x y : eqb x y = Z.eqb [x] [y].
  Proof.
- intros. unfold eq_bool, Zeq_bool. rewrite spec_compare; reflexivity.
+ apply eq_iff_eq_true.
+ unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare.
+ split; [now destruct Z.compare | now intros ->].
  Qed.
 
- Theorem spec_eq_bool_aux: forall x y,
-    if eq_bool x y then [x] = [y] else [x] <> [y].
+ Definition lt (n m : t) := [n] < [m].
+ Definition le (n m : t) := [n] <= [m].
+
+ Definition ltb (x y : t) : bool :=
+  match compare x y with
+  | Lt => true
+  | _  => false
+  end.
+
+ Theorem spec_ltb x y : ltb x y = Z.ltb [x] [y].
  Proof.
- intros x y; unfold eq_bool.
- generalize (spec_compare_aux x y); case compare; auto with zarith.
+ apply eq_iff_eq_true.
+ rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare.
+ split; [now destruct Z.compare | now intros ->].
  Qed.
 
- Definition lt n m := [n] < [m].
- Definition le n m := [n] <= [m].
+ Definition leb (x y : t) : bool :=
+  match compare x y with
+  | Gt => false
+  | _  => true
+  end.
+
+ Theorem spec_leb x y : leb x y = Z.leb [x] [y].
+ Proof.
+ apply eq_iff_eq_true.
+ rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare.
+ destruct Z.compare; split; try easy. now destruct 1.
+ Qed.
 
- 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.
+ Definition min (n m : t) : t := match compare n m with Gt => m | _ => n end.
+ Definition max (n m : t) : t := match compare n m with Lt => m | _ => n end.
 
  Theorem spec_max : forall n m, [max n m] = Zmax [n] [m].
  Proof.
@@ -88,46 +356,239 @@ Module Make (Import W0:CyclicType) <: NType.
  intros. unfold min, Zmin. rewrite spec_compare; destruct Zcompare; reflexivity.
  Qed.
 
+ (** * Multiplication *)
+
+ Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t :=
+  let op := dom_op n in
+  let zero := @ZnZ.zero _ op in
+  let succ := @ZnZ.succ _ op in
+  let add_c := @ZnZ.add_c _ op in
+  let mul_c := @ZnZ.mul_c _ op in
+  let ww := @ZnZ.WW _ op in
+  let ow := @ZnZ.OW _ op in
+  let eq0 := @ZnZ.eq0 _ op in
+  let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in
+  let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in
+  fun m x y =>
+   let (w,r) := mul_add_n1 (S m) x y zero in
+   if eq0 w then mk_t_w' n m r
+   else mk_t_w' n (S m) (WW (extend n m w) r).
+
+ Definition mulnm n m x y :=
+    let mn := Max.max n m in
+    let d := diff n m in
+    let op := make_op mn in
+     reduce_n (S mn) (ZnZ.mul_c
+       (castm (diff_r n m) (extend_tr x (snd d)))
+       (castm (diff_l n m) (extend_tr y (fst d)))).
+
+ Local Notation mul_folded :=
+  (iter_sym _
+    (fun n => let mul_c := ZnZ.mul_c in
+      fun x y => reduce (S n) (succ_t _ (mul_c x y)))
+    wn_mul
+    mulnm
+    (fun x => x)).
+
+ Definition mul : t -> t -> t :=
+  Eval lazy beta iota delta
+   [iter_sym dom_op dom_t reduce succ_t extend zeron
+    wn_mul DoubleMul.w_mul_add mk_t_w'] in
+  mul_folded.
+
+ Lemma mul_fold : mul = mul_folded.
+ Proof.
+  lazy beta iota delta
+   [iter_sym dom_op dom_t reduce succ_t extend zeron
+    wn_mul  DoubleMul.w_mul_add mk_t_w']. reflexivity.
+ Qed.
 
- (** * Power *)
+ Lemma spec_muln:
+   forall n (x: word _ (S n)) y,
+     [Nn (S n) (ZnZ.mul_c (Ops:=make_op n) x y)] = [Nn n x] * [Nn n y].
+ Proof.
+    intros n x y; unfold to_Z.
+    rewrite <- ZnZ.spec_mul_c.
+    rewrite make_op_S.
+    case ZnZ.mul_c; auto.
+ Qed.
 
- 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.
+ Lemma spec_mul_add_n1: forall n m x y z,
+  let (q,r) := DoubleMul.double_mul_add_n1 ZnZ.zero ZnZ.WW ZnZ.OW
+          (DoubleMul.w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c)
+          (S m) x y z in
+  ZnZ.to_Z q * (base (ZnZ.digits (nmake_op _ (dom_op n) (S m))))
+   + eval n (S m) r =
+  eval n (S m) x * ZnZ.to_Z y + ZnZ.to_Z z.
+ Proof.
+ intros n m x y z.
+ rewrite digits_nmake.
+ unfold eval. rewrite nmake_double.
+ apply DoubleMul.spec_double_mul_add_n1.
+ apply ZnZ.spec_0.
+ exact ZnZ.spec_WW.
+ exact ZnZ.spec_OW.
+ apply DoubleCyclic.spec_mul_add.
+ Qed.
 
- Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
+ Lemma spec_wn_mul : forall n m x y,
+   [wn_mul n m x y] = (eval n (S m) x) * ZnZ.to_Z y.
  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.
+  intros; unfold wn_mul.
+  generalize (spec_mul_add_n1 n m x y ZnZ.zero).
+  case DoubleMul.double_mul_add_n1; intros q r Hqr.
+  rewrite ZnZ.spec_0, Zplus_0_r in Hqr. rewrite <- Hqr.
+  generalize (ZnZ.spec_eq0 q); case ZnZ.eq0; intros HH.
+  rewrite HH; auto. simpl. apply spec_mk_t_w'.
+  clear.
+  rewrite spec_mk_t_w'.
+  set (m' := S m) in *.
+  unfold eval.
+  rewrite nmake_WW. f_equal. f_equal.
+  rewrite <- spec_mk_t.
+  symmetry. apply spec_extend.
  Qed.
 
- Definition power x (n:N) := match n with
-  | BinNat.N0 => one
-  | BinNat.Npos p => power_pos x p
- end.
+ Theorem spec_mul : forall x y, [mul x y] = [x] * [y].
+ Proof.
+  intros x y. rewrite mul_fold. apply spec_iter_sym; clear x y.
+   intros n x y. cbv zeta beta.
+    rewrite spec_reduce, spec_succ_t, <- ZnZ.spec_mul_c; auto.
+   apply spec_wn_mul.
+   intros n m x y; unfold mulnm. rewrite spec_reduce_n.
+    rewrite (spec_cast_l n m x), (spec_cast_r n m y).
+    apply spec_muln.
+   intros. rewrite Zmult_comm; auto.
+ Qed.
 
- Theorem spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
+ (** * Division by a smaller number *)
+
+ Definition wn_divn1 n :=
+  let op := dom_op n in
+  let zd := ZnZ.zdigits op in
+  let zero := @ZnZ.zero _ op in
+  let ww := @ZnZ.WW _ op in
+  let head0 := @ZnZ.head0 _ op in
+  let add_mul_div := @ZnZ.add_mul_div _ op in
+  let div21 := @ZnZ.div21 _ op in
+  let compare := @ZnZ.compare _ op in
+  let sub := @ZnZ.sub _ op in
+  let ddivn1 :=
+    DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in
+  fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v).
+
+ Let div_gtnm n m wx wy :=
+    let mn := Max.max n m in
+    let d := diff n m in
+    let op := make_op mn in
+    let (q, r):= ZnZ.div_gt
+         (castm (diff_r n m) (extend_tr wx (snd d)))
+         (castm (diff_l n m) (extend_tr wy (fst d))) in
+    (reduce_n mn q, reduce_n mn r).
+
+ Local Notation div_gt_folded :=
+   (iter _
+     (fun n => let div_gt := ZnZ.div_gt in
+       fun x y => let (u,v) := div_gt x y in (reduce n u, reduce n v))
+     (fun n =>
+       let div_gt := ZnZ.div_gt in
+       fun m x y =>
+         let y' := DoubleBase.get_low (zeron n) (S m) y in
+         let (u,v) := div_gt x y' in (reduce n u, reduce n v))
+      wn_divn1
+      div_gtnm).
+
+ Definition div_gt :=
+  Eval lazy beta iota delta
+   [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t] in
+  div_gt_folded.
+
+ Lemma div_gt_fold : div_gt = div_gt_folded.
  Proof.
- destruct n; simpl. apply (spec_1 w0_spec).
- apply spec_power_pos.
+  lazy beta iota delta [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t].
+  reflexivity.
  Qed.
 
+ Lemma spec_get_endn: forall n m x y,
+  eval n m x  <= [mk_t n y] ->
+   [mk_t n (DoubleBase.get_low (zeron n) m x)] = eval n m x.
+ Proof.
+  intros n m x y H.
+  unfold eval. rewrite nmake_double.
+  rewrite spec_mk_t in *.
+  apply DoubleBase.spec_get_low.
+  apply spec_zeron.
+  exact ZnZ.spec_to_Z.
+  apply Zle_lt_trans with (ZnZ.to_Z y); auto.
+    rewrite <- nmake_double; auto.
+  case (ZnZ.spec_to_Z y); auto.
+ Qed.
 
- (** * Div *)
+ Let spec_divn1 n :=
+   DoubleDivn1.spec_double_divn1
+    (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n)
+    ZnZ.WW ZnZ.head0
+    ZnZ.add_mul_div ZnZ.div21
+    ZnZ.compare ZnZ.sub ZnZ.to_Z
+    ZnZ.spec_to_Z
+    ZnZ.spec_zdigits
+    ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0
+    ZnZ.spec_add_mul_div ZnZ.spec_div21
+    ZnZ.spec_compare ZnZ.spec_sub.
+
+ Lemma spec_div_gt_aux : forall x y, [x] > [y] -> 0 < [y] ->
+   let (q,r) := div_gt x y in
+   [x] = [q] * [y] + [r] /\ 0 <= [r] < [y].
+ Proof.
+  intros x y. rewrite div_gt_fold. apply spec_iter; clear x y.
+   intros n x y H1 H2. simpl.
+    generalize (ZnZ.spec_div_gt x y H1 H2); case ZnZ.div_gt.
+    intros u v. rewrite 2 spec_reduce. auto.
+   intros n m x y H1 H2. cbv zeta beta.
+    generalize (ZnZ.spec_div_gt x
+                (DoubleBase.get_low (zeron n) (S m) y)).
+    case ZnZ.div_gt.
+    intros u v H3; repeat rewrite spec_reduce.
+    generalize (spec_get_endn n (S m) y x). rewrite !spec_mk_t. intros H4.
+    rewrite H4 in H3; auto with zarith.
+   intros n m x y H1 H2.
+    generalize (spec_divn1 n (S m) x y H2).
+    unfold wn_divn1; case DoubleDivn1.double_divn1.
+    intros u v H3.
+    rewrite spec_mk_t_w', spec_mk_t.
+    rewrite <- !nmake_double in H3; auto.
+   intros n m x y H1 H2; unfold div_gtnm.
+    generalize (ZnZ.spec_div_gt
+                   (castm (diff_r n m)
+                     (extend_tr x (snd (diff n m))))
+                   (castm (diff_l n m)
+                     (extend_tr y (fst (diff n m))))).
+    case ZnZ.div_gt.
+    intros xx yy HH.
+    repeat rewrite spec_reduce_n.
+    rewrite (spec_cast_l n m x), (spec_cast_r n m y).
+    unfold to_Z; apply HH.
+    rewrite (spec_cast_l n m x) in H1; auto.
+    rewrite (spec_cast_r n m y) in H1; auto.
+    rewrite (spec_cast_r n m y) in H2; auto.
+ Qed.
+
+ Theorem spec_div_gt: forall x y, [x] > [y] -> 0 < [y] ->
+  let (q,r) := div_gt x y in
+  [q] = [x] / [y] /\ [r] = [x] mod [y].
+ Proof.
+  intros x y H1 H2; generalize (spec_div_gt_aux x y H1 H2); case div_gt.
+  intros q r (H3, H4); split.
+  apply (Zdiv_unique [x] [y] [q] [r]); auto.
+  rewrite Zmult_comm; auto.
+  apply (Zmod_unique [x] [y] [q] [r]); auto.
+  rewrite Zmult_comm; auto.
+ Qed.
 
- Definition div_eucl x y :=
-  if eq_bool y zero then (zero,zero) else
+ (** * General Division *)
+
+ Definition div_eucl (x y : t) : t * t :=
+  if eqb y zero then (zero,zero) else
   match compare x y with
   | Eq => (one, zero)
   | Lt => (zero, x)
@@ -138,32 +599,27 @@ Module Make (Import W0:CyclicType) <: NType.
       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).
+ rewrite spec_eqb, spec_compare, spec_0.
+ case Z.eqb_spec.
+ intros ->. rewrite spec_0. destruct [x]; auto.
+ intros 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; auto with zarith.
- rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))
-                        (Z_mod_same [y] (Zlt_gt _ _ H));
+ case Zcompare_spec; intros Cmp;
+   rewrite ?spec_0, ?spec_1; intros; auto with zarith.
+ rewrite Cmp; 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);
+ assert (LeLt: 0 <= [x] < [y]) by (generalize (spec_pos x); auto).
+ generalize (Zdiv_small _ _ LeLt) (Zmod_small _ _ LeLt);
   unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.
- generalize (spec_div_gt _ _ H0 H); auto.
+ generalize (spec_div_gt _ _ (Zlt_gt _ _ Cmp) 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).
+ Definition div (x y : t) : t := fst (div_eucl x y).
 
  Theorem spec_div:
    forall x y, [div x y] = [x] / [y].
@@ -174,11 +630,90 @@ Module Make (Import W0:CyclicType) <: NType.
   injection H; auto.
  Qed.
 
+ (** * Modulo by a smaller number *)
+
+ Definition wn_modn1 n :=
+  let op := dom_op n in
+  let zd := ZnZ.zdigits op in
+  let zero := @ZnZ.zero _ op in
+  let head0 := @ZnZ.head0 _ op in
+  let add_mul_div := @ZnZ.add_mul_div _ op in
+  let div21 := @ZnZ.div21 _ op in
+  let compare := @ZnZ.compare _ op in
+  let sub := @ZnZ.sub _ op in
+  let dmodn1 :=
+    DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in
+  fun m x y => reduce n (dmodn1 (S m) x y).
+
+ Let mod_gtnm n m wx wy :=
+    let mn := Max.max n m in
+    let d := diff n m in
+    let op := make_op mn in
+    reduce_n mn (ZnZ.modulo_gt
+         (castm (diff_r n m) (extend_tr wx (snd d)))
+         (castm (diff_l n m) (extend_tr wy (fst d)))).
+
+ Local Notation mod_gt_folded :=
+   (iter _
+      (fun n => let modulo_gt := ZnZ.modulo_gt in
+        fun x y => reduce n (modulo_gt x y))
+      (fun n => let modulo_gt := ZnZ.modulo_gt in
+        fun m x y =>
+          reduce n (modulo_gt x (DoubleBase.get_low (zeron n) (S m) y)))
+      wn_modn1
+      mod_gtnm).
+
+ Definition mod_gt :=
+  Eval lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron] in
+  mod_gt_folded.
+
+ Lemma mod_gt_fold : mod_gt = mod_gt_folded.
+ Proof.
+  lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron].
+  reflexivity.
+ Qed.
+
+ Let spec_modn1 n :=
+   DoubleDivn1.spec_double_modn1
+    (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n)
+    ZnZ.WW ZnZ.head0
+    ZnZ.add_mul_div ZnZ.div21
+    ZnZ.compare ZnZ.sub ZnZ.to_Z
+    ZnZ.spec_to_Z
+    ZnZ.spec_zdigits
+    ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0
+    ZnZ.spec_add_mul_div ZnZ.spec_div21
+    ZnZ.spec_compare ZnZ.spec_sub.
+
+ Theorem spec_mod_gt:
+   forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y].
+ Proof.
+ intros x y. rewrite mod_gt_fold. apply spec_iter; clear x y.
+ intros n x y H1 H2. simpl. rewrite spec_reduce.
+   exact (ZnZ.spec_modulo_gt x y H1 H2).
+ intros n m x y H1 H2. cbv zeta beta. rewrite spec_reduce.
+  rewrite <- spec_mk_t in H1.
+  rewrite <- (spec_get_endn n (S m) y x); auto with zarith.
+  rewrite spec_mk_t.
+  apply ZnZ.spec_modulo_gt; auto.
+  rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H1; auto with zarith.
+  rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H2; auto with zarith.
+ intros n m x y H1 H2. unfold wn_modn1. rewrite spec_reduce.
+  unfold eval; rewrite nmake_double.
+  apply (spec_modn1 n); auto.
+ intros n m x y H1 H2; unfold mod_gtnm.
+  repeat rewrite spec_reduce_n.
+  rewrite (spec_cast_l n m x), (spec_cast_r n m y).
+  unfold to_Z; apply ZnZ.spec_modulo_gt.
+  rewrite (spec_cast_l n m x) in H1; auto.
+  rewrite (spec_cast_r n m y) in H1; auto.
+  rewrite (spec_cast_r n m y) in H2; auto.
+ Qed.
 
- (** * Modulo *)
+ (** * General Modulo *)
 
- Definition modulo x y :=
-  if eq_bool y zero then zero else
+ Definition modulo (x y : t) : t :=
+  if eqb y zero then zero else
   match compare x y with
   | Eq => zero
   | Lt => x
@@ -188,24 +723,129 @@ Module Make (Import W0:CyclicType) <: NType.
  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.
+ rewrite spec_eqb, spec_compare, spec_0.
+ case Z.eqb_spec.
+ intros ->; rewrite spec_0. 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.
+ case Zcompare_spec;
+   rewrite ?spec_0, ?spec_1; 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.
+ apply spec_mod_gt; auto with zarith.
+ Qed.
+
+ (** * Square *)
+
+ Local Notation squaren := (fun n =>
+   let square_c := ZnZ.square_c in
+   fun x => reduce (S n) (succ_t _ (square_c x))).
+
+ Definition square : t -> t := Eval red_t in iter_t squaren.
+
+ Lemma square_fold : square = iter_t squaren.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_square: forall x, [square x] = [x] * [x].
+ Proof.
+  intros x. rewrite square_fold. destr_t x as (n,x).
+  rewrite spec_succ_t. exact (ZnZ.spec_square_c x).
+ Qed.
+
+ (** * Square Root *)
+
+ Local Notation sqrtn := (fun n =>
+   let sqrt := ZnZ.sqrt in
+   fun x => reduce n (sqrt x)).
+
+ Definition sqrt : t -> t := Eval red_t in iter_t sqrtn.
+
+ Lemma sqrt_fold : sqrt = iter_t sqrtn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_sqrt_aux: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
+ Proof.
+  intros x. rewrite sqrt_fold. destr_t x as (n,x). exact (ZnZ.spec_sqrt x).
+ Qed.
+
+ Theorem spec_sqrt: forall x, [sqrt x] = Z.sqrt [x].
+ Proof.
+  intros x.
+  symmetry. apply Z.sqrt_unique.
+  rewrite <- ! Zpower_2. apply spec_sqrt_aux.
+ Qed.
+
+ (** * Power *)
+
+ Fixpoint pow_pos (x:t)(p:positive) : t :=
+  match p with
+  | xH => x
+  | xO p => square (pow_pos x p)
+  | xI p => mul (square (pow_pos x p)) x
+  end.
+
+ Theorem spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
+ Proof.
+ intros x n; generalize x; elim n; clear n x; simpl pow_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 pow_N (x:t)(n:N) : t := match n with
+  | BinNat.N0 => one
+  | BinNat.Npos p => pow_pos x p
+ end.
+
+ Theorem spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z_of_N n.
+ Proof.
+ destruct n; simpl. apply spec_1.
+ apply spec_pow_pos.
+ Qed.
+
+ Definition pow (x y:t) : t := pow_N x (to_N y).
+
+ Theorem spec_pow : forall x y, [pow x y] = [x] ^ [y].
+ Proof.
+ intros. unfold pow, to_N.
+ now rewrite spec_pow_N, Z2N.id by apply spec_pos.
+ Qed.
+
+
+ (** * digits
+
+     Number of digits in the representation of a numbers
+     (including head zero's).
+     NB: This function isn't a morphism for setoid [eq].
+ *)
+
+ Local Notation digitsn := (fun n =>
+   let digits := ZnZ.digits (dom_op n) in
+   fun _ => digits).
+
+ Definition digits : t -> positive := Eval red_t in iter_t digitsn.
+
+ Lemma digits_fold : digits = iter_t digitsn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x).
+ Proof.
+ intros x. rewrite digits_fold. destr_t x as (n,x). exact (ZnZ.spec_to_Z x).
+ Qed.
+
+ Lemma digits_level : forall x, digits x = ZnZ.digits (dom_op (level x)).
+ Proof.
+ intros x. rewrite digits_fold. unfold level. destr_t x as (n,x). reflexivity.
+ Qed.
 
  (** * Gcd *)
 
@@ -226,15 +866,12 @@ Module Make (Import W0:CyclicType) <: NType.
          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.
+ rewrite ! spec_compare, spec_0. case Zcompare_spec.
+  intros ->; 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 H5; case Zcompare_spec.
  intros H6; rewrite <- (Zmult_1_r [b]).
  rewrite (Z_div_mod_eq [a] [b]); auto with zarith.
  rewrite <- spec_mod_gt; auto with zarith.
@@ -273,7 +910,7 @@ Module Make (Import W0:CyclicType) <: NType.
  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 :=
+ Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) : t :=
   gcd_gt_body a b
     (fun a b =>
        match p with
@@ -310,12 +947,7 @@ Module Make (Import W0:CyclicType) <: NType.
          (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.
+    apply Zpower_le_monotone2; auto with zarith.
  intros n a b cont H H2 H3.
   simpl gcd_gt_aux.
   apply Zspec_gcd_gt_body with (n + 1); auto with zarith.
@@ -345,7 +977,7 @@ Module Make (Import W0:CyclicType) <: NType.
    intros; apply False_ind; auto with zarith.
  Qed.
 
- Definition gcd a b :=
+ Definition gcd (a b : t) : t :=
   match compare a b with
   | Eq => a
   | Lt => gcd_gt b a
@@ -357,7 +989,7 @@ Module Make (Import W0:CyclicType) <: NType.
  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.
+ unfold gcd. rewrite spec_compare. case Zcompare_spec.
  intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto.
    apply Zis_gcd_refl.
  intros; apply trans_equal with (Zgcd [b] [a]).
@@ -365,13 +997,91 @@ Module Make (Import W0:CyclicType) <: NType.
  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.
+ intros; apply spec_gcd_gt; auto with zarith.
+ Qed.
+
+ (** * Parity test *)
+
+ Definition even : t -> bool := Eval red_t in
+   iter_t (fun n x => ZnZ.is_even x).
+
+ Definition odd x := negb (even x).
+
+ Lemma even_fold : even = iter_t (fun n x => ZnZ.is_even x).
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_even_aux: forall x,
+   if even x then [x] mod 2 = 0 else [x] mod 2 = 1.
+ Proof.
+ intros x. rewrite even_fold. destr_t x as (n,x).
+ exact (ZnZ.spec_is_even x).
+ Qed.
+
+ Theorem spec_even: forall x, even x = Zeven_bool [x].
+ Proof.
+ intros x. assert (H := spec_even_aux x). symmetry.
+ rewrite (Z_div_mod_eq_full [x] 2); auto with zarith.
+ destruct (even x); rewrite H, ?Zplus_0_r.
+ rewrite Zeven_bool_iff. apply Zeven_2p.
+ apply not_true_is_false. rewrite Zeven_bool_iff.
+ apply Zodd_not_Zeven. apply Zodd_2p_plus_1.
  Qed.
 
+ Theorem spec_odd: forall x, odd x = Zodd_bool [x].
+ Proof.
+ intros x. unfold odd.
+ assert (H := spec_even_aux x). symmetry.
+ rewrite (Z_div_mod_eq_full [x] 2); auto with zarith.
+ destruct (even x); rewrite H, ?Zplus_0_r; simpl negb.
+ apply not_true_is_false. rewrite Zodd_bool_iff.
+ apply Zeven_not_Zodd. apply Zeven_2p.
+ apply Zodd_bool_iff. apply Zodd_2p_plus_1.
+ Qed.
 
  (** * Conversion *)
 
- Definition of_N x :=
+ Definition pheight p :=
+   Peano.pred (nat_of_P (get_height (ZnZ.digits (dom_op 0)) (plength p))).
+
+ Theorem pheight_correct: forall p,
+    Zpos p < 2 ^ (Zpos (ZnZ.digits (dom_op 0)) * 2 ^ (Z_of_nat (pheight p))).
+ Proof.
+ intros p; unfold pheight.
+ assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1).
+  intros x.
+  assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith.
+    rewrite <- inj_S.
+    rewrite <- (fun x => S_pred x 0); auto with zarith.
+    rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto.
+    apply lt_le_trans with 1%nat; auto with zarith.
+    exact (le_Pmult_nat x 1).
+  rewrite F1; clear F1.
+ assert (F2:= (get_height_correct (ZnZ.digits (dom_op 0)) (plength p))).
+ apply Zlt_le_trans with (Zpos (Psucc p)).
+   rewrite Zpos_succ_morphism; auto with zarith.
+  apply Zle_trans with (1 := plength_pred_correct (Psucc p)).
+ rewrite Ppred_succ.
+ apply Zpower_le_monotone2; auto with zarith.
+ Qed.
+
+ Definition of_pos (x:positive) : t  :=
+  let n := pheight x in
+  reduce n (snd (ZnZ.of_pos x)).
+
+ Theorem spec_of_pos: forall x,
+   [of_pos x] = Zpos x.
+ Proof.
+ intros x; unfold of_pos.
+ rewrite spec_reduce.
+ simpl.
+ apply ZnZ.of_pos_correct.
+ unfold base.
+ apply Zlt_le_trans with (1 := pheight_correct x).
+ apply Zpower_le_monotone2; auto with zarith.
+ rewrite (digits_dom_op (_ _)), Pshiftl_nat_Zpower. auto with zarith.
+ Qed.
+
+ Definition of_N (x:N) : t :=
   match x with
   | BinNat.N0 => zero
   | Npos p => of_pos p
@@ -381,51 +1091,437 @@ Module Make (Import W0:CyclicType) <: NType.
    [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.
+  simpl of_N. exact spec_0.
  intros p; exact (spec_of_pos p).
  Qed.
 
+ (** * [head0] and [tail0]
 
- (** * Shift *)
+     Number of zero at the beginning and at the end of
+     the representation of the number.
+     NB: these functions are not morphism for setoid [eq].
+ *)
 
- Definition shiftr n x :=
-   match compare n (Ndigits x) with
-   |  Lt => unsafe_shiftr n x
-   | _ => N0 w_0
-   end.
+ Local Notation head0n := (fun n =>
+   let head0 := ZnZ.head0 in
+   fun x => reduce n (head0 x)).
+
+ Definition head0 : t -> t := Eval red_t in iter_t head0n.
+
+ Lemma head0_fold : head0 = iter_t head0n.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_head00: forall x, [x] = 0 -> [head0 x] = Zpos (digits x).
+ Proof.
+ intros x. rewrite head0_fold, digits_fold. destr_t x as (n,x).
+ exact (ZnZ.spec_head00 x).
+ Qed.
+
+ Lemma pow2_pos_minus_1 : forall z, 0<z -> 2^(z-1) = 2^z / 2.
+ Proof.
+  intros. apply Zdiv_unique with 0; auto with zarith.
+  change 2 with (2^1) at 2.
+  rewrite <- Zpower_exp; auto with zarith.
+  rewrite Zplus_0_r. f_equal. auto with zarith.
+ Qed.
 
- 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
+ Theorem spec_head0: forall x, 0 < [x] ->
+   2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x).
+ Proof.
+ intros x. rewrite pow2_pos_minus_1 by (red; auto).
+ rewrite head0_fold, digits_fold. destr_t x as (n,x). exact (ZnZ.spec_head0 x).
+ Qed.
+
+ Local Notation tail0n := (fun n =>
+  let tail0 := ZnZ.tail0 in
+  fun x => reduce n (tail0 x)).
+
+ Definition tail0 : t -> t := Eval red_t in iter_t tail0n.
+
+ Lemma tail0_fold : tail0 = iter_t tail0n.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_tail00: forall x, [x] = 0 -> [tail0 x] = Zpos (digits x).
+ Proof.
+ intros x. rewrite tail0_fold, digits_fold. destr_t x as (n,x).
+ exact (ZnZ.spec_tail00 x).
+ Qed.
+
+ Theorem spec_tail0: forall x,
+   0 < [x] -> exists y, 0 <= y /\ [x] = (2 * y + 1) * 2 ^ [tail0 x].
+ Proof.
+ intros x. rewrite tail0_fold. destr_t x as (n,x). exact (ZnZ.spec_tail0 x).
+ Qed.
+
+ (** * [Ndigits]
+
+     Same as [digits] but encoded using large integers
+     NB: this function is not a morphism for setoid [eq].
+ *)
+
+ Local Notation Ndigitsn := (fun n =>
+  let d := reduce n (ZnZ.zdigits (dom_op n)) in
+  fun _ => d).
+
+ Definition Ndigits : t -> t := Eval red_t in iter_t Ndigitsn.
+
+ Lemma Ndigits_fold : Ndigits = iter_t Ndigitsn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x).
+ Proof.
+ intros x. rewrite Ndigits_fold, digits_fold. destr_t x as (n,x).
+ apply ZnZ.spec_zdigits.
+ Qed.
+
+ (** * Binary logarithm *)
+
+ Local Notation log2n := (fun n =>
+  let op := dom_op n in
+  let zdigits := ZnZ.zdigits op in
+  let head0 := ZnZ.head0 in
+  let sub_carry := ZnZ.sub_carry in
+  fun x => reduce n (sub_carry zdigits (head0 x))).
+
+ Definition log2 : t -> t := Eval red_t in
+   let log2 := iter_t log2n in
+   fun x => if eqb x zero then zero else log2 x.
+
+ Lemma log2_fold :
+   log2 = fun x => if eqb x zero then zero else iter_t log2n x.
+ Proof. red_t; reflexivity. Qed.
+
+ Lemma spec_log2_0 : forall x, [x] = 0 -> [log2 x] = 0.
+ Proof.
+ intros x H. rewrite log2_fold.
+ rewrite spec_eqb, H. rewrite spec_0. simpl. exact spec_0.
+ Qed.
+
+ Lemma head0_zdigits : forall n (x : dom_t n),
+  0 < ZnZ.to_Z x ->
+  ZnZ.to_Z (ZnZ.head0 x) < ZnZ.to_Z (ZnZ.zdigits (dom_op n)).
+ Proof.
+ intros n x H.
+ destruct (ZnZ.spec_head0 x H) as (_,H0).
+ intros.
+ assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)).
+ assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))).
+ unfold base in *.
+ rewrite ZnZ.spec_zdigits in H2 |- *.
+ set (h := ZnZ.to_Z (ZnZ.head0 x)) in *; clearbody h.
+ set (d := ZnZ.digits (dom_op n)) in *; clearbody d.
+ destruct (Z_lt_le_dec h (Zpos d)); auto. exfalso.
+ assert (1 * 2^Zpos d <= ZnZ.to_Z x * 2^h).
+  apply Zmult_le_compat; auto with zarith.
+  apply Zpower_le_monotone2; auto with zarith.
+ rewrite Zmult_comm in H0. auto with zarith.
+ Qed.
+
+ Lemma spec_log2_pos : forall x, [x]<>0 ->
+   2^[log2 x] <= [x] < 2^([log2 x]+1).
+ Proof.
+ intros x H. rewrite log2_fold.
+ rewrite spec_eqb. rewrite spec_0.
+ case Z.eqb_spec.
+ auto with zarith.
+ clear H.
+ destr_t x as (n,x). intros H.
+ rewrite ZnZ.spec_sub_carry.
+ assert (H0 := ZnZ.spec_to_Z x).
+ assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)).
+ assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))).
+ assert (H3 := head0_zdigits n x).
+ rewrite Zmod_small by auto with zarith.
+ rewrite (Z.mul_lt_mono_pos_l (2^(ZnZ.to_Z (ZnZ.head0 x))));
+  auto with zarith.
+ rewrite (Z.mul_le_mono_pos_l _ _ (2^(ZnZ.to_Z (ZnZ.head0 x))));
+  auto with zarith.
+ rewrite <- 2 Zpower_exp; auto with zarith.
+ rewrite Z.add_sub_assoc, Zplus_minus.
+ rewrite Z.sub_simpl_r, Zplus_minus.
+ rewrite ZnZ.spec_zdigits.
+ rewrite pow2_pos_minus_1 by (red; auto).
+ apply ZnZ.spec_head0; auto with zarith.
+ Qed.
+
+ Lemma spec_log2 : forall x, [log2 x] = Z.log2 [x].
+ Proof.
+  intros. destruct (Z_lt_ge_dec 0 [x]).
+  symmetry. apply Z.log2_unique. apply spec_pos.
+  apply spec_log2_pos. intro EQ; rewrite EQ in *; auto with zarith.
+  rewrite spec_log2_0. rewrite Z.log2_nonpos; auto with zarith.
+  generalize (spec_pos x); auto with zarith.
+ Qed.
+
+ Lemma log2_digits_head0 : forall x, 0 < [x] ->
+   [log2 x] = Zpos (digits x) - [head0 x] - 1.
+ Proof.
+ intros. rewrite log2_fold.
+ rewrite spec_eqb. rewrite spec_0.
+ case Z.eqb_spec.
+ auto with zarith.
+ intros _. revert H. rewrite digits_fold, head0_fold. destr_t x as (n,x).
+ rewrite ZnZ.spec_sub_carry.
+ intros.
+ generalize (head0_zdigits n x H).
+ generalize (ZnZ.spec_to_Z (ZnZ.head0 x)).
+ generalize (ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))).
+ rewrite ZnZ.spec_zdigits. intros. apply Zmod_small.
+ auto with zarith.
+ Qed.
+
+ (** * Right shift *)
+
+ Local Notation shiftrn := (fun n =>
+   let op := dom_op n in
+   let zdigits := ZnZ.zdigits op in
+   let sub_c := ZnZ.sub_c in
+   let add_mul_div := ZnZ.add_mul_div in
+   let zzero := ZnZ.zero in
+   fun x p => match sub_c zdigits p with
+   | C0 d => reduce n (add_mul_div d zzero x)
+   | C1 _ => zero
+   end).
+
+ Definition shiftr : t -> t -> t := Eval red_t in
+   same_level shiftrn.
+
+ Lemma shiftr_fold : shiftr = same_level shiftrn.
+ Proof. red_t; reflexivity. Qed.
+
+ Lemma div_pow2_bound :forall x y z,
+   0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z.
+ Proof.
+   intros x y z HH HH1 HH2.
+   split; auto with zarith.
+   apply Zle_lt_trans with (2 := HH2); auto with zarith.
+   apply Zdiv_le_upper_bound; auto with zarith.
+   pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith.
+   apply Zmult_le_compat_l; auto.
+   apply Zpower_le_monotone2; auto with zarith.
+   rewrite Zpower_0_r; ring.
+ Qed.
+
+ Theorem spec_shiftr_pow2 : forall x n,
+  [shiftr x n] = [x] / 2 ^ [n].
+ Proof.
+  intros x y. rewrite shiftr_fold. apply spec_same_level. clear x y.
+  intros n x p. simpl.
+  assert (Hx := ZnZ.spec_to_Z x).
+  assert (Hy := ZnZ.spec_to_Z p).
+  generalize (ZnZ.spec_sub_c (ZnZ.zdigits (dom_op n)) p).
+  case ZnZ.sub_c; intros d H; unfold interp_carry in *; simpl.
+  (** Subtraction without underflow : [ p <= digits ] *)
+  rewrite spec_reduce.
+  rewrite ZnZ.spec_zdigits in H.
+  rewrite ZnZ.spec_add_mul_div by auto with zarith.
+  rewrite ZnZ.spec_0, Zmult_0_l, Zplus_0_l.
+  rewrite Zmod_small.
+  f_equal. f_equal. auto with zarith.
+  split. auto with zarith.
+  apply div_pow2_bound; auto with zarith.
+  (** Subtraction with underflow : [ digits < p ] *)
+  rewrite ZnZ.spec_0. symmetry.
+  apply Zdiv_small.
+  split; auto with zarith.
+  apply Zlt_le_trans with (base (ZnZ.digits (dom_op n))); auto with zarith.
+  unfold base. apply Zpower_le_monotone2; auto with zarith.
+  rewrite ZnZ.spec_zdigits in H.
+  generalize (ZnZ.spec_to_Z d); auto with zarith.
+ Qed.
+
+ Lemma spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p].
+ Proof.
+  intros.
+  now rewrite spec_shiftr_pow2, Z.shiftr_div_pow2 by apply spec_pos.
+ Qed.
+
+ (** * Left shift *)
+
+ (** First an unsafe version, working correctly only if
+     the representation is large enough *)
+
+ Local Notation unsafe_shiftln := (fun n =>
+   let op := dom_op n in
+   let add_mul_div := ZnZ.add_mul_div in
+   let zero := ZnZ.zero in
+   fun x p => reduce n (add_mul_div p x zero)).
+
+ Definition unsafe_shiftl : t -> t -> t := Eval red_t in
+   same_level unsafe_shiftln.
+
+ Lemma unsafe_shiftl_fold : unsafe_shiftl = same_level unsafe_shiftln.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_unsafe_shiftl_aux : forall x p K,
+  0 <= K ->
+  [x] < 2^K ->
+  [p] + K <= Zpos (digits x) ->
+  [unsafe_shiftl x p] = [x] * 2 ^ [p].
+ Proof.
+ intros x p.
+ rewrite unsafe_shiftl_fold. rewrite digits_level.
+ apply spec_same_level_dep.
+ intros n m z z' r LE H K HK H1 H2. apply (H K); auto.
+  transitivity (Zpos (ZnZ.digits (dom_op n))); auto.
+  apply digits_dom_op_incr; auto.
+ clear x p.
+ intros n x p K HK Hx Hp. simpl. rewrite spec_reduce.
+ destruct (ZnZ.spec_to_Z x).
+ destruct (ZnZ.spec_to_Z p).
+ rewrite ZnZ.spec_add_mul_div by (omega with *).
+ rewrite ZnZ.spec_0, Zdiv_0_l, Zplus_0_r.
+ apply Zmod_small. unfold base.
+ split; auto with zarith.
+ rewrite Zmult_comm.
+ apply Zlt_le_trans with (2^(ZnZ.to_Z p + K)).
+ rewrite Zpower_exp; auto with zarith.
+ apply Zmult_lt_compat_l; auto with zarith.
+ apply Zpower_le_monotone2; auto with zarith.
+ Qed.
+
+ Theorem spec_unsafe_shiftl: forall x p,
+  [p] <= [head0 x] -> [unsafe_shiftl x p] = [x] * 2 ^ [p].
+ Proof.
+ intros.
+ destruct (Z_eq_dec [x] 0) as [EQ|NEQ].
+ (* [x] = 0 *)
+ apply spec_unsafe_shiftl_aux with 0; auto with zarith.
+ now rewrite EQ.
+ rewrite spec_head00 in *; auto with zarith.
+ (* [x] <> 0 *)
+ apply spec_unsafe_shiftl_aux with ([log2 x] + 1); auto with zarith.
+ generalize (spec_pos (log2 x)); auto with zarith.
+ destruct (spec_log2_pos x); auto with zarith.
+ rewrite log2_digits_head0; auto with zarith.
+ generalize (spec_pos x); auto with zarith.
+ Qed.
+
+ (** Then we define a function doubling the size of the representation
+     but without changing the value of the number. *)
+
+ Local Notation double_size_n := (fun n =>
+  let zero := ZnZ.zero in
+  fun x => mk_t_S n (WW zero x)).
+
+ Definition double_size : t -> t := Eval red_t in
+   iter_t double_size_n.
+
+ Lemma double_size_fold : double_size = iter_t double_size_n.
+ Proof. red_t; reflexivity. Qed.
+
+ Lemma double_size_level : forall x, level (double_size x) = S (level x).
+ Proof.
+ intros x. rewrite double_size_fold; unfold level at 2. destr_t x as (n,x).
+ apply mk_t_S_level.
+ Qed.
+
+ Theorem spec_double_size_digits:
+   forall x, Zpos (digits (double_size x)) = 2 * (Zpos (digits x)).
+ Proof.
+ intros x. rewrite ! digits_level, double_size_level.
+ rewrite 2 digits_dom_op, 2 Pshiftl_nat_Zpower,
+         inj_S, Zpower_Zsucc; auto with zarith.
+ ring.
+ Qed.
+
+ Theorem spec_double_size: forall x, [double_size x] = [x].
+ Proof.
+ intros x. rewrite double_size_fold. destr_t x as (n,x).
+ rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_0. auto with zarith.
+ Qed.
+
+ Theorem spec_double_size_head0:
+   forall x, 2 * [head0 x] <= [head0 (double_size x)].
+ Proof.
+ intros x.
+ assert (F1:= spec_pos (head0 x)).
+ assert (F2: 0 < Zpos (digits x)).
+   red; auto.
+ case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH.
+ generalize HH; rewrite <- (spec_double_size x); intros HH1.
+ case (spec_head0 x HH); intros _ HH2.
+ case (spec_head0 _ HH1).
+ rewrite (spec_double_size x); rewrite (spec_double_size_digits x).
+ intros HH3 _.
+ case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4.
+ absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto.
+ apply Zle_not_lt.
+ apply Zmult_le_compat_r; auto with zarith.
+ apply Zpower_le_monotone2; auto; auto with zarith.
+ assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)).
+   case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5.
+   apply Zmult_le_reg_r with (2 ^ 1); auto with zarith.
+   rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith.
+   assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp].
+   apply Zle_trans with (2 := Zlt_le_weak _ _ HH2).
+   apply Zmult_le_compat_l; auto with zarith.
+   rewrite Zpower_1_r; auto with zarith.
+   apply Zpower_le_monotone2; auto with zarith.
+   case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6.
+   absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith.
+   rewrite <- HH5; rewrite Zmult_1_r.
+   apply Zpower_le_monotone2; auto with zarith.
+ rewrite (Zmult_comm 2).
+ rewrite Zpower_mult; auto with zarith.
+ rewrite Zpower_2.
+ apply Zlt_le_trans with (2 := HH3).
+ rewrite <- Zmult_assoc.
+ replace (2 * Zpos (digits x) - 1) with
+   ((Zpos (digits x) - 1) + (Zpos (digits x))).
+ rewrite Zpower_exp; auto with zarith.
+ apply Zmult_lt_compat2; auto with zarith.
+ split; auto with zarith.
+ apply Zmult_lt_0_compat; auto with zarith.
+ rewrite Zpos_xO; ring.
+ apply Zlt_le_weak; auto.
+ repeat rewrite spec_head00; auto.
+ rewrite spec_double_size_digits.
+ rewrite Zpos_xO; auto with zarith.
+ rewrite spec_double_size; auto.
+ Qed.
+
+ Theorem spec_double_size_head0_pos:
+   forall x, 0 < [head0 (double_size x)].
+ Proof.
+ intros x.
+ assert (F: 0 < Zpos (digits x)).
+  red; auto.
+ case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0.
+ case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1.
+   apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith.
+ case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3.
+ generalize F3; rewrite <- (spec_double_size x); intros F4.
+ absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))).
+   apply Zle_not_lt.
+   apply Zpower_le_monotone2; auto with zarith.
+   rewrite Zpos_xO; auto with zarith.
+ case (spec_head0 x F3).
+ rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH.
+ apply Zle_lt_trans with (2 := HH).
+ case (spec_head0 _ F4).
+ rewrite (spec_double_size x); rewrite (spec_double_size_digits x).
+ rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto.
+ generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith.
+ Qed.
+
+ (** Finally we iterate [double_size] enough before [unsafe_shiftl]
+     in order to get a fully correct [shiftl]. *)
+
+ Definition shiftl_aux_body cont x n :=
+   match compare n (head0 x) with
+      Gt => cont (double_size x) n
+   |  _ => unsafe_shiftl x n
    end.
 
- Theorem spec_shiftl_aux_body: forall n p x cont,
+ Theorem spec_shiftl_aux_body: forall n x p 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].
+         [cont x n] = [x] * 2 ^ [n]) ->
+      [shiftl_aux_body cont x n] = [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.
+ intros n x p cont H1 H2; unfold shiftl_aux_body.
+ rewrite spec_compare; case Zcompare_spec; intros H.
   apply spec_unsafe_shiftl; auto with zarith.
   apply spec_unsafe_shiftl; auto with zarith.
  rewrite H2.
@@ -435,22 +1531,22 @@ Module Make (Import W0:CyclicType) <: NType.
  rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith.
  Qed.
 
- Fixpoint shiftl_aux p cont n x  {struct p} :=
+ Fixpoint shiftl_aux p cont x n :=
    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.
+       (fun x n => match p with
+        | xH => cont x n
+        | xO p => shiftl_aux p (shiftl_aux p cont) x n
+        | xI p => shiftl_aux p (shiftl_aux p cont) x n
+        end) x n.
 
- Theorem spec_shiftl_aux: forall p q n x cont,
+ Theorem spec_shiftl_aux: forall p q x n 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].
+         [cont x n] = [x] * 2 ^ [n]) ->
+      [shiftl_aux p cont x n] = [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.
+ intros p Hrec q x n 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.
@@ -465,7 +1561,7 @@ Module Make (Import W0:CyclicType) <: NType.
  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.
+ apply Zpower_le_monotone2; auto with zarith.
  intros x2 H4; apply Hrec with (p + q)%positive; auto.
  intros x3 H5; apply H2.
  rewrite (Zpos_xO p).
@@ -477,20 +1573,20 @@ Module Make (Import W0:CyclicType) <: NType.
  rewrite Zplus_comm; auto.
  Qed.
 
- Definition shiftl n x :=
+ Definition shiftl x n :=
   shiftl_aux_body
    (shiftl_aux_body
-    (shiftl_aux (digits n) unsafe_shiftl)) n x.
+    (shiftl_aux (digits n) unsafe_shiftl)) x n.
 
- Theorem spec_shiftl: forall n x,
-   [shiftl n x] = [x] * 2 ^ [n].
+ Theorem spec_shiftl_pow2 : forall x n,
+   [shiftl x n] = [x] * 2 ^ [n].
  Proof.
- intros n x; unfold shiftl, shiftl_aux_body.
- generalize (spec_compare_aux n (head0 x)); case compare; intros H.
+ intros x n; unfold shiftl, shiftl_aux_body.
+ rewrite spec_compare; case Zcompare_spec; 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.
+ rewrite spec_compare; case Zcompare_spec; intros H1.
   apply spec_unsafe_shiftl; auto with zarith.
   apply spec_unsafe_shiftl; auto with zarith.
  rewrite <- (spec_double_size (double_size x)).
@@ -504,21 +1600,67 @@ Module Make (Import W0:CyclicType) <: NType.
  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.
+ apply Zpower_le_monotone2; auto with zarith.
  Qed.
 
+ Lemma spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p].
+ Proof.
+  intros.
+  now rewrite spec_shiftl_pow2, Z.shiftl_mul_pow2 by apply spec_pos.
+ Qed.
 
- (** * Zero and One *)
+ (** Other bitwise operations *)
 
- Theorem spec_0: [zero] = 0.
+ Definition testbit x n := odd (shiftr x n).
+
+ Lemma spec_testbit: forall x p, testbit x p = Z.testbit [x] [p].
  Proof.
- exact (spec_0 w0_spec).
+  intros. unfold testbit. symmetry.
+  rewrite spec_odd, spec_shiftr. apply Z.testbit_odd.
  Qed.
 
- Theorem spec_1: [one] = 1.
+ Definition div2 x := shiftr x one.
+
+ Lemma spec_div2: forall x, [div2 x] = Z.div2 [x].
  Proof.
- exact (spec_1 w0_spec).
+  intros. unfold div2. symmetry.
+  rewrite spec_shiftr, spec_1. apply Z.div2_spec.
  Qed.
 
+ (** TODO : provide efficient versions instead of just converting
+   from/to N (see with Laurent) *)
+
+ Definition lor x y := of_N (N.lor (to_N x) (to_N y)).
+ Definition land x y := of_N (N.land (to_N x) (to_N y)).
+ Definition ldiff x y := of_N (N.ldiff (to_N x) (to_N y)).
+ Definition lxor x y := of_N (N.lxor (to_N x) (to_N y)).
+
+ Lemma spec_land: forall x y, [land x y] = Z.land [x] [y].
+ Proof.
+  intros x y. unfold land. rewrite spec_of_N. unfold to_N.
+  generalize (spec_pos x), (spec_pos y).
+  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+ Qed.
+
+ Lemma spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
+ Proof.
+  intros x y. unfold lor. rewrite spec_of_N. unfold to_N.
+  generalize (spec_pos x), (spec_pos y).
+  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+ Qed.
+
+ Lemma spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
+ Proof.
+  intros x y. unfold ldiff. rewrite spec_of_N. unfold to_N.
+  generalize (spec_pos x), (spec_pos y).
+  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+ Qed.
+
+ Lemma spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
+ Proof.
+  intros x y. unfold lxor. rewrite spec_of_N. unfold to_N.
+  generalize (spec_pos x), (spec_pos y).
+  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+ Qed.
 
 End Make.
diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml
index 67a62c40..59d440c3 100644
--- a/theories/Numbers/Natural/BigN/NMake_gen.ml
+++ b/theories/Numbers/Natural/BigN/NMake_gen.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,100 +8,88 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: NMake_gen.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(*S NMake_gen.ml : this file generates NMake_gen.v *)
 
-(*S NMake_gen.ml : this file generates NMake.v *)
 
-
-(*s The two parameters that control the generation: *)
+(*s The parameter that control the generation: *)
 
 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 ? *)
-
 
 (*s Some utilities *)
 
-let t = "t"
-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 =
-  if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")"
+let rec iter_str n s = if n = 0 then "" else (iter_str (n-1) s) ^ 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",
-   let's use instead a magical hack *)
+let rec iter_str_gen n f = if n < 0 then "" else (iter_str_gen (n-1) f) ^ (f n)
 
-(* Standard printer, with a final newline *)
-let pr s = Printf.printf (s^^"\n")
-(* Printing to /dev/null *)
-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
-(* Printer for admitted parts : prints iff gen_proof is false *)
-let pa = if not gen_proof then pr else pn
-(* Same as before, but without the final newline *)
-let pr0 = Printf.printf
-let pp0 = if gen_proof then pr0 else pn
+let rec iter_name i j base sep =
+  if i >= j then base^(string_of_int i)
+  else (iter_name i (j-1) base sep)^sep^" "^base^(string_of_int j)
 
+let pr s = Printf.printf (s^^"\n")
 
 (*s The actual printing *)
 
 let _ =
 
-  pr "(************************************************************************)";
-  pr "(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)";
-  pr "(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)";
-  pr "(*   \\VV/  **************************************************************)";
-  pr "(*    //   *      This file is distributed under the terms of the       *)";
-  pr "(*         *       GNU Lesser General Public License Version 2.1        *)";
-  pr "(************************************************************************)";
-  pr "(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)";
-  pr "(************************************************************************)";
-  pr "";
-  pr "(** * NMake *)";
-  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 "";
-  pr "Require Import BigNumPrelude ZArith CyclicAxioms";
-  pr " DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic";
-  pr " Wf_nat StreamMemo.";
-  pr "";
-  pr "Module Make (Import W0:CyclicType).";
-  pr "";
+pr
+"(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \\VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
+(************************************************************************)
 
-  pr " Definition w0 := W0.w.";
-  for i = 1 to size do
-    pr " Definition w%i := zn2z w%i." i (i-1)
-  done;
-  pr "";
+(** * NMake_gen *)
 
-  pr " Definition w0_op := W0.w_op.";
-  for i = 1 to 3 do
-    pr " Definition w%i_op := mk_zn2z_op w%i_op." i (i-1)
-  done;
-  for i = 4 to size + 3 do
-    pr " Definition w%i_op := mk_zn2z_op_karatsuba w%i_op." i (i-1)
-  done;
-  pr "";
+(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)
+
+(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)
+
+Require Import BigNumPrelude ZArith Ndigits CyclicAxioms
+ DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic
+ Wf_nat StreamMemo.
+
+Module Make (W0:CyclicType) <: NAbstract.
+
+ (** * The word types *)
+";
+
+pr " Local Notation w0 := W0.t.";
+for i = 1 to size do
+  pr " Definition w%i := zn2z w%i." i (i-1)
+done;
+pr "";
+
+pr " (** * The operation type classes for the word types *)
+";
+
+pr " Local Notation w0_op := W0.ops.";
+for i = 1 to min 3 size do
+  pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops w%i_op." i i (i-1)
+done;
+for i = 4 to size do
+  pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops_karatsuba w%i_op." i i (i-1)
+done;
+for i = size+1 to size+3 do
+  pr " Instance w%i_op : ZnZ.Ops (word w%i %i) := mk_zn2z_ops_karatsuba w%i_op." i size (i-size) (i-1)
+done;
+pr "";
 
   pr " Section Make_op.";
-  pr "  Variable mk : forall w', znz_op w' -> znz_op (zn2z w').";
+  pr "  Variable mk : forall w', ZnZ.Ops w' -> ZnZ.Ops (zn2z w').";
   pr "";
-  pr "  Fixpoint make_op_aux (n:nat) : znz_op (word w%i (S n)):=" size;
-  pr "   match n return znz_op (word w%i (S n)) with" size;
+  pr "  Fixpoint make_op_aux (n:nat) : ZnZ.Ops (word w%i (S n)):=" size;
+  pr "   match n return ZnZ.Ops (word w%i (S n)) with" size;
   pr "   | O => w%i_op" (size+1);
   pr "   | S n1 =>";
-  pr "     match n1 return znz_op (word w%i (S (S n1))) with" size;
+  pr "     match n1 return ZnZ.Ops (word w%i (S (S n1))) with" size;
   pr "     | O => w%i_op" (size+2);
   pr "     | S n2 =>";
-  pr "       match n2 return znz_op (word w%i (S (S (S n2)))) with" size;
+  pr "       match n2 return ZnZ.Ops (word w%i (S (S (S n2)))) with" size;
   pr "       | O => w%i_op" (size+3);
   pr "       | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))";
   pr "       end";
@@ -110,2565 +98,912 @@ let _ =
   pr "";
   pr " End Make_op.";
   pr "";
-  pr " Definition omake_op := make_op_aux mk_zn2z_op_karatsuba.";
+  pr " Definition omake_op := make_op_aux mk_zn2z_ops_karatsuba.";
   pr "";
   pr "";
   pr " Definition make_op_list := dmemo_list _ omake_op.";
   pr "";
-  pr " Definition make_op n := dmemo_get _ omake_op n make_op_list.";
-  pr "";
-  pr " Lemma make_op_omake: forall n, make_op n = omake_op n.";
-  pr " intros n; unfold make_op, make_op_list.";
-  pr " refine (dmemo_get_correct _ _ _).";
-  pr " Qed.";
+  pr " Instance make_op n : ZnZ.Ops (word w%i (S n))" size;
+  pr "  := dmemo_get _ omake_op n make_op_list.";
   pr "";
 
-  pr " Inductive %s_ :=" t;
-  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;
-  pr "";
-  pr " Definition %s := %s_." t t;
-  pr "";
-  pr " Definition w_0 := w0_op.(znz_0).";
-  pr "";
+pr " Ltac unfold_ops := unfold omake_op, make_op_aux, w%i_op, w%i_op." (size+3) (size+2);
 
-  for i = 0 to size do
-    pr " Definition one%i := w%i_op.(znz_1)." i i
-  done;
-  pr "";
+pr
+"
+ Lemma make_op_omake: forall n, make_op n = omake_op n.
+ Proof.
+ intros n; unfold make_op, make_op_list.
+ refine (dmemo_get_correct _ _ _).
+ Qed.
 
+ Theorem make_op_S: forall n,
+   make_op (S n) = mk_zn2z_ops_karatsuba (make_op n).
+ Proof.
+ intros n. do 2 rewrite make_op_omake.
+ revert n. fix IHn 1.
+ do 3 (destruct n; [unfold_ops; reflexivity|]).
+ simpl mk_zn2z_ops_karatsuba. simpl word in *.
+ rewrite <- (IHn n). auto.
+ Qed.
 
-  pr " Definition zero := %s0 w_0." c;
-  pr " Definition one := %s0 one0." c;
-  pr "";
+ (** * The main type [t], isomorphic with [exists n, word w0 n] *)
+";
 
-  pr " Definition to_Z x :=";
-  pr "  match x with";
+  pr " Inductive t' :=";
   for i = 0 to size do
-    pr "  | %s%i wx => w%i_op.(znz_to_Z) wx" c i i
+    pr "  | N%i : w%i -> t'" i i
   done;
-  pr "  | %sn n wx => (make_op n).(znz_to_Z) wx" c;
-  pr "  end.";
+  pr "  | Nn : forall n, word w%i (S n) -> t'." size;
   pr "";
-
-  pr " Open Scope Z_scope.";
-  pr " Notation \"[ x ]\" := (to_Z x).";
-  pr "";
-
-  pr " Definition to_N x := Zabs_N (to_Z x).";
+  pr " Definition t := t'.";
   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 "       znz_op (word ww n) :=";
-  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 "  end.";
-  pp "";
-  pp " (* Simplification by rewriting for nmake_op *)";
-  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.";
-  pp "";
-
-
-  pr " (* Eval and extend functions for each level *)";
-  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
-      pr " Let extend%i := DoubleBase.extend  (WW w_0)." i
-    else
-      pr " Let extend%i := DoubleBase.extend  (WW (W0: w%i))." i i;
-  done;
+  pr " Bind Scope abstract_scope with t t'.";
   pr "";
 
-
-  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.";
-  pp " intros n Hrec ww ww_op; simpl DoubleBase.double_digits.";
-  pp " rewrite <- Hrec; auto.";
-  pp " Qed.";
-  pp "";
-  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.";
-  pp " intros n; elim n; auto; clear n.";
-  pp " intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z.";
-  pp " rewrite <- Hrec; auto.";
-  pp " unfold DoubleBase.double_wB; rewrite <- digits_doubled; auto.";
-  pp " Qed.";
-  pp "";
-
-
-  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.";
-  pp " Qed.";
-  pp "";
-
-
-  pp " Theorem znz_nmake_op: forall ww ww_op n xh xl,";
-  pp "  znz_to_Z (nmake_op ww ww_op (S n)) (WW xh xl) =";
-  pp "   znz_to_Z (nmake_op ww ww_op n) xh *";
-  pp "    base (znz_digits (nmake_op ww ww_op n)) +";
-  pp "   znz_to_Z (nmake_op ww ww_op n) xl.";
-  pp " Proof.";
-  pp " auto.";
-  pp " Qed.";
-  pp "";
-
-  pp " Theorem make_op_S: forall n,";
-  pp "   make_op (S n) = mk_zn2z_op_karatsuba (make_op n).";
-  pp " intro n.";
-  pp " do 2 rewrite make_op_omake.";
-  pp " pattern n; apply lt_wf_ind; clear n.";
-  pp " intros n; case n; clear n.";
-  pp "   intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal." (size + 2);
-  pp " intros n; case n; clear n.";
-  pp "   intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal." (size + 3);
-  pp " intros n; case n; clear n.";
-  pp "   intros _; unfold omake_op, make_op_aux, w%i_op, w%i_op; apply refl_equal." (size + 3) (size + 2);
-  pp " intros n Hrec.";
-  pp "   change (omake_op (S (S (S (S n))))) with";
-  pp "          (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op (S n))))).";
-  pp "   change (omake_op (S (S (S n)))) with";
-  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 "";
-
-
-  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 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 "";
-  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 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 "";
-
-  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)
-  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)
-  done;
-  pp "";
-
-  pp " Let wn_spec: forall n, znz_spec (make_op n).";
-  pp "  intros n; elim n; clear n.";
-  pp "    exact w%i_spec." (size + 1);
-  pp "  intros n Hrec; rewrite make_op_S.";
-  pp "  exact (mk_znz2_karatsuba_spec Hrec).";
-  pp " Qed.";
-  pp "";
-
-  for i = 0 to size do
-    pr " Definition w%i_eq0 := w%i_op.(znz_eq0)." i i;
-    pr " Let spec_w%i_eq0: forall x, if w%i_eq0 x then [%s%i x] = 0 else True." i i c i;
-    pa " Admitted.";
-    pp " Proof.";
-    pp " intros x; unfold w%i_eq0, to_Z; generalize (spec_eq0 w%i_spec x);" i i;
-    pp "    case znz_eq0; auto.";
-    pp " Qed.";
-    pr "";
-  done;
+  pr " (** * A generic toolbox for building and deconstructing [t] *)";
   pr "";
 
-
-  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;
-    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 " Proof.";
-    pp "  intros n; exact (nmake_double n w%i w%i_op)." i i;
-    pp " Qed.";
-    pp "";
-  done;
-
-  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 " Proof.";
-      if j == 0 then
-        if i == 0 then
-          pp " auto."
-        else
-          begin
-            pp " apply trans_equal with (xO (znz_digits w%i_op))." (i + j -1);
-            pp "  auto.";
-            pp "  unfold nmake_op; auto.";
-          end
-      else
-        begin
-          pp " apply trans_equal with (xO (znz_digits w%i_op))." (i + j -1);
-          pp "  auto.";
-          pp " rewrite digits_nmake.";
-          pp " rewrite digits_w%in%i." i (j - 1);
-          pp " auto.";
-        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 " Proof.";
-      if j == 0 then
-        pp " intros x; rewrite spec_double_eval%in; unfold DoubleBase.double_to_Z, to_Z; auto." i
-      else
-        begin
-          pp " intros x; case x.";
-          pp "   auto.";
-          pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (i + j);
-          pp " rewrite digits_w%in%i." i (j - 1);
-          pp " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH." i (j - 1);
-          pp " unfold eval%in, nmake_op%i." i i;
-          pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (j - 1);
-        end;
-      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;
-          if j == 0 then
-            begin
-              pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." i (i + j);
-              pp " unfold to_Z; rewrite znz_to_Z_%i." (i + j + 1);
-              pp " rewrite (spec_0 w%i_spec); auto." (i + j);
-            end
-          else
-            begin
-              pp " intros x; change (extend%i %i x) with (WW (znz_0 w%i_op) (extend%i %i x))." i j (i + j) i (j - 1);
-              pp " unfold to_Z; rewrite znz_to_Z_%i." (i + j + 1);
-              pp " rewrite (spec_0 w%i_spec)." (i + j);
-              pp " generalize (spec_extend%in%i x); unfold to_Z." i (i + j);
-              pp " intros HH; rewrite <- HH; auto.";
-            end;
-          pp " Qed.";
-          pp "";
-        end;
-    done;
-
-    pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i (size - i + 1) (size + 1) i (size - i + 1);
-    pp " Proof.";
-    pp " apply trans_equal with (xO (znz_digits w%i_op))." size;
-    pp "  auto.";
-    pp " rewrite digits_nmake.";
-    pp " rewrite digits_w%in%i." i (size - i);
-    pp " auto.";
-    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 " Proof.";
-    pp " intros x; case x.";
-    pp "   auto.";
-    pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 1);
-    pp " rewrite digits_w%in%i." i (size - i);
-    pp " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH." i (size - i);
-    pp " unfold eval%in, nmake_op%i." i i;
-    pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (size - i);
-    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 " intros x; case x.";
-    pp "   auto.";
-    pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 2);
-    pp " rewrite digits_w%in%i." i (size + 1 - i);
-    pp " generalize (spec_eval%in%i); unfold to_Z; change (make_op 0) with (w%i_op); intros HH; repeat rewrite HH." i (size + 1 - i) (size + 1);
-    pp " unfold eval%in, nmake_op%i." i i;
-    pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (size + 1 - i);
-    pp " Qed.";
-    pp "";
-  done;
-
-  pp " Let digits_w%in: forall n," size;
-  pp "   znz_digits (make_op n) = znz_digits (nmake_op _ w%i_op (S n))." size;
-  pp " intros n; elim n; clear n.";
-  pp "  change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size;
-  pp "  rewrite nmake_op_S; apply sym_equal; auto.";
-  pp "  intros  n Hrec.";
-  pp "  replace (znz_digits (make_op (S n))) with (xO (znz_digits (make_op n))).";
-  pp "  rewrite Hrec.";
-  pp "  rewrite nmake_op_S; apply sym_equal; auto.";
-  pp "  rewrite make_op_S; apply sym_equal; auto.";
-  pp " Qed.";
-  pp "";
-
-  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.";
-  pp "  unfold to_Z, eval%in, nmake_op%i." size size;
-  pp "    rewrite make_op_S; rewrite nmake_op_S; auto.";
-  pp " intros xh xl.";
-  pp "  unfold to_Z in Hrec |- *.";
-  pp "  rewrite znz_to_Z_n.";
-  pp "  rewrite digits_w%in." size;
-  pp "  repeat rewrite Hrec.";
-  pp "  unfold eval%in, nmake_op%i." size size;
-  pp "  apply sym_equal; rewrite nmake_op_S; auto.";
-  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 " 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.";
-  pp "   change (make_op 0) with w%i_op." (size + 1);
-  pp "   rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto." (size + 1) size;
-  pp " intros n Hrec x.";
-  pp "   change (extend%i (S n) x) with (WW W0 (extend%i n x))." size size;
-  pp "   unfold to_Z in Hrec |- *; rewrite znz_to_Z_n; auto.";
-  pp "   rewrite <- Hrec.";
-  pp "  replace (znz_to_Z (make_op n) W0) with 0; auto.";
-  pp "  case n; auto; intros; rewrite make_op_S; auto.";
-  pp " Qed.";
-  pp "";
-
-  pr " Theorem spec_pos: forall x, 0 <= [x].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; clear x.";
-  for i = 0 to size do
-    pp " intros x; case (spec_to_Z w%i_spec x); auto." i;
-  done;
-  pp " intros n x; case (spec_to_Z (wn_spec n) x); auto.";
-  pp " Qed.";
+  pr " Local Notation SizePlus n := %sn%s."
+    (iter_str size "(S ") (iter_str size ")");
+  pr " Local Notation Size := (SizePlus O).";
   pr "";
 
-  pp " Let spec_extendn_0: forall n wx, [%sn n (extend n _ wx)] = [%sn 0 wx]." c c;
-  pp " intros n; elim n; auto.";
-  pp " intros n1 Hrec wx; simpl extend; rewrite <- Hrec; auto.";
-  pp " unfold to_Z.";
-  pp " case n1; auto; intros n2; repeat rewrite make_op_S; auto.";
-  pp " Qed.";
-  pp "";
-  pp " Let spec_extendn0_0: forall n wx, [%sn (S n) (WW W0 wx)] = [%sn n wx]." c c;
-  pp " Proof.";
-  pp " intros n x; unfold to_Z.";
-  pp " rewrite znz_to_Z_n.";
-  pp " rewrite <- (Zplus_0_l (znz_to_Z (make_op n) x)).";
-  pp " apply (f_equal2 Zplus); auto.";
-  pp " case n; auto.";
-  pp " intros n1; rewrite make_op_S; auto.";
-  pp " Qed.";
-  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;
-  pp " Proof.";
-  pp " induction m; auto.";
-  pp " intros n x; simpl extend_tr.";
-  pp " simpl plus; rewrite spec_extendn0_0; auto.";
-  pp " Qed.";
-  pp "";
-  pp " Let spec_cast_l: forall n m x1,";
-  pp " [%sn (Max.max n m)" c;
-  pp " (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))] =";
-  pp " [%sn n x1]." c;
-  pp " Proof.";
-  pp " intros n m x1; case (diff_r n m); simpl castm.";
-  pp " rewrite spec_extend_tr; auto.";
-  pp " Qed.";
-  pp "";
-  pp " Let spec_cast_r: forall n m x1,";
-  pp " [%sn (Max.max n m)" c;
-  pp "  (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))] =";
-  pp " [%sn m x1]." c;
-  pp " Proof.";
-  pp " intros n m x1; case (diff_l n m); simpl castm.";
-  pp " rewrite spec_extend_tr; auto.";
-  pp " Qed.";
-  pp "";
-
-
-  pr " Section LevelAndIter.";
-  pr "";
-  pr "  Variable res: Type.";
-  pr "  Variable xxx: res.";
-  pr "  Variable P: Z -> Z -> res -> Prop.";
-  pr "  (* Abstraction function for each level *)";
-  for i = 0 to size do
-    pr "  Variable f%i: w%i -> w%i -> res." i i i;
-    pr "  Variable f%in: forall n, w%i -> word w%i (S n) -> res." i i i;
-    pr "  Variable fn%i: forall n, word w%i (S n) -> w%i -> res." i i i;
-    pp "  Variable Pf%i: forall x y, P [%s%i x] [%s%i y] (f%i x y)." i c i c i i;
-    if i == size then
-      begin
-        pp "  Variable Pf%in: forall n x y, P [%s%i x] (eval%in (S n) y) (f%in n x y)." i c i i i;
-        pp "  Variable Pfn%i: forall n x y, P (eval%in (S n) x) [%s%i y] (fn%i n x y)." i i c i i;
-      end
-    else
-      begin
-        pp "  Variable Pf%in: forall n x y, Z_of_nat n <= %i -> P [%s%i x] (eval%in (S n) y) (f%in n x y)." i (size - i) c i i i;
-        pp "  Variable Pfn%i: forall n x y, Z_of_nat n <= %i -> P (eval%in (S n) x) [%s%i y] (fn%i n x y)." i (size - i) i c i i;
-      end;
-    pr "";
-  done;
-  pr "  Variable fnn: forall n, word w%i (S n) -> word w%i (S n) -> res." size size;
-  pp "  Variable Pfnn: forall n x y, P [%sn n x] [%sn n y] (fnn n x y)." c c;
-  pr "  Variable fnm: forall n m, word w%i (S n) -> word w%i (S m) -> res." size size;
-  pp "  Variable Pfnm: forall n m x y, P [%sn n x] [%sn m y] (fnm n m x y)." c c;
-  pr "";
-  pr "  (* Special zero functions *)";
-  pr "  Variable f0t:  t_ -> res.";
-  pp "  Variable Pf0t: forall x, P 0 [x] (f0t x).";
-  pr "  Variable ft0:  t_ -> res.";
-  pp "  Variable Pft0: forall x, P [x] 0 (ft0 x).";
+  pr " Tactic Notation \"do_size\" tactic(t) := do %i t." (size+1);
   pr "";
 
-
-  pr "  (* We level the two arguments before applying *)";
-  pr "  (* the functions at each leval                *)";
-  pr "  Definition same_level (x y: t_): res :=";
-  pr0 "    Eval lazy zeta beta iota delta [";
-  for i = 0 to size do
-    pr0 "extend%i " i;
-  done;
-  pr "";
-  pr "                                         DoubleBase.extend DoubleBase.extend_aux";
-  pr "                                         ] in";
-  pr "  match x, y with";
+  pr " Definition dom_t n := match n with";
   for i = 0 to size do
-    for j = 0 to i - 1 do
-      pr "  | %s%i wx, %s%i wy => f%i wx (extend%i %i wy)" c i c j i j (i - j -1);
-    done;
-    pr "  | %s%i wx, %s%i wy => f%i wx wy" c i c i i;
-    for j = i + 1 to size do
-      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 (extend%i %i wx)) wy" c i c size i (size - i - 1);
+    pr "  | %i => w%i" i i;
   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 (extend%i %i wy))" c c i size i (size - i - 1);
-  done;
-  pr "  | %sn n wx, Nn m wy =>" c;
-  pr "    let mn := Max.max n m in";
-  pr "    let d := diff n m in";
-  pr "     fnn mn";
-  pr "       (castm (diff_r n m) (extend_tr wx (snd d)))";
-  pr "       (castm (diff_l n m) (extend_tr wy (fst d)))";
-  pr "  end.";
+  pr "  | %sn => word w%i n" (if size=0 then "" else "SizePlus ") size;
+  pr " end.";
   pr "";
 
-  pp "  Lemma spec_same_level: forall x y, P [x] [y] (same_level x y).";
-  pp "  Proof.";
-  pp "  intros x; case x; clear x; unfold 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; rewrite spec_extend%in%i; apply Pf%i." j i i;
-    done;
-    pp "     intros y; apply Pf%i." i;
-    for j = i + 1 to size do
-      pp "     intros y; rewrite spec_extend%in%i; apply Pf%i." i j j;
-    done;
-    if i == size then
-      pp "     intros m y; rewrite (spec_extend%in m); apply Pfnn." size
-    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
-      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 "          rewrite <- (spec_cast_r n m y); apply Pfnn.";
-  pp "  Qed.";
-  pp "";
-
-  pr "  (* We level the two arguments before applying      *)";
-  pr "  (* the functions at each level (special zero case) *)";
-  pr "  Definition same_level0 (x y: t_): res :=";
-  pr0 "    Eval lazy zeta beta iota delta [";
-  for i = 0 to size do
-    pr0 "extend%i " i;
-  done;
-  pr "";
-  pr "                                         DoubleBase.extend DoubleBase.extend_aux";
-  pr "                                         ] in";
-  pr "  match x with";
-  for i = 0 to size do
-    pr "  | %s%i wx =>" c i;
-    if i == 0 then
-      pr "    if w0_eq0 wx then f0t y else";
-    pr "    match y with";
-    for j = 0 to i - 1 do
-      pr "    | %s%i wy =>" c j;
-      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;
-    pr "    | %s%i wy => f%i wx wy" c i i;
-    for j = i + 1 to size do
-      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 (extend%i %i wx)) wy" c size i (size - i - 1);
-    pr"    end";
-  done;
-  pr "  |  %sn n wx =>" c;
-  pr "     match y with";
-  for i = 0 to size do
-    pr "     | %s%i wy =>" c i;
-    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 (extend%i %i wy))" size i (size - i - 1);
-  done;
-  pr "        | %sn m wy =>" c;
-  pr "            let mn := Max.max n m in";
-  pr "            let d := diff n m in";
-  pr "              fnn mn";
-  pr "              (castm (diff_r n m) (extend_tr wx (snd d)))";
-  pr "              (castm (diff_l n m) (extend_tr wy (fst d)))";
-  pr "    end";
-  pr "  end.";
-  pr "";
+pr
+" Instance dom_op n : ZnZ.Ops (dom_t n) | 10.
+ Proof.
+  do_size (destruct n; [simpl;auto with *|]).
+  unfold dom_t. auto with *.
+ Defined.
+";
 
-  pp "  Lemma spec_same_level0: forall x y, P [x] [y] (same_level0 x y).";
-  pp "  Proof.";
-  pp "  intros x; case x; clear x; unfold same_level0.";
-  for i = 0 to size do
-    pp "    intros x.";
-    if i == 0 then
-      begin
-        pp "    generalize (spec_w0_eq0 x); case w0_eq0; intros H.";
-        pp "      intros y; rewrite H; apply Pf0t.";
-        pp "    clear H.";
-      end;
-    pp "    intros y; case y; clear y.";
-    for j = 0 to i - 1 do
-      pp "     intros y.";
-      if j == 0 then
-        begin
-          pp "     generalize (spec_w0_eq0 y); case w0_eq0; intros H.";
-          pp "       rewrite H; apply Pft0.";
-          pp "     clear H.";
-        end;
-      pp "     rewrite spec_extend%in%i; apply Pf%i." j i i;
-    done;
-    pp "     intros y; apply Pf%i." i;
-    for j = i + 1 to size do
-      pp "     intros y; rewrite spec_extend%in%i; apply Pf%i." i j j;
-    done;
-    if i == size then
-      pp "     intros m y; rewrite (spec_extend%in m); apply Pfnn." size
-    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.";
+  pr " Definition iter_t {A:Type}(f : forall n, dom_t n -> A) : t -> A :=";
   for i = 0 to size do
-    pp "    intros y.";
-    if i = 0 then
-      begin
-        pp "     generalize (spec_w0_eq0 y); case w0_eq0; intros H.";
-        pp "       rewrite H; apply Pft0.";
-        pp "     clear H.";
-      end;
-    if i == size then
-      pp "    rewrite (spec_extend%in n); apply Pfnn." size
-    else
-      pp "    rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size;
+   pr "  let f%i := f %i in" i i;
   done;
-  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 :=";
-  pr0 "    Eval lazy zeta beta iota delta [";
+  pr "  let fn n := f (SizePlus (S n)) in";
+  pr "  fun x => match x with";
   for i = 0 to size do
-    pr0 "extend%i " i;
+    pr "   | N%i wx => f%i wx" i i;
   done;
-  pr "";
-  pr "                                         DoubleBase.extend DoubleBase.extend_aux";
-  pr "                                         ] in";
-  pr "  match x, y with";
-  for i = 0 to size do
-    for j = 0 to i - 1 do
-      pr "  | %s%i wx, %s%i wy => fn%i %i wx wy" c i c j j (i - j - 1);
-    done;
-    pr "  | %s%i wx, %s%i wy => f%i wx wy" c i c i i;
-    for j = i + 1 to size do
-      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 (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 (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;
+  pr "   | Nn n wx => fn n wx";
   pr "  end.";
   pr "";
 
-  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.";
-  for i = 0 to size do
-    pp "    intros x y; case y; clear y.";
-    for j = 0 to i - 1 do
-      pp "     intros y; rewrite spec_eval%in%i;  apply (Pfn%i %i); zg_tac." j (i - j) j (i - j - 1);
-    done;
-    pp "     intros y; apply Pf%i." i;
-    for j = i + 1 to size do
-      pp "     intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac." i (j - i) i (j - i - 1);
-    done;
-    if i == size then
-      pp "     intros m y; rewrite spec_eval%in; apply Pf%in." size size
-    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
-      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.";
-  pp "  Qed.";
-  pp "";
-
-
-  pr "  (* We iter the smaller argument with the bigger  (zero case) *)";
-  pr "  Definition iter0 (x y: t_): res :=";
-  pr0 "    Eval lazy zeta beta iota delta [";
-  for i = 0 to size do
-    pr0 "extend%i " i;
-  done;
-  pr "";
-  pr "                                         DoubleBase.extend DoubleBase.extend_aux";
-  pr "                                         ] in";
-  pr "  match x with";
-  for i = 0 to size do
-    pr "  | %s%i wx =>" c i;
-    if i == 0 then
-      pr "    if w0_eq0 wx then f0t y else";
-    pr "    match y with";
-    for j = 0 to i - 1 do
-      pr "    | %s%i wy =>" c j;
-      if j == 0 then
-        pr "       if w0_eq0 wy then ft0 x else";
-      pr "       fn%i %i wx wy" j (i - j - 1);
-    done;
-    pr "    | %s%i wy => f%i wx wy" c i i;
-    for j = i + 1 to size do
-      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 (extend%i %i wx) wy" c size i (size - i - 1);
-    pr "    end";
-  done;
-  pr "  | %sn n wx =>" c;
-  pr "    match y with";
+  pr " Definition mk_t (n:nat) : dom_t n -> t :=";
+  pr "  match n as n' return dom_t n' -> t with";
   for i = 0 to size do
-    pr "    | %s%i wy =>" c i;
-    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 (extend%i %i wy)" size i (size - i - 1);
+    pr "   | %i => N%i" i i;
   done;
-  pr "    | %sn m wy => fnm n m wx wy" c;
-  pr "    end";
+  pr "   | %s(S n) => Nn n" (if size=0 then "" else "SizePlus ");
   pr "  end.";
   pr "";
 
-  pp "  Lemma spec_iter0: forall x y, P [x] [y] (iter0 x y).";
-  pp "  Proof.";
-  pp "  intros x; case x; clear x; unfold iter0.";
-  for i = 0 to size do
-    pp "    intros x.";
-    if i == 0 then
-      begin
-        pp "    generalize (spec_w0_eq0 x); case w0_eq0; intros H.";
-        pp "      intros y; rewrite H; apply Pf0t.";
-        pp "    clear H.";
-      end;
-    pp "    intros y; case y; clear y.";
-    for j = 0 to i - 1 do
-      pp "     intros y.";
-      if j == 0 then
-        begin
-          pp "     generalize (spec_w0_eq0 y); case w0_eq0; intros H.";
-          pp "       rewrite H; apply Pft0.";
-          pp "     clear H.";
-        end;
-      pp "     rewrite spec_eval%in%i;  apply (Pfn%i %i); zg_tac." j (i - j) j (i - j - 1);
-    done;
-    pp "     intros y; apply Pf%i." i;
-    for j = i + 1 to size do
-      pp "     intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac." i (j - i) i (j - i - 1);
-    done;
-    if i == size then
-      pp "     intros m y; rewrite spec_eval%in; apply Pf%in." size size
-    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
-    pp "    intros y.";
-    if i = 0 then
-      begin
-        pp "     generalize (spec_w0_eq0 y); case w0_eq0; intros H.";
-        pp "       rewrite H; apply Pft0.";
-        pp "     clear H.";
-      end;
-    if i == size then
-      pp "     rewrite spec_eval%in; apply Pfn%i." size size
-    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.";
-  pp "  Qed.";
-  pp "";
-
-
-  pr "  End LevelAndIter.";
-  pr "";
+pr
+" Definition level := iter_t (fun n _ => n).
 
+ Inductive View_t : t -> Prop :=
+  Mk_t : forall n (x : dom_t n), View_t (mk_t n x).
+
+ Lemma destr_t : forall x, View_t x.
+ Proof.
+ intros x. generalize (Mk_t (level x)). destruct x; simpl; auto.
+ Defined.
+
+ Lemma iter_mk_t : forall A (f:forall n, dom_t n -> A),
+ forall n x, iter_t f (mk_t n x) = f n x.
+ Proof.
+ do_size (destruct n; try reflexivity).
+ Qed.
+
+ (** * Projection to ZArith *)
+
+ Definition to_Z : t -> Z :=
+  Eval lazy beta iota delta [iter_t dom_t dom_op] in
+  iter_t (fun _ x => ZnZ.to_Z x).
+
+ Notation \"[ x ]\" := (to_Z x).
+
+ Theorem spec_mk_t : forall n (x:dom_t n), [mk_t n x] = ZnZ.to_Z x.
+ Proof.
+ intros. change to_Z with (iter_t (fun _ x => ZnZ.to_Z x)).
+ rewrite iter_mk_t; auto.
+ Qed.
+
+ (** * Regular make op, without memoization or karatsuba
+
+     This will normally never be used for actual computations,
+     but only for specification purpose when using
+     [word (dom_t n) m] intermediate values. *)
+
+ Fixpoint nmake_op (ww:Type) (ww_op: ZnZ.Ops ww) (n: nat) :
+       ZnZ.Ops (word ww n) :=
+  match n return ZnZ.Ops (word ww n) with
+   O => ww_op
+  | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1)
+  end.
+
+ Let eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m).
+
+ Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x,
+   nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x).
+ Proof.
+ auto.
+ Qed.
+
+ Theorem digits_nmake_S :forall n ww (w_op: ZnZ.Ops ww),
+    ZnZ.digits (nmake_op _ w_op (S n)) =
+    xO (ZnZ.digits (nmake_op _ w_op n)).
+ Proof.
+ auto.
+ Qed.
+
+ Theorem digits_nmake : forall n ww (w_op: ZnZ.Ops ww),
+    ZnZ.digits (nmake_op _ w_op n) = Pos.shiftl_nat (ZnZ.digits w_op) n.
+ Proof.
+ induction n. auto.
+ intros ww ww_op. rewrite Pshiftl_nat_S, <- IHn; auto.
+ Qed.
+
+ Theorem nmake_double: forall n ww (w_op: ZnZ.Ops ww),
+    ZnZ.to_Z (Ops:=nmake_op _ w_op n) =
+    @DoubleBase.double_to_Z _ (ZnZ.digits w_op) (ZnZ.to_Z (Ops:=w_op)) n.
+ Proof.
+ intros n; elim n; auto; clear n.
+ intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z.
+ rewrite <- Hrec; auto.
+ unfold DoubleBase.double_wB; rewrite <- digits_nmake; auto.
+ Qed.
+
+ Theorem nmake_WW: forall ww ww_op n xh xl,
+  (ZnZ.to_Z (Ops:=nmake_op ww ww_op (S n)) (WW xh xl) =
+   ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xh *
+    base (ZnZ.digits (nmake_op ww ww_op n)) +
+   ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xl)%%Z.
+ Proof.
+ auto.
+ Qed.
+
+ (** * The specification proofs for the word operators *)
+";
+
+  if size <> 0 then
+  pr " Typeclasses Opaque %s." (iter_name 1 size "w" "");
+  pr "";
+
+  pr " Instance w0_spec: ZnZ.Specs w0_op := W0.specs.";
+  for i = 1 to min 3 size do
+    pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs w%i_spec." i i (i-1)
+  done;
+  for i = 4 to size do
+    pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." i i (i-1)
+  done;
+  pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." (size+1) (size+1) size;
+
+
+pr "
+ Instance wn_spec (n:nat) : ZnZ.Specs (make_op n).
+ Proof.
+  induction n.
+  rewrite make_op_omake; simpl; auto with *.
+  rewrite make_op_S. exact (mk_zn2z_specs_karatsuba IHn).
+ Qed.
+
+ Instance dom_spec n : ZnZ.Specs (dom_op n) | 10.
+ Proof.
+  do_size (destruct n; auto with *). apply wn_spec.
+ Qed.
+
+ Let make_op_WW : forall n x y,
+   (ZnZ.to_Z (Ops:=make_op (S n)) (WW x y) =
+    ZnZ.to_Z (Ops:=make_op n) x * base (ZnZ.digits (make_op n))
+     + ZnZ.to_Z (Ops:=make_op n) y)%%Z.
+ Proof.
+ intros n x y; rewrite make_op_S; auto.
+ Qed.
+
+ (** * Zero *)
+
+ Definition zero0 : w0 := ZnZ.zero.
+
+ Definition zeron n : dom_t n :=
+  match n with
+   | O => zero0
+   | SizePlus (S n) => W0
+   | _ => W0
+  end.
+
+ Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z.
+ Proof.
+  do_size (destruct n; [exact ZnZ.spec_0|]).
+  destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0.
+ Qed.
+
+ (** * Digits *)
+
+ Lemma digits_make_op_0 : forall n,
+  ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op Size)) (S n).
+ Proof.
+ induction n.
+ auto.
+ replace (ZnZ.digits (make_op (S n))) with (xO (ZnZ.digits (make_op n))).
+  rewrite IHn; auto.
+ rewrite make_op_S; auto.
+ Qed.
+
+ Lemma digits_make_op : forall n,
+  ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) (SizePlus (S n)).
+ Proof.
+ intros. rewrite digits_make_op_0.
+ replace (SizePlus (S n)) with (S n + Size) by (rewrite <- plus_comm; auto).
+ rewrite Pshiftl_nat_plus. auto.
+ Qed.
+
+ Lemma digits_dom_op : forall n,
+  ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) n.
+ Proof.
+ do_size (destruct n; try reflexivity).
+ exact (digits_make_op n).
+ Qed.
+
+ Lemma digits_dom_op_nmake : forall n m,
+  ZnZ.digits (dom_op (m+n)) = ZnZ.digits (nmake_op _ (dom_op n) m).
+ Proof.
+ intros. rewrite digits_nmake, 2 digits_dom_op. apply Pshiftl_nat_plus.
+ Qed.
+
+ (** * Conversion between [zn2z (dom_t n)] and [dom_t (S n)].
+
+     These two types are provably equal, but not convertible,
+     hence we need some work. We now avoid using generic casts
+     (i.e. rewrite via proof of equalities in types), since
+     proving things with them is a mess.
+ *)
+
+ Definition succ_t n : zn2z (dom_t n) -> dom_t (S n) :=
+  match n with
+   | SizePlus (S _) => fun x => x
+   | _ => fun x => x
+  end.
+
+ Lemma spec_succ_t : forall n x,
+  ZnZ.to_Z (succ_t n x) =
+  zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.
+ Proof.
+ do_size (destruct n ; [reflexivity|]).
+ intros. simpl. rewrite make_op_S. simpl. auto.
+ Qed.
+
+ Definition pred_t n : dom_t (S n) -> zn2z (dom_t n) :=
+  match n with
+   | SizePlus (S _) => fun x => x
+   | _ => fun x => x
+  end.
+
+ Lemma succ_pred_t : forall n x, succ_t n (pred_t n x) = x.
+ Proof.
+ do_size (destruct n ; [reflexivity|]). reflexivity.
+ Qed.
+
+ (** We can hence project from [zn2z (dom_t n)] to [t] : *)
+
+ Definition mk_t_S n (x : zn2z (dom_t n)) : t :=
+  mk_t (S n) (succ_t n x).
+
+ Lemma spec_mk_t_S : forall n x,
+  [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.
+ Proof.
+ intros. unfold mk_t_S. rewrite spec_mk_t. apply spec_succ_t.
+ Qed.
+
+ Lemma mk_t_S_level : forall n x, level (mk_t_S n x) = S n.
+ Proof.
+ intros. unfold mk_t_S, level. rewrite iter_mk_t; auto.
+ Qed.
+
+ (** * Conversion from [word (dom_t n) m] to [dom_t (m+n)].
+
+     Things are more complex here. We start with a naive version
+     that breaks zn2z-trees and reconstruct them. Doing this is
+     quite unfortunate, but I don't know how to fully avoid that.
+     (cast someday ?). Then we build an optimized version where
+     all basic cases (n<=6 or m<=7) are nicely handled.
+ *)
+
+ Definition zn2z_map {A} {B} (f:A->B) (x:zn2z A) : zn2z B :=
+  match x with
+   | W0 => W0
+   | WW h l => WW (f h) (f l)
+  end.
+
+ Lemma zn2z_map_id : forall A f (x:zn2z A), (forall u, f u = u) ->
+   zn2z_map f x = x.
+ Proof.
+  destruct x; auto; intros.
+  simpl; f_equal; auto.
+ Qed.
+
+ (** The naive version *)
+
+ Fixpoint plus_t n m : word (dom_t n) m -> dom_t (m+n) :=
+  match m as m' return word (dom_t n) m' -> dom_t (m'+n) with
+   | O => fun x => x
+   | S m => fun x => succ_t _ (zn2z_map (plus_t n m) x)
+  end.
+
+ Theorem spec_plus_t : forall n m (x:word (dom_t n) m),
+  ZnZ.to_Z (plus_t n m x) = eval n m x.
+ Proof.
+ unfold eval.
+ induction m.
+ simpl; auto.
+ intros.
+ simpl plus_t; simpl plus. rewrite spec_succ_t.
+ destruct x.
+ simpl; auto.
+ fold word in w, w0.
+ simpl. rewrite 2 IHm. f_equal. f_equal. f_equal.
+ apply digits_dom_op_nmake.
+ Qed.
+
+ Definition mk_t_w n m (x:word (dom_t n) m) : t :=
+   mk_t (m+n) (plus_t n m x).
+
+ Theorem spec_mk_t_w : forall n m (x:word (dom_t n) m),
+  [mk_t_w n m x] = eval n m x.
+ Proof.
+ intros. unfold mk_t_w. rewrite spec_mk_t. apply spec_plus_t.
+ Qed.
+
+ (** The optimized version.
+
+     NB: the last particular case for m could depend on n,
+     but it's simplier to just expand everywhere up to m=7
+     (cf [mk_t_w'] later).
+ *)
+
+ Definition plus_t' n : forall m, word (dom_t n) m -> dom_t (m+n) :=
+   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
+     | SizePlus (S n') as n => plus_t n
+     | _ as n =>
+         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
+                    | SizePlus (S (S m')) as m => plus_t n m
+                    | _ => fun x => x
+                  end
+   end.
+
+ Lemma plus_t_equiv : forall n m x,
+  plus_t' n m x = plus_t n m x.
+ Proof.
+  (do_size try destruct n); try reflexivity;
+   (do_size try destruct m); try destruct m; try reflexivity;
+     simpl; symmetry; repeat (intros; apply zn2z_map_id; trivial).
+ Qed.
+
+ Lemma spec_plus_t' : forall n m x,
+  ZnZ.to_Z (plus_t' n m x) = eval n m x.
+ Proof.
+ intros; rewrite plus_t_equiv. apply spec_plus_t.
+ Qed.
+
+ (** Particular cases [Nk x] = eval i j x with specific k,i,j
+     can be solved by the following tactic *)
+
+ Ltac solve_eval :=
+  intros; rewrite <- spec_plus_t'; unfold to_Z; simpl dom_op; reflexivity.
+
+ (** The last particular case that remains useful *)
+
+ Lemma spec_eval_size : forall n x, [Nn n x] = eval Size (S n) x.
+ Proof.
+ induction n.
+ solve_eval.
+ destruct x as [ | xh xl ].
+  simpl. unfold eval. rewrite make_op_S. rewrite nmake_op_S. auto.
+ simpl word in xh, xl |- *.
+ unfold to_Z in *. rewrite make_op_WW.
+ unfold eval in *. rewrite nmake_WW.
+ f_equal; auto.
+ f_equal; auto.
+ f_equal.
+ rewrite <- digits_dom_op_nmake. rewrite plus_comm; auto.
+ Qed.
+
+ (** An optimized [mk_t_w].
+
+     We could say mk_t_w' := mk_t _ (plus_t' n m x)
+     (TODO: WHY NOT, BTW ??).
+     Instead we directly define functions for all intersting [n],
+     reverting to naive [mk_t_w] at places that should normally
+     never be used (see [mul] and [div_gt]).
+ *)
+";
+
+for i = 0 to size-1 do
+let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in
+pr
+" Let mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in
+  match m return word w%i (S m) -> t with
+    | %s as p => mk_t_w %i (S p)
+    | p => mk_t (%i+p)
+  end.
+" i i pattern i (i+1)
+done;
+
+pr
+" Let mk_t_w' n : forall m, word (dom_t n) (S m) -> t :=
+  match n return (forall m, word (dom_t n) (S m) -> t) with";
+for i = 0 to size-1 do pr "    | %i => mk_t_%iw" i i done;
+pr
+"    | Size => Nn
+    | _ as n' => fun m => mk_t_w n' (S m)
+  end.
+";
+
+pr
+" Ltac solve_spec_mk_t_w' :=
+  rewrite <- spec_plus_t';
+  match goal with _ : word (dom_t ?n) ?m |- _ => apply (spec_mk_t (n+m)) end.
+
+ Theorem spec_mk_t_w' :
+  forall n m x, [mk_t_w' n m x] = eval n (S m) x.
+ Proof.
+ intros.
+ repeat (apply spec_mk_t_w || (destruct n;
+  [repeat (apply spec_mk_t_w || (destruct m; [solve_spec_mk_t_w'|]))|])).
+ apply spec_eval_size.
+ Qed.
+
+ (** * Extend : injecting [dom_t n] into [word (dom_t n) (S m)] *)
+
+ Definition extend n m (x:dom_t n) : word (dom_t n) (S m) :=
+  DoubleBase.extend_aux m (WW (zeron n) x).
+
+ Lemma spec_extend : forall n m x,
+  [mk_t n x] = eval n (S m) (extend n m x).
+ Proof.
+ intros. unfold eval, extend.
+ rewrite spec_mk_t.
+ assert (H : forall (x:dom_t n),
+              (ZnZ.to_Z (zeron n) * base (ZnZ.digits (dom_op n)) + ZnZ.to_Z x =
+              ZnZ.to_Z x)%%Z).
+  clear; intros; rewrite spec_zeron; auto.
+ rewrite <- (@DoubleBase.spec_extend _
+              (WW (zeron n)) (ZnZ.digits (dom_op n)) ZnZ.to_Z H m x).
+ simpl. rewrite digits_nmake, <- nmake_double. auto.
+ Qed.
+
+ (** A particular case of extend, used in [same_level]:
+     [extend_size] is [extend Size] *)
+
+ Definition extend_size := DoubleBase.extend (WW (W0:dom_t Size)).
+
+ Lemma spec_extend_size : forall n x, [mk_t Size x] = [Nn n (extend_size n x)].
+ Proof.
+ intros. rewrite spec_eval_size. apply (spec_extend Size n).
+ Qed.
+
+ (** Misc results about extensions *)
+
+ Let spec_extend_WW : forall n x,
+  [Nn (S n) (WW W0 x)] = [Nn n x].
+ Proof.
+ intros n x.
+ set (N:=SizePlus (S n)).
+ change ([Nn (S n) (extend N 0 x)]=[mk_t N x]).
+ rewrite (spec_extend N 0).
+ solve_eval.
+ Qed.
+
+ Let spec_extend_tr: forall m n w,
+ [Nn (m + n) (extend_tr w m)] = [Nn n w].
+ Proof.
+ induction m; auto.
+ intros n x; simpl extend_tr.
+ simpl plus; rewrite spec_extend_WW; auto.
+ Qed.
+
+ Let spec_cast_l: forall n m x1,
+ [Nn n x1] =
+ [Nn (Max.max n m) (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))].
+ Proof.
+ intros n m x1; case (diff_r n m); simpl castm.
+ rewrite spec_extend_tr; auto.
+ Qed.
+
+ Let spec_cast_r: forall n m x1,
+ [Nn m x1] =
+ [Nn (Max.max n m) (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))].
+ Proof.
+ intros n m x1; case (diff_l n m); simpl castm.
+ rewrite spec_extend_tr; auto.
+ Qed.
+
+ Ltac unfold_lets :=
+  match goal with
+   | h : _ |- _ => unfold h; clear h; unfold_lets
+   | _ => idtac
+  end.
+
+ (** * [same_level]
+
+     Generic binary operator construction, by extending the smaller
+     argument to the level of the other.
+ *)
+
+ Section SameLevel.
+
+  Variable res: Type.
+  Variable P : Z -> Z -> res -> Prop.
+  Variable f : forall n, dom_t n -> dom_t n -> res.
+  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).
+";
+
+for i = 0 to size do
+pr "  Let f%i : w%i -> w%i -> res := f %i." i i i i
+done;
+pr
+"  Let fn n := f (SizePlus (S n)).
+
+  Let Pf' :
+   forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y).
+  Proof.
+  intros. subst. rewrite 2 spec_mk_t. apply Pf.
+  Qed.
+";
+
+let ext i j s =
+  if j <= i then s else Printf.sprintf "(extend %i %i %s)" i (j-i-1) s
+in
+
+pr "  Notation same_level_folded := (fun x y => match x, y with";
+for i = 0 to size do
+  for j = 0 to size do
+    pr "  | N%i wx, N%i wy => f%i %s %s" i j (max i j) (ext i j "wx") (ext j i "wy")
+  done;
+  pr "  | N%i wx, Nn m wy => fn m (extend_size m %s) wy" i (ext i size "wx")
+done;
+for i = 0 to size do
+  pr "  | Nn n wx, N%i wy => fn n wx (extend_size n %s)" i (ext i size "wy")
+done;
+pr
+"  | Nn n wx, Nn m wy =>
+    let mn := Max.max n m in
+    let d := diff n m in
+     fn mn
+       (castm (diff_r n m) (extend_tr wx (snd d)))
+       (castm (diff_l n m) (extend_tr wy (fst d)))
+  end).
+";
+
+pr
+"  Definition same_level := Eval lazy beta iota delta
+   [ DoubleBase.extend DoubleBase.extend_aux extend zeron ]
+  in same_level_folded.
+
+  Lemma spec_same_level_0: forall x y, P [x] [y] (same_level x y).
+  Proof.
+  change same_level with same_level_folded. unfold_lets.
+  destruct x, y; apply Pf'; simpl mk_t; rewrite <- ?spec_extend_size;
+  match goal with
+   | |- context [ extend ?n ?m _ ] => apply (spec_extend n m)
+   | |- context [ castm _ _ ] => apply spec_cast_l || apply spec_cast_r
+   | _ => reflexivity
+  end.
+  Qed.
+
+ End SameLevel.
+
+ Arguments same_level [res] f x y.
+
+ Theorem spec_same_level_dep :
+  forall res
+   (P : nat -> Z -> Z -> res -> Prop)
+   (Pantimon : forall n m z z' r, n <= m -> P m z z' r -> P n z z' r)
+   (f : forall n, dom_t n -> dom_t n -> res)
+   (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)),
+   forall x y, P (level x) [x] [y] (same_level f x y).
+ Proof.
+ intros res P Pantimon f Pf.
+ set (f' := fun n x y => (n, f n x y)).
+ set (P' := fun z z' r => P (fst r) z z' (snd r)).
+ assert (FST : forall x y, level x <= fst (same_level f' x y))
+  by (destruct x, y; simpl; omega with * ).
+ assert (SND : forall x y, same_level f x y = snd (same_level f' x y))
+  by (destruct x, y; reflexivity).
+ intros. eapply Pantimon; [eapply FST|].
+ rewrite SND. eapply (@spec_same_level_0 _ P' f'); eauto.
+ Qed.
+
+ (** * [iter]
+
+     Generic binary operator construction, by splitting the larger
+     argument in blocks and applying the smaller argument to them.
+ *)
+
+ Section Iter.
+
+  Variable res: Type.
+  Variable P: Z -> Z -> res -> Prop.
+
+  Variable f : forall n, dom_t n -> dom_t n -> res.
+  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).
+
+  Variable fd : forall n m, dom_t n -> word (dom_t n) (S m) -> res.
+  Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res.
+  Variable Pfd : forall n m x y, P (ZnZ.to_Z x) (eval n (S m) y) (fd n m x y).
+  Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y).
+
+  Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res.
+  Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y).
+
+  Let Pf' :
+   forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y).
+  Proof.
+  intros. subst. rewrite 2 spec_mk_t. apply Pf.
+  Qed.
+
+  Let Pfd' : forall n m x y u v, u = [mk_t n x] -> v = eval n (S m) y ->
+   P u v (fd n m x y).
+  Proof.
+  intros. subst. rewrite spec_mk_t. apply Pfd.
+  Qed.
+
+  Let Pfg' : forall n m x y u v, u = eval n (S m) x -> v = [mk_t n y] ->
+   P u v (fg n m x y).
+  Proof.
+  intros. subst. rewrite spec_mk_t. apply Pfg.
+  Qed.
+";
+
+for i = 0 to size do
+pr "  Let f%i := f %i." i i
+done;
+
+for i = 0 to size do
+pr "  Let f%in := fd %i." i i;
+pr "  Let fn%i := fg %i." i i;
+done;
+
+pr "  Notation iter_folded := (fun x y => match x, y with";
+for i = 0 to size do
+  for j = 0 to size do
+    pr "  | N%i wx, N%i wy => f%s wx wy" i j
+      (if i = j then string_of_int i
+       else if i < j then string_of_int i ^ "n " ^ string_of_int (j-i-1)
+       else "n" ^ string_of_int j ^ " " ^ string_of_int (i-j-1))
+  done;
+  pr "  | N%i wx, Nn m wy => f%in m %s wy" i size (ext i size "wx")
+done;
+for i = 0 to size do
+  pr "  | Nn n wx, N%i wy => fn%i n wx %s" i size (ext i size "wy")
+done;
+pr
+"  | Nn n wx, Nn m wy => fnm n m wx wy
+  end).
+";
+
+pr
+"  Definition iter := Eval lazy beta iota delta
+   [extend DoubleBase.extend DoubleBase.extend_aux zeron]
+   in iter_folded.
+
+  Lemma spec_iter: forall x y, P [x] [y] (iter x y).
+  Proof.
+  change iter with iter_folded; unfold_lets.
+  destruct x; destruct y; apply Pf' || apply Pfd' || apply Pfg' || apply Pfnm;
+  simpl mk_t;
+  match goal with
+   | |- ?x = ?x => reflexivity
+   | |- [Nn _ _] = _ => apply spec_eval_size
+   | |- context [extend ?n ?m _] => apply (spec_extend n m)
+   | _ => idtac
+  end;
+  unfold to_Z; rewrite <- spec_plus_t'; simpl dom_op; reflexivity.
+  Qed.
+
+  End Iter.
+";
+
+pr
+"  Definition switch
+  (P:nat->Type)%s
+  (fn:forall n, P n) n :=
+  match n return P n with"
+  (iter_str_gen size (fun i -> Printf.sprintf "(f%i:P %i)" i i));
+for i = 0 to size do pr "   | %i => f%i" i i done;
+pr
+"   | n => fn n
+  end.
+";
+
+pr
+"  Lemma spec_switch : forall P (f:forall n, P n) n,
+   switch P %sf n = f n.
+  Proof.
+  repeat (destruct n; try reflexivity).
+  Qed.
+" (iter_str_gen size (fun i -> Printf.sprintf "(f %i) " i));
+
+pr
+"  (** * [iter_sym]
+
+    A variant of [iter] for symmetric functions, or pseudo-symmetric
+    functions (when f y x can be deduced from f x y).
+  *)
+
+  Section IterSym.
+
+  Variable res: Type.
+  Variable P: Z -> Z -> res -> Prop.
+
+  Variable f : forall n, dom_t n -> dom_t n -> res.
+  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).
+
+  Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res.
+  Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y).
+
+  Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res.
+  Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y).
+
+  Variable opp: res -> res.
+  Variable Popp : forall u v r, P u v r -> P v u (opp r).
+";
+
+for i = 0 to size do
+pr "  Let f%i := f %i." i i
+done;
+
+for i = 0 to size do
+pr "  Let fn%i := fg %i." i i;
+done;
+
+pr "  Let f' := switch _ %s f." (iter_name 0 size "f" "");
+pr "  Let fg' := switch _ %s fg." (iter_name 0 size "fn" "");
+
+pr
+"  Local Notation iter_sym_folded :=
+   (iter res f' (fun n m x y => opp (fg' n m y x)) fg' fnm).
+
+  Definition iter_sym :=
+   Eval lazy beta zeta iota delta [iter f' fg' switch] in iter_sym_folded.
+
+  Lemma spec_iter_sym: forall x y, P [x] [y] (iter_sym x y).
+  Proof.
+  intros. change iter_sym with iter_sym_folded. apply spec_iter; clear x y.
+  unfold_lets.
+  intros. rewrite spec_switch. auto.
+  intros. apply Popp. unfold_lets. rewrite spec_switch; auto.
+  intros. unfold_lets. rewrite spec_switch; auto.
+  auto.
+  Qed.
+
+  End IterSym.
+
+ (** * Reduction
+
+     [reduce] can be used instead of [mk_t], it will choose the
+     lowest possible level. NB: We only search and remove leftmost
+     W0's via ZnZ.eq0, any non-W0 block ends the process, even
+     if its value is 0.
+ *)
+
+ (** First, a direct version ... *)
+
+ Fixpoint red_t n : dom_t n -> t :=
+  match n return dom_t n -> t with
+   | O => N0
+   | S n => fun x =>
+     let x' := pred_t n x in
+     reduce_n1 _ _ (N0 zero0) ZnZ.eq0 (red_t n) (mk_t_S n) x'
+  end.
+
+ Lemma spec_red_t : forall n x, [red_t n x] = [mk_t n x].
+ Proof.
+ induction n.
+ reflexivity.
+ intros.
+ simpl red_t. unfold reduce_n1.
+ rewrite <- (succ_pred_t n x) at 2.
+ remember (pred_t n x) as x'.
+ rewrite spec_mk_t, spec_succ_t.
+ destruct x' as [ | xh xl]. simpl. apply ZnZ.spec_0.
+ generalize (ZnZ.spec_eq0 xh); case ZnZ.eq0; intros H.
+ rewrite IHn, spec_mk_t. simpl. rewrite H; auto.
+ apply spec_mk_t_S.
+ Qed.
+
+ (** ... then a specialized one *)
+";
+
+for i = 0 to size do
+pr " Definition eq0%i := @ZnZ.eq0 _ w%i_op." i i;
+done;
+
+pr "
+ Definition reduce_0 := N0.";
+for i = 1 to size do
+  pr " Definition reduce_%i :=" i;
+  pr "  Eval lazy beta iota delta [reduce_n1] in";
+  pr "   reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i N%i." (i-1) (i-1) i
+done;
 
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Reduction                         *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  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."
-      (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 "  Eval lazy beta iota delta [reduce_n1] in";
+  pr "   reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i (Nn 0)." size size;
 
   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 "";
-
-  pp " Let spec_reduce_0: forall x, [reduce_0 x] = [%s0 x]." c;
-  pp " Proof.";
-  pp " intros x; unfold to_Z, reduce_0.";
-  pp " auto.";
-  pp " Qed.";
-  pp "";
-
-  for i = 1 to size + 1 do
-    if i == size + 1 then
-      pp " Let spec_reduce_%i: forall x, [reduce_%i x] = [%sn 0 x]." i i c
-    else
-      pp " Let spec_reduce_%i: forall x, [reduce_%i x] = [%s%i x]." i i c i;
-    pp " Proof.";
-    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 "   case w%i_eq0; intros H1; auto." (i - 1);
-    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 "";
-  done;
-
-  pp " Let spec_reduce_n: forall n x, [reduce_n n x] = [%sn n x]." c;
-  pp " Proof.";
-  pp " intros n; elim n; simpl reduce_n.";
-  pp "   intros x; rewrite <- spec_reduce_%i; auto." (size + 1);
-  pp " intros n1 Hrec x; case x.";
-  pp " unfold to_Z; rewrite make_op_S; auto.";
-  pp " exact (spec_0 w0_spec).";
-  pp " intros x1 y1; case x1; auto.";
-  pp " rewrite Hrec.";
-  pp " rewrite spec_extendn0_0; auto.";
-  pp " Qed.";
-  pp "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Successor                         *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_succ_c := w%i_op.(znz_succ_c)." i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_succ := w%i_op.(znz_succ)." i i
-  done;
-  pr "";
-
-  pr " Definition succ x :=";
-  pr "  match x with";
-  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 "    | 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 "    | 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 "    | C1 r => %sn (S n) (WW op.(znz_1) r)" c;
-  pr "    end";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_succ: forall n, [succ n] = [n] + 1.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp "  intros n; case n; unfold succ, to_Z.";
-  for i = 0 to size do
-    pp  "  intros n1; generalize (spec_succ_c w%i_spec n1);" i;
-    pp  "  unfold succ, to_Z, w%i_succ_c; case znz_succ_c; auto." i;
-    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;
-  done;
-  pp "  intros k n1; generalize (spec_succ_c (wn_spec k) n1).";
-  pp "  unfold succ, to_Z; case znz_succ_c; auto.";
-  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.";
-  pr "";
-
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  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 x y :=" i;
-    pr "  match w%i_add_c x y with" i;
-    pr "  | C0 r => %s%i r" c i;
-    if i == size then
-      pr "  | C1 r => %sn 0 (WW one%i r)" c size
-    else
-      pr "  | C1 r => %s%i (WW one%i r)" c (i + 1) i;
-    pr "  end.";
-    pr "";
-  done ;
-  pr " Definition addn n (x y : word w%i (S n)) :=" size;
-  pr "  let op := make_op n in";
-  pr "  match op.(znz_add_c) x y with";
-  pr "  | C0 r => %sn n r" c;
-  pr "  | C1 r => %sn (S n) (WW op.(znz_1) r)  end." c;
-  pr "";
-
-
-  for i = 0 to size do
-    pp " Let spec_w%i_add: forall x y, [w%i_add x y] = [%s%i x] + [%s%i y]." i i c i c i;
-    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 "    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 "";
-  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 " 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.";
-
-  pr " Definition add := Eval lazy beta delta [same_level] in";
-  pr0 "   (same_level t_ ";
-  for i = 0 to size do
-    pr0 "w%i_add " i;
-  done;
-  pr "addn).";
-  pr "";
-
-  pr " Theorem spec_add: forall x y, [add x y] = [x] + [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " unfold add.";
-  pp " generalize (spec_same_level t_ (fun x y res => [res] = x + y)).";
-  pp " unfold same_level; intros HH; apply HH; clear HH.";
-  for i = 0 to size do
-    pp " exact spec_w%i_add." i;
-  done;
-  pp " exact spec_wn_add.";
-  pp " Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Predecessor                       *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_pred_c := w%i_op.(znz_pred_c)." i i
-  done;
-  pr "";
-
-  pr " Definition pred x :=";
-  pr "  match x with";
-  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 "    | 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 "    | C1 r => zero";
-  pr "    end";
-  pr "  end.";
-  pr "";
-
-  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 " 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.";
-    pp " case (spec_to_Z w%i_spec x1); intros HH1 HH2." i;
-    pp " case (spec_to_Z w%i_spec y1); intros HH3 HH4 HH5." i;
-    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 "   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.";
-  pp " case (spec_to_Z (wn_spec n) x1); intros HH1 HH2.";
-  pp " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4 HH5.";
-  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 " 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 "   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 "   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 " (** *                        Subtraction                       *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_sub_c := w%i_op.(znz_sub_c)." i i
-  done;
-  pr "";
-
-  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;
-    pr "  | C1 r => zero";
-    pr "  end."
-  done;
-  pr "";
-
-  pr " Definition subn n (x y : word w%i (S n)) :=" size;
-  pr "  let op := make_op n in";
-  pr "  match op.(znz_sub_c) x y with";
-  pr "  | C0 r => %sn n r" c;
-  pr "  | C1 r => N0 w_0";
-  pr "  end.";
-  pr "";
-
-  for i = 0 to size do
-    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 "    intros x; auto."
-    else
-      pp "   intros x; try rewrite spec_reduce_%i; auto." i;
-    pp " unfold interp_carry; unfold zero, w_0, to_Z.";
-    pp " rewrite (spec_0 w0_spec).";
-    pp " case (spec_to_Z w%i_spec x); intros; auto with zarith." i;
-    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 "   intros x; auto.";
-  pp " unfold interp_carry, to_Z.";
-  pp " case (spec_to_Z (wn_spec k) x); intros; auto with zarith.";
-  pp " Qed.";
-  pp "";
-
-  pr " Definition sub := Eval lazy beta delta [same_level] in";
-  pr0 "   (same_level t_ ";
-  for i = 0 to size do
-    pr0 "w%i_sub " i;
-  done;
-  pr "subn).";
-  pr "";
-
-  pr " Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " unfold sub.";
-  pp " generalize (spec_same_level t_ (fun x y res => y <= x -> [res] = x - y)).";
-  pp " unfold same_level; intros HH; apply HH; clear HH.";
-  for i = 0 to size do
-    pp " exact spec_w%i_sub." i;
-  done;
-  pp " exact spec_wn_sub.";
-  pp " Qed.";
-  pr "";
-
-  for i = 0 to size do
-    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 "   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.";
-    pp " Qed.";
-    pp "";
-  done;
-
-  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 "   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.";
-  pp " Qed.";
-  pp "";
-
-  pr " Theorem spec_sub0: forall x y, [x] < [y] -> [sub x y] = 0.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " unfold sub.";
-  pp " generalize (spec_same_level t_ (fun x y res => x < y -> [res] = 0)).";
-  pp " unfold same_level; intros HH; apply HH; clear HH.";
-  for i = 0 to size do
-    pp " exact spec_w%i_sub0." i;
-  done;
-  pp " exact spec_wn_sub0.";
-  pp " Qed.";
-  pr "";
-
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Comparison                        *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition compare_%i := w%i_op.(znz_compare)." i i;
-    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 " Definition comparenm n m wx wy :=";
-  pr "    let mn := Max.max n m in";
-  pr "    let d := diff n m in";
-  pr "    let op := make_op mn in";
-  pr "     op.(znz_compare)";
-  pr "       (castm (diff_r n m) (extend_tr wx (snd d)))";
-  pr "       (castm (diff_l n m) (extend_tr wy (fst d))).";
-  pr "";
-
-  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 => CompOpp (comparen_%i (S n) y x))" i;
-    pr "      (fun n => comparen_%i (S n))" i;
-  done;
-  pr "      comparenm).";
-  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 "      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;
-    pp "    end.";
-    pp "  Proof.";
-    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;
-    pp "  | Eq => eval%in n x = [%s%i y]" i c i;
-    pp "  | Lt => eval%in n x < [%s%i y]" i c i;
-    pp "  | Gt => eval%in n x > [%s%i y]" i c i;
-    pp "  end.";
-    pp "  intros n x y.";
-    pp "  unfold comparen_%i, to_Z; rewrite spec_double_eval%in." i i;
-    pp "  apply spec_compare_mn_1.";
-    pp "  exact (spec_0 w%i_spec)." i;
-    pp "  intros x1; exact (spec_compare w%i_spec %s x1)." i (pz i);
-    pp "  exact (spec_to_Z w%i_spec)." i;
-    pp "  exact (spec_compare w%i_spec)." i;
-    pp "  exact (spec_compare w%i_spec)." i;
-    pp "  exact (spec_to_Z w%i_spec)." i;
-    pp "  Qed.";
-    pp "";
-  done;
-
-  pp " Let spec_opp_compare: forall c (u v: Z),";
-  pp "  match c with Eq => u = v | Lt => u < v | Gt => u > v end ->";
-  pp "  match CompOpp c with Eq => v = u | Lt => v < u | Gt => v > u end.";
-  pp " Proof.";
-  pp " intros c u v; case c; unfold CompOpp; auto with zarith.";
-  pp " Qed.";
-  pp "";
-
-
-  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 "                        Eq => x = y";
-  pp "                      | Lt => x < y";
-  pp "                      | Gt => x > y";
-  pp "                      end)";
-  for i = 0 to size do
-    pp "      compare_%i" i;
-    pp "      (fun n x y => CompOpp (comparen_%i (S n) y x))" i;
-    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;
-  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;
-  pp "  intros n m x y; unfold comparenm.";
-  pp "  rewrite <- (spec_cast_l n m x); rewrite <- (spec_cast_r n m y).";
-  pp "  unfold to_Z; apply (spec_compare  (wn_spec (Max.max n m))).";
-  pp "  Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Multiplication                    *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_mul_c := w%i_op.(znz_mul_c)." i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_mul_add :=" i;
-    pr "   Eval lazy beta delta [w_mul_add] in";
-    pr "     @w_mul_add w%i %s w%i_succ w%i_add_c w%i_mul_c." i (pz i) i i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_0W := znz_0W w%i_op." i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_WW := znz_WW w%i_op." i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_mul_add_n1 :=" i;
-    pr "  @double_mul_add_n1 w%i %s w%i_WW w%i_0W w%i_mul_add."  i (pz i) i i i
-  done;
-  pr "";
-
-  for i = 0 to size - 1 do
-    pr "  Let to_Z%i n :=" i;
-    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
-          pr "  | %i%s => fun x => %sn 0 x" j "%nat" c;
-          pr "  | %i%s => fun x => %sn 1 x" (j + 1) "%nat" c
-        end
-      else
-        pr "  | %i%s => fun x => %s%i x" j "%nat" c (i + j + 1)
-    done;
-    pr   "  | _   => fun _ => N0 w_0";
-    pr "  end.";
-    pr "";
-  done;
-
-
-  for i = 0 to size - 1 do
-    pp "Theorem to_Z%i_spec:" i;
-    pp "  forall n x, Z_of_nat n <= %i -> [to_Z%i n x] = znz_to_Z (nmake_op _ w%i_op (S n)) x." (size + 1 - i) i i;
-    for j = 1 to size + 2 - i do
-      pp " intros n; case n; clear n.";
-      pp "   unfold to_Z%i." i;
-      pp "   intros x H; rewrite spec_eval%in%i; auto." i j;
-    done;
-    pp " intros n x.";
-    pp " repeat rewrite inj_S; unfold Zsucc; auto with zarith.";
-    pp " Qed.";
-    pp "";
-  done;
-
-
-  for i = 0 to size do
-    pr " Definition w%i_mul n x y :=" i;
-    pr " let (w,r) := w%i_mul_add_n1 (S n) x y %s in" i (pz i);
-    if i == size then
-      begin
-        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
-        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;
-    pr "";
-  done;
-
-  pr " Definition mulnm n m x y :=";
-  pr "    let mn := Max.max n m in";
-  pr "    let d := diff n m in";
-  pr "    let op := make_op mn in";
-  pr "     reduce_n (S mn) (op.(znz_mul_c)";
-  pr "       (castm (diff_r n m) (extend_tr x (snd d)))";
-  pr "       (castm (diff_l n m) (extend_tr y (fst d)))).";
-  pr "";
-
-  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 n x y => w%i_mul n y x)" i;
-    pr "    w%i_mul" i;
-  done;
-  pr "    mulnm";
-  pr "    (fun _ => N0 w_0)";
-  pr "    (fun _ => N0 w_0)";
-  pr "  ).";
-  pr "";
-  for i = 0 to size do
-    pp " Let spec_w%i_mul_add: forall x y z," i;
-    pp "  let (q,r) := w%i_mul_add x y z in" i;
-    pp "  znz_to_Z w%i_op q * (base (znz_digits w%i_op))  +  znz_to_Z w%i_op r =" i i i;
-    pp "  znz_to_Z w%i_op x * znz_to_Z w%i_op y + znz_to_Z w%i_op z :=" i i i ;
-    pp "   (spec_mul_add w%i_spec)." i;
-    pp "";
-  done;
-
-  for i = 0 to size do
-    pp " Theorem spec_w%i_mul_add_n1: forall n x y z," i;
-    pp "  let (q,r) := w%i_mul_add_n1 n x y z in" i;
-    pp "  znz_to_Z w%i_op q * (base (znz_digits (nmake_op _ w%i_op n)))  +" i i;
-    pp "  znz_to_Z (nmake_op _ w%i_op n) r =" i;
-    pp "  znz_to_Z (nmake_op _ w%i_op n) x * znz_to_Z w%i_op y +" i i;
-    pp "  znz_to_Z w%i_op z." i;
-    pp " Proof.";
-    pp " intros n x y z; unfold w%i_mul_add_n1." i;
-    pp " rewrite nmake_double.";
-    pp " rewrite digits_doubled.";
-    pp " change (base (DoubleBase.double_digits (znz_digits w%i_op) n)) with" i;
-    pp "        (DoubleBase.double_wB (znz_digits w%i_op) n)." i;
-    pp " apply spec_double_mul_add_n1; auto.";
-    if i == 0 then pp " exact (spec_0 w%i_spec)." i;
-    pp " exact (spec_WW w%i_spec)." i;
-    pp " exact (spec_0W w%i_spec)." i;
-    pp " exact (spec_mul_add w%i_spec)." i;
-    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)) +";
-  pp "    znz_to_Z (nmake_op ww ww1 n) y.";
-  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 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
-      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;
-  pp "  Proof.";
-  pp "    intros n x y; unfold to_Z.";
-  pp "    rewrite <- (spec_mul_c (wn_spec n)).";
-  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 "    forall n x y,";
-    if i <> size then
-      pp0 "    Z_of_nat n <= %i -> "   (size - i);
-    pp "    [w%i_mul n x y] = eval%in (S n) x * [%s%i y])." i i c i;
-    if i == size then
-      pp "    intros n x y; unfold w%i_mul." i
-    else
-      pp "    intros n x y H; unfold w%i_mul." i;
-    pp "    generalize (spec_w%i_mul_add_n1 (S n) x y %s)." i (pz i);
-    pp "    case w%i_mul_add_n1; intros x1 y1." i;
-    pp "    change (znz_to_Z (nmake_op _ w%i_op (S n)) x) with (eval%in (S n) x)." i i;
-    pp "    change (znz_to_Z w%i_op y) with ([%s%i y])." i c i;
-    if i == 0 then
-      pp "    unfold w_0; rewrite (spec_0 w0_spec); rewrite Zplus_0_r."
-    else
-      pp "    change (znz_to_Z w%i_op W0) with 0; rewrite Zplus_0_r." i;
-    pp "    intros H1; rewrite <- H1; clear H1.";
-    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
-        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
-    else
-      begin
-        pp "    rewrite to_Z%i_spec; auto with zarith." i;
-        pp "    rewrite to_Z%i_spec; try (rewrite inj_S; auto with zarith)." i
-      end;
-    pp "    rewrite nmake_op_WW; rewrite extend%in_spec; auto." i;
-  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 n x y => w%i_mul n y x)" i;
-    pp "    w%i_mul _ _ _" i;
-  done;
-  pp "    mulnm _";
-  pp "    (fun _ => N0 w_0) _";
-  pp "    (fun _ => N0 w_0) _";
-  pp "  ).";
-  for i = 0 to size do
-    pp "    intros x y; rewrite spec_reduce_%i." (i + 1);
-    pp "    unfold w%i_mul_c, to_Z." i;
-    pp "    generalize (spec_mul_c w%i_spec x y)." i;
-    pp "    intros HH; rewrite <- HH; clear HH; auto.";
-    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;
-      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;
-      end;
-  done;
-  pp "    intros n m x y; unfold mulnm.";
-  pp "    rewrite spec_reduce_n.";
-  pp "    rewrite <- (spec_cast_l n m x).";
-  pp "    rewrite <- (spec_cast_r n m y).";
-  pp "    rewrite spec_muln; rewrite spec_cast_l; rewrite spec_cast_r; auto.";
-  pp "    intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring.";
-  pp "    intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring.";
-  pp "  Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Square                            *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_square_c := w%i_op.(znz_square_c)." i i
-  done;
-  pr "";
-
-  pr " Definition square x :=";
-  pr "  match x with";
-  pr "  | %s0 wx => reduce_1 (w0_square_c wx)" c;
-  for i = 1 to size - 1 do
-    pr "  | %s%i wx => %s%i (w%i_square_c wx)" c i c (i+1) i
-  done;
-  pr "  | %s%i wx => %sn 0 (w%i_square_c wx)" c size c size;
-  pr "  | %sn n wx =>" c;
-  pr "    let op := make_op n in";
-  pr "    %sn (S n) (op.(znz_square_c) wx)" c;
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_square: forall x, [square x] = [x] * [x].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp "  intros x; case x; unfold square; clear x.";
-  pp "  intros x; rewrite spec_reduce_1; unfold to_Z.";
-  pp "   exact (spec_square_c w%i_spec x)." 0;
-  for i = 1 to size do
-    pp "  intros x; unfold to_Z.";
-    pp "    exact (spec_square_c w%i_spec x)." i;
-  done;
-  pp "  intros n x; unfold to_Z.";
-  pp "    rewrite make_op_S.";
-  pp "    exact (spec_square_c (wn_spec n) x).";
-  pp "Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Square root                       *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_sqrt := w%i_op.(znz_sqrt)." i i
-  done;
-  pr "";
-
-  pr " Definition sqrt x :=";
-  pr "  match x with";
-  for i = 0 to size do
-    pr "  | %s%i wx => reduce_%i (w%i_sqrt wx)" c i i i;
-  done;
-  pr "  | %sn n wx =>" c;
-  pr "    let op := make_op n in";
-  pr "    reduce_n n (op.(znz_sqrt) wx)";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; unfold sqrt; case x; clear x.";
-  for i = 0 to size do
-    pp " intros x; rewrite spec_reduce_%i; exact (spec_sqrt w%i_spec x)." i i;
-  done;
-  pp " intros n x; rewrite spec_reduce_n; exact (spec_sqrt (wn_spec n) x).";
-  pp " Qed.";
-  pr "";
-
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Division                          *)";
-  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 "    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_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 "    (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec)).";
-  pp "";
-
-  for i = 0 to size do
-    pr " Definition w%i_divn1 n x y :="  i;
-    pr "  let (u, v) :=";
-    pr "  double_divn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)" i i;
-    pr "    (znz_WW w%i_op) w%i_op.(znz_head0)" i i;
-    pr "    w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)" i i;
-    pr "    w%i_op.(znz_compare) w%i_op.(znz_sub) (S n) x y in" i i;
-    if i == size then
-      pr "   (%sn _ u, %s%i v)." c c i
-    else
-      pr "   (to_Z%i _ u, %s%i v)." i c i;
-  done;
-  pr "";
-
-  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 "     [%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.";
-    pp " rewrite spec_double_eval%in; unfold to_Z." i;
-    pp " apply DoubleBase.spec_get_low.";
-    pp " exact (spec_0 w%i_spec)." i;
-    pp " exact (spec_to_Z w%i_spec)." i;
-    pp " apply Zle_lt_trans with [%s%i y]; auto." c i;
-    pp "   rewrite <- spec_double_eval%in; auto." i;
-    pp " unfold to_Z; case (spec_to_Z w%i_spec y); auto." i;
-    pp " Qed.";
-    pp "";
-  done;
-
-  for i = 0 to size do
-    pr " Let div_gt%i x y := let (u,v) := (w%i_div_gt x y) in (reduce_%i u, reduce_%i v)." i i i i;
-  done;
-  pr "";
-
-
-  pr " Let div_gtnm n m wx wy :=";
-  pr "    let mn := Max.max n m in";
-  pr "    let d := diff n m in";
-  pr "    let op := make_op mn in";
-  pr "    let (q, r):= op.(znz_div_gt)";
-  pr "         (castm (diff_r n m) (extend_tr wx (snd d)))";
-  pr "         (castm (diff_l n m) (extend_tr wy (fst d))) in";
-  pr "    (reduce_n mn q, reduce_n mn r).";
-  pr "";
-
-  pr " Definition div_gt := Eval lazy beta delta [iter] in";
-  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;
-  done;
-  pr "      div_gtnm).";
-  pr "";
-
-  pr " Theorem spec_div_gt: forall x y,";
-  pr "       [x] > [y] -> 0 < [y] ->";
-  pr "      let (q,r) := div_gt x y in";
-  pr "      [q] = [x] / [y] /\\ [r] = [x] mod [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " assert (FO:";
-  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 "      let (q,r) := res in";
-  pp "      x = [q] * y + [r] /\\ 0 <= [r] < y)";
-  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;
-  done;
-  pp "      div_gtnm _).";
-  for i = 0 to size do
-    pp "  intros x y H1 H2; unfold div_gt%i, w%i_div_gt." i i;
-    pp "    generalize (spec_div_gt w%i_spec x y H1 H2); case znz_div_gt." i;
-    pp "    intros xx yy; repeat rewrite spec_reduce_%i; auto." i;
-    if i == size then
-      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 "                (DoubleBase.get_low %s (S n) y))." (pz i);
-    pp0 "";
-    for j = 0 to i do
-      pp0 "unfold w%i; " (i-j);
-    done;
-    pp "case znz_div_gt.";
-    pp "    intros xx yy H4; repeat rewrite spec_reduce_%i." i;
-    pp "    generalize (spec_get_end%i (S n) y x); unfold to_Z; intros H5." i;
-    pp "    unfold to_Z in H2; rewrite H5 in H4; auto with zarith.";
-    if i == size then
-      pp "  intros n x y H2 H3."
-    else
-      pp "  intros n x y H1 H2 H3.";
-    pp "    generalize";
-    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);
-    done;
-    pp "case double_divn1.";
-    pp "    intros xx yy H4.";
-    if i == size then
-      begin
-        pp "    repeat rewrite <- spec_double_eval%in in H4; auto." i;
-        pp "    rewrite spec_eval%in; auto." i;
-      end
-    else
-      begin
-        pp "    rewrite to_Z%i_spec; auto with zarith." i;
-        pp "    repeat rewrite <- spec_double_eval%in in H4; auto." i;
-      end;
-  done;
-  pp "  intros n m x y H1 H2; unfold div_gtnm.";
-  pp "    generalize (spec_div_gt (wn_spec (Max.max n m))";
-  pp "                   (castm (diff_r n m)";
-  pp "                     (extend_tr x (snd (diff n m))))";
-  pp "                   (castm (diff_l n m)";
-  pp "                     (extend_tr y (fst (diff n m))))).";
-  pp "    case znz_div_gt.";
-  pp "    intros xx yy HH.";
-  pp "    repeat rewrite spec_reduce_n.";
-  pp "    rewrite <- (spec_cast_l n m x).";
-  pp "    rewrite <- (spec_cast_r n m y).";
-  pp "    unfold to_Z; apply HH.";
-  pp "    rewrite <- (spec_cast_l n m x) in H1; auto.";
-  pp "    rewrite <- (spec_cast_r n m y) in H1; auto.";
-  pp "    rewrite <- (spec_cast_r n m y) in H2; auto.";
-  pp "  intros x y H1 H2; generalize (FO x y H1 H2); case div_gt.";
-  pp "  intros q r (H3, H4); split.";
-  pp "  apply (Zdiv_unique [x] [y] [q] [r]); auto.";
-  pp "  rewrite Zmult_comm; auto.";
-  pp "  apply (Zmod_unique [x] [y] [q] [r]); auto.";
-  pp "  rewrite Zmult_comm; auto.";
-  pp "  Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                        Modulo                            *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_mod_gt := w%i_op.(znz_mod_gt)." i i
-  done;
-  pr "";
-
-  for i = 0 to size do
-    pr " Definition w%i_modn1 :=" i;
-    pr "  double_modn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)" i i;
-    pr "    w%i_op.(znz_head0) w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)" i i i;
-    pr "    w%i_op.(znz_compare) w%i_op.(znz_sub)." i i;
-  done;
-  pr "";
-
-  pr " Let mod_gtnm n m wx wy :=";
-  pr "    let mn := Max.max n m in";
-  pr "    let d := diff n m in";
-  pr "    let op := make_op mn in";
-  pr "    reduce_n mn (op.(znz_mod_gt)";
-  pr "         (castm (diff_r n m) (extend_tr wx (snd d)))";
-  pr "         (castm (diff_l n m) (extend_tr wy (fst d)))).";
-  pr "";
-
-  pr " Definition mod_gt := Eval lazy beta delta[iter] in";
-  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);
-    pr "      (fun n x y => reduce_%i (w%i_modn1 (S n) x y))" i i;
-  done;
-  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 "    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_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 "    (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec)).";
-  pp "";
-
-  pr " Theorem spec_mod_gt:";
-  pr "   forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " refine (spec_iter _ (fun x y res => x > y -> 0 < y ->";
-  pp "      [res] = x mod y)";
-  for i = 0 to size do
-    pp "      (fun x y => reduce_%i (w%i_mod_gt x y))" i i;
-    pp "      (fun n x y => reduce_%i (w%i_mod_gt x (DoubleBase.get_low %s (S n) y)))" i i (pz i);
-    pp "      (fun n x y => reduce_%i (w%i_modn1 (S n) x y)) _ _ _" i i;
-  done;
-  pp "      mod_gtnm _).";
-  for i = 0 to size do
-    pp " intros x y H1 H2; rewrite spec_reduce_%i." i;
-    pp "   exact (spec_mod_gt w%i_spec x y H1 H2)." i;
-    if i == size then
-      pp " intros n x y H2 H3; rewrite spec_reduce_%i." i
-    else
-      pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i;
-    pp " unfold w%i_mod_gt." i;
-    pp " rewrite <- (spec_get_end%i (S n) y x); auto with zarith." i;
-    pp " unfold to_Z; apply (spec_mod_gt w%i_spec); auto." i;
-    pp " rewrite <- (spec_get_end%i (S n) y x) in H2; auto with zarith." i;
-    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
-      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;
-  done;
-  pp " intros n m x y H1 H2; unfold mod_gtnm.";
-  pp "    repeat rewrite spec_reduce_n.";
-  pp "    rewrite <- (spec_cast_l n m x).";
-  pp "    rewrite <- (spec_cast_r n m y).";
-  pp "    unfold to_Z; apply (spec_mod_gt (wn_spec (Max.max n m))).";
-  pp "    rewrite <- (spec_cast_l n m x) in H1; auto.";
-  pp "    rewrite <- (spec_cast_r n m y) in H1; auto.";
-  pp "    rewrite <- (spec_cast_r n m y) in H2; auto.";
-  pp " Qed.";
-  pr "";
-
-  pr " (** digits: a measure for gcd *)";
-  pr "";
-
-  pr " Definition digits x :=";
-  pr "  match x with";
-  for i = 0 to size do
-    pr "  | %s%i _ => w%i_op.(znz_digits)" c i i;
-  done;
-  pr "  | %sn n _ => (make_op n).(znz_digits)" c;
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_digits: forall x, 0 <= [x] < 2 ^  Zpos (digits x).";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; clear x.";
-  for i = 0 to size do
-    pp "  intros x; unfold to_Z, digits;";
-    pp "   generalize (spec_to_Z w%i_spec x); unfold base; intros H; exact H." i;
-  done;
-  pp "  intros n x; unfold to_Z, digits;";
-  pp "   generalize (spec_to_Z (wn_spec n) x); unfold base; intros H; exact H.";
-  pp " Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                       Conversion                         *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  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 "    Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p))).";
-  pr " Proof.";
-  pr " intros p; unfold pheight.";
-  pr " assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1).";
-  pr "  intros x.";
-  pr "  assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith.";
-  pr "    rewrite <- inj_S.";
-  pr "    rewrite <- (fun x => S_pred x 0); auto with zarith.";
-  pr "    rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto.";
-  pr "    apply lt_le_trans with 1%snat; auto with zarith." "%";
-  pr "    exact (le_Pmult_nat x 1).";
-  pr "  rewrite F1; clear F1.";
-  pr " assert (F2:= (get_height_correct (znz_digits w0_op) (plength p))).";
-  pr " apply Zlt_le_trans with (Zpos (Psucc p)).";
-  pr "   rewrite Zpos_succ_morphism; auto with zarith.";
-  pr "  apply Zle_trans with (1 := plength_pred_correct (Psucc p)).";
-  pr " rewrite Ppred_succ.";
-  pr " apply Zpower_le_monotone; auto with zarith.";
-  pr " Qed.";
-  pr "";
-
-  pr " Definition of_pos x :=";
-  pr "  let h := pheight x in";
-  pr "  match h with";
-  for i = 0 to size do
-    pr "  | %i%snat => reduce_%i (snd (w%i_op.(znz_of_pos) x))" i "%" i i;
-  done;
-  pr "  | _ =>";
-  pr "    let n := minus h %i in" (size + 1);
-  pr "    reduce_n n (snd ((make_op n).(znz_of_pos) x))";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_of_pos: forall x,";
-  pr "   [of_pos x] = Zpos x.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " assert (F := spec_more_than_1_digit w0_spec).";
-  pp " intros x; unfold of_pos; case_eq (pheight x).";
-  for i = 0 to size do
-    if i <> 0 then
-      pp " intros n; case n; clear n.";
-    pp " intros H1; rewrite spec_reduce_%i; unfold to_Z." i;
-    pp " apply (znz_of_pos_correct w%i_spec)." i;
-    pp " apply Zlt_le_trans with (1 := pheight_correct x).";
-    pp "   rewrite H1; simpl Z_of_nat; change (2^%i) with (%s)." i (gen2 i);
-    pp "   unfold base.";
-    pp "   apply Zpower_le_monotone; split; auto with zarith.";
-    if i <> 0 then
-      begin
-        pp "   rewrite Zmult_comm; repeat rewrite <- Zmult_assoc.";
-        pp "     repeat rewrite <- Zpos_xO.";
-        pp "   refine (Zle_refl _).";
-      end;
-  done;
-  pp " intros n.";
-  pp " intros H1; rewrite spec_reduce_n; unfold to_Z.";
-  pp " simpl minus; rewrite <- minus_n_O.";
-  pp " apply (znz_of_pos_correct (wn_spec n)).";
-  pp " apply Zlt_le_trans with (1 := pheight_correct x).";
-  pp "   unfold base.";
-  pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp "   split; auto with zarith.";
-  pp "   rewrite H1.";
-  pp "  elim n; clear n H1.";
-  pp "   simpl Z_of_nat; change (2^%i) with (%s)." (size + 1) (gen2 (size + 1));
-  pp "   rewrite Zmult_comm; repeat rewrite <- Zmult_assoc.";
-  pp "     repeat rewrite <- Zpos_xO.";
-  pp "   refine (Zle_refl _).";
-  pp "  intros n Hrec.";
-  pp "  rewrite make_op_S.";
-  pp "  change (@znz_digits (word _ (S (S n))) (mk_zn2z_op_karatsuba (make_op n))) with";
-  pp "    (xO (znz_digits (make_op n))).";
-  pp "  rewrite (fun x y => (Zpos_xO (@znz_digits x y))).";
-  pp "  rewrite inj_S; unfold Zsucc.";
-  pp "  rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.";
-  pp "  rewrite Zpower_1_r.";
-  pp "  assert (tmp: forall x y z, x * (y * z) = y * (x * z));";
-  pp "   [intros; ring | rewrite tmp; clear tmp].";
-  pp "  apply Zmult_le_compat_l; auto with zarith.";
-  pp "  Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (** *                       Shift                              *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr "";
-
-  (* Head0 *)
-  pr " Definition head0 w := match w with";
-  for i = 0 to size do
-    pr " | %s%i w=> reduce_%i (w%i_op.(znz_head0) w)"  c i i i;
-  done;
-  pr " | %sn n w=> reduce_n n ((make_op n).(znz_head0) w)" c;
-  pr " end.";
-  pr "";
-
-  pr " Theorem spec_head00: forall x, [x] = 0 ->[head0 x] = Zpos (digits x).";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; unfold head0; clear x.";
-  for i = 0 to size do
-    pp "   intros x; rewrite spec_reduce_%i; exact (spec_head00 w%i_spec x)." i i;
-  done;
-  pp " intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x).";
-  pp " Qed.";
-  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 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 " 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.";
-  done;
-  pp " intros n x Hx; rewrite spec_reduce_n.";
-  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 " 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.";
-  pp " Qed.";
-  pr "";
-
-
-  (* Tail0 *)
-  pr " Definition tail0 w := match w with";
-  for i = 0 to size do
-    pr " | %s%i w=> reduce_%i (w%i_op.(znz_tail0) w)"  c i i i;
-  done;
-  pr " | %sn n w=> reduce_n n ((make_op n).(znz_tail0) w)" c;
-  pr " end.";
-  pr "";
-
-
-  pr " Theorem spec_tail00: forall x, [x] = 0 ->[tail0 x] = Zpos (digits x).";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; unfold tail0; clear x.";
-  for i = 0 to size do
-    pp "   intros x; rewrite spec_reduce_%i; exact (spec_tail00 w%i_spec x)." i i;
-  done;
-  pp " intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x).";
-  pp " Qed.";
-  pr "";
-
-
-  pr " Theorem spec_tail0: forall x,";
-  pr "   0 < [x] -> exists y, 0 <= y /\\ [x] = (2 * y + 1) * 2 ^ [tail0 x].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; clear x; unfold tail0.";
-  for i = 0 to size do
-    pp " intros x Hx; rewrite spec_reduce_%i; exact (spec_tail0 w%i_spec x Hx)." i  i;
-  done;
-  pp " intros n x Hx; rewrite spec_reduce_n; exact (spec_tail0 (wn_spec n) x Hx).";
-  pp " Qed.";
-  pr "";
-
-
-  (* Number of digits *)
-  pr " Definition %sdigits x :=" c;
-  pr "  match x with";
-  pr "  | %s0 _ => %s0 w0_op.(znz_zdigits)" c c;
-  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;
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x).";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; clear x; unfold Ndigits, digits.";
-  for i = 0 to size do
-    pp " intros _; try rewrite spec_reduce_%i; exact (spec_zdigits w%i_spec)." i i;
-  done;
-  pp " intros n _; try rewrite spec_reduce_n; exact (spec_zdigits (wn_spec n)).";
-  pp " Qed.";
-  pr "";
-
-
-  (* Shiftr *)
-  for i = 0 to size do
-    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 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 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 (unsafe_shiftr%i n x))" i i;
-  done;
-  pr "           (fun n p x => reduce_n n (unsafe_shiftrn n p x)).";
-  pr "";
-
-
-  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).";
-  pp "   intros; ring.";
-  pp " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z).";
-  pp "   intros x y z HH HH1 HH2.";
-  pp "   split; auto with zarith.";
-  pp "   apply Zle_lt_trans with (2 := HH2); auto with zarith.";
-  pp "   apply Zdiv_le_upper_bound; auto with zarith.";
-  pp "   pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith.";
-  pp "   apply Zmult_le_compat_l; auto.";
-  pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp "   rewrite Zpower_0_r; ring.";
-  pp "  assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x).";
-  pp "    intros xx y HH HH1.";
-  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 "         (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) ->";
-  pp "  znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->";
-  pp "  znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->";
-  pp "  znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->";
-  pp "  znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->";
-  pp "  znz_to_Z ww_op";
-  pp "  (znz_add_mul_div ww_op (znz_sub ww_op (znz_zdigits ww_op)  yy1)";
-  pp "     (znz_0 ww_op) xx1) = znz_to_Z ww1_op xx / 2 ^ znz_to_Z ww2_op yy).";
-  pp "  intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy.";
-  pp "     case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2.";
-  pp "     case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4.";
-  pp "     rewrite <- Hx.";
-  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 "                    yy1)";
-  pp "                ).";
-  pp "     rewrite (spec_0 Hw).";
-  pp "     rewrite Zmult_0_l; rewrite Zplus_0_l.";
-  pp "     rewrite (CyclicAxioms.spec_sub Hw).";
-  pp "     rewrite Zmod_small; auto with zarith.";
-  pp "     rewrite (spec_zdigits Hw).";
-  pp "     rewrite F0.";
-  pp "     rewrite Zmod_small; auto with zarith.";
-  pp "     unfold base; rewrite (spec_zdigits Hw) in Hl1 |- *;";
-  pp "      auto with zarith.";
-  pp "  assert (F5: forall n m, (n <= m)%snat ->" "%";
-  pp "     Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))).";
-  pp "    intros n m HH; elim HH; clear m HH; auto with zarith.";
-  pp "    intros m HH Hrec; apply Zle_trans with (1 := Hrec).";
-  pp "    rewrite make_op_S.";
-  pp "    match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end.";
-  pp "    rewrite Zpos_xO.";
-  pp "    assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith.";
-  pp "  assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n)))." size;
-  pp "    intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))).";
-  pp "    change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size;
-  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 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 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;
-      pp "       rewrite (spec_zdigits w%i_spec)." j;
-      pp "       change (znz_digits w%i_op) with %s." i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)"));
-      pp "       repeat rewrite (fun x => Zpos_xO (xO x)).";
-      pp "       repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)).";
-      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 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 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 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
-      begin
-        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;
-        pp "       rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto." size i size;
-      end
-  done;
-  pp "    intros n x y; case y; clear y;";
-  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;
-    pp "       rewrite (spec_zdigits w%i_spec)." i;
-    pp "       rewrite (spec_zdigits (wn_spec n)).";
-    pp "       apply Zle_trans with (2 := F6 n).";
-    pp "       change (znz_digits w%i_op) with %s." size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)"));
-    pp "       repeat rewrite (fun x => Zpos_xO (xO x)).";
-    pp "       repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)).";
-    pp "       assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith." i;
-    if i == size then
-      pp "       change ([Nn n (extend%i n y)] = [N%i y])." size i
-    else
-      pp "       change ([Nn n (extend%i n (extend%i %i y))] = [N%i y])." size i (size - i - 1) i;
-    pp "       rewrite <- (spec_extend%in n); auto." size;
-    if i <> size then
-      pp "       try (rewrite <- spec_extend%in%i; auto)." i size;
-  done;
-  pp "     generalize y; clear y; intros m y.";
-  pp "     rewrite spec_reduce_n; unfold to_Z; intros H1.";
-  pp "       apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith.";
-  pp "     rewrite (spec_zdigits (wn_spec m)).";
-  pp "     rewrite (spec_zdigits (wn_spec (Max.max n m))).";
-  pp "     apply F5; auto with arith.";
-  pp "     exact (spec_cast_r n m y).";
-  pp "     exact (spec_cast_l n m x).";
-  pp " Qed.";
-  pr "";
-
-  (* Unsafe_Shiftl *)
-  for i = 0 to size do
-    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 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 (unsafe_shiftl%i n x))" i i;
-  done;
-  pr "           (fun n p x => reduce_n n (unsafe_shiftln n p x)).";
-  pr "";
-  pr "";
-
-
-  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).";
-  pp "   intros; ring.";
-  pp " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z).";
-  pp "   intros x y z HH HH1 HH2.";
-  pp "   split; auto with zarith.";
-  pp "   apply Zle_lt_trans with (2 := HH2); auto with zarith.";
-  pp "   apply Zdiv_le_upper_bound; auto with zarith.";
-  pp "   pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith.";
-  pp "   apply Zmult_le_compat_l; auto.";
-  pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp "   rewrite Zpower_0_r; ring.";
-  pp "  assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x).";
-  pp "    intros xx y HH HH1.";
-  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 "         (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) ->";
-  pp "  znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->";
-  pp "  znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->";
-  pp "  znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->";
-  pp "  znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->";
-  pp "  znz_to_Z ww_op";
-  pp "  (znz_add_mul_div ww_op yy1";
-  pp "     xx1 (znz_0 ww_op)) = znz_to_Z ww1_op xx * 2 ^ znz_to_Z ww2_op yy).";
-  pp "  intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy.";
-  pp "     case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2.";
-  pp "     case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4.";
-  pp "     rewrite <- Hx.";
-  pp "     rewrite <- Hy.";
-  pp "     generalize (spec_add_mul_div Hw xx1 (znz_0 ww_op) yy1).";
-  pp "     rewrite (spec_0 Hw).";
-  pp "     assert (F1: znz_to_Z ww1_op (znz_head0 ww1_op xx) <= Zpos (znz_digits ww1_op)).";
-  pp "     case (Zle_lt_or_eq _ _ HH1); intros HH5.";
-  pp "     apply Zlt_le_weak.";
-  pp "     case (CyclicAxioms.spec_head0 Hw1 xx).";
-  pp "       rewrite <- Hx; auto.";
-  pp "     intros _ Hu; unfold base in Hu.";
-  pp "     case (Zle_or_lt (Zpos (znz_digits ww1_op))";
-  pp "                     (znz_to_Z ww1_op (znz_head0 ww1_op xx))); auto; intros H1.";
-  pp "     absurd (2 ^  (Zpos (znz_digits ww1_op)) <= 2 ^ (znz_to_Z ww1_op (znz_head0 ww1_op xx))).";
-  pp "       apply Zlt_not_le.";
-  pp "       case (spec_to_Z Hw1 xx); intros HHx3 HHx4.";
-  pp "       rewrite <- (Zmult_1_r (2 ^ znz_to_Z ww1_op (znz_head0 ww1_op xx))).";
-  pp "       apply Zle_lt_trans with (2 := Hu).";
-  pp "       apply Zmult_le_compat_l; auto with zarith.";
-  pp "     apply Zpower_le_monotone; auto with zarith.";
-  pp "     rewrite (CyclicAxioms.spec_head00 Hw1 xx); auto with zarith.";
-  pp "     rewrite Zdiv_0_l; auto with zarith.";
-  pp "     rewrite Zplus_0_r.";
-  pp "     case (Zle_lt_or_eq _ _ HH1); intros HH5.";
-  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 "     apply Zle_trans with (2 := Hl1); auto.";
-  pp "     rewrite  (spec_zdigits Hw1); auto with zarith.";
-  pp "     split; auto with zarith .";
-  pp "     apply Zlt_le_trans with (base (znz_digits ww1_op)).";
-  pp "     rewrite Hx.";
-  pp "     case (CyclicAxioms.spec_head0 Hw1 xx); auto.";
-  pp "       rewrite <- Hx; auto.";
-  pp "     intros _ Hu; rewrite Zmult_comm in Hu.";
-  pp "     apply Zle_lt_trans with (2 := Hu).";
-  pp "     apply Zmult_le_compat_l; auto with zarith.";
-  pp "     apply Zpower_le_monotone; auto with zarith.";
-  pp "     unfold base; apply Zpower_le_monotone; auto with zarith.";
-  pp "     split; auto with zarith.";
-  pp "     rewrite <- (spec_zdigits Hw); auto with zarith.";
-  pp "     rewrite <- (spec_zdigits Hw1); auto with zarith.";
-  pp "     rewrite <- HH5.";
-  pp "     rewrite Zmult_0_l.";
-  pp "     rewrite Zmod_small; auto with zarith.";
-  pp "     intros HH; apply HH.";
-  pp "     rewrite Hy; apply Zle_trans with (1 := Hl).";
-  pp "     rewrite (CyclicAxioms.spec_head00 Hw1 xx); auto with zarith.";
-  pp "     rewrite <- (spec_zdigits Hw); auto with zarith.";
-  pp "     rewrite <- (spec_zdigits Hw1); auto with zarith.";
-  pp "  assert (F5: forall n m, (n <= m)%snat ->" "%";
-  pp "     Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))).";
-  pp "    intros n m HH; elim HH; clear m HH; auto with zarith.";
-  pp "    intros m HH Hrec; apply Zle_trans with (1 := Hrec).";
-  pp "    rewrite make_op_S.";
-  pp "    match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end.";
-  pp "    rewrite Zpos_xO.";
-  pp "    assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith.";
-  pp "  assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n)))." size;
-  pp "    intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))).";
-  pp "    change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size;
-  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 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 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;
-      pp "       rewrite (spec_zdigits w%i_spec)." j;
-      pp "       change (znz_digits w%i_op) with %s." i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)"));
-      pp "       repeat rewrite (fun x => Zpos_xO (xO x)).";
-      pp "       repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)).";
-      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 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 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 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
-      begin
-        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;
-        pp "       rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto." size i size;
-      end
-  done;
-  pp "    intros n x y; case y; clear y;";
-  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;
-    pp "       rewrite (spec_zdigits w%i_spec)." i;
-    pp "       rewrite (spec_zdigits (wn_spec n)).";
-    pp "       apply Zle_trans with (2 := F6 n).";
-    pp "       change (znz_digits w%i_op) with %s." size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)"));
-    pp "       repeat rewrite (fun x => Zpos_xO (xO x)).";
-    pp "       repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)).";
-    pp "       assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith." i;
-    if i == size then
-      pp "       change ([Nn n (extend%i n y)] = [N%i y])." size i
-    else
-      pp "       change ([Nn n (extend%i n (extend%i %i y))] = [N%i y])." size i (size - i - 1) i;
-    pp "       rewrite <- (spec_extend%in n); auto." size;
-    if i <> size then
-      pp "       try (rewrite <- spec_extend%in%i; auto)." i size;
-  done;
-  pp "     generalize y; clear y; intros m y.";
-  pp "     repeat rewrite spec_reduce_n; unfold to_Z; intros H1.";
-  pp "       apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith.";
-  pp "     rewrite (spec_zdigits (wn_spec m)).";
-  pp "     rewrite (spec_zdigits (wn_spec (Max.max n m))).";
-  pp "     apply F5; auto with arith.";
-  pp "     exact (spec_cast_r n m y).";
-  pp "     exact (spec_cast_l n m x).";
-  pp " Qed.";
-  pr "";
-
-  (* Double size *)
-  pr " Definition double_size w := match w with";
-  for i = 0 to size-1 do
-    pr " | %s%i x => %s%i (WW (znz_0 w%i_op) x)" c i c (i + 1) i;
-  done;
-  pr " | %s%i x => %sn 0 (WW (znz_0 w%i_op) x)" c size c size;
-  pr " | %sn n x => %sn (S n) (WW (znz_0 (make_op n)) x)" c c;
-  pr " end.";
-  pr "";
-
-  pr " Theorem spec_double_size_digits:";
-  pr "   forall x, digits (double_size x) = xO (digits x).";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; unfold double_size, digits; clear x; auto.";
-  pp " intros n x; rewrite make_op_S; auto.";
-  pp " Qed.";
-  pr "";
-
-
-  pr " Theorem spec_double_size: forall x, [double_size x] = [x].";
-  pa " Admitted.";
-  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 "     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;";
-  pp "     generalize (znz_to_Z_n n); simpl word.";
-  pp "     intros HH; rewrite HH; clear HH.";
-  pp "     generalize (spec_0 (wn_spec n)); simpl word.";
-  pp "     intros HH; rewrite HH; clear HH; auto with zarith.";
-  pp " Qed.";
-  pr "";
-
-
-  pr " Theorem spec_double_size_head0:";
-  pr "   forall x, 2 * [head0 x] <= [head0 (double_size x)].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x.";
-  pp " assert (F1:= spec_pos (head0 x)).";
-  pp " assert (F2: 0 < Zpos (digits x)).";
-  pp "   red; auto.";
-  pp " case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH.";
-  pp " generalize HH; rewrite <- (spec_double_size x); intros HH1.";
-  pp " case (spec_head0 x HH); intros _ HH2.";
-  pp " case (spec_head0 _ HH1).";
-  pp " rewrite (spec_double_size x); rewrite (spec_double_size_digits x).";
-  pp " intros HH3 _.";
-  pp " case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4.";
-  pp " absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto.";
-  pp " apply Zle_not_lt.";
-  pp " apply Zmult_le_compat_r; auto with zarith.";
-  pp " apply Zpower_le_monotone; auto; auto with zarith.";
-  pp " generalize (spec_pos (head0 (double_size x))); auto with zarith.";
-  pp " assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)).";
-  pp "   case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5.";
-  pp "   apply Zmult_le_reg_r with (2 ^ 1); auto with zarith.";
-  pp "   rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith.";
-  pp "   assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp].";
-  pp "   apply Zle_trans with (2 := Zlt_le_weak _ _ HH2).";
-  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 "   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.";
-  pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp " rewrite (Zmult_comm 2).";
-  pp " rewrite Zpower_mult; auto with zarith.";
-  pp " rewrite Zpower_2.";
-  pp " apply Zlt_le_trans with (2 := HH3).";
-  pp " rewrite <- Zmult_assoc.";
-  pp " replace (Zpos (xO (digits x)) - 1) with";
-  pp "   ((Zpos (digits x) - 1) + (Zpos (digits x))).";
-  pp " rewrite Zpower_exp; auto with zarith.";
-  pp " apply Zmult_lt_compat2; auto with zarith.";
-  pp " split; auto with zarith.";
-  pp " apply Zmult_lt_0_compat; auto with zarith.";
-  pp " rewrite Zpos_xO; ring.";
-  pp " apply Zlt_le_weak; auto.";
-  pp " repeat rewrite spec_head00; auto.";
-  pp " rewrite spec_double_size_digits.";
-  pp " rewrite Zpos_xO; auto with zarith.";
-  pp " rewrite spec_double_size; auto.";
-  pp " Qed.";
-  pr "";
-
-  pr " Theorem spec_double_size_head0_pos:";
-  pr "   forall x, 0 < [head0 (double_size x)].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x.";
-  pp " assert (F: 0 < Zpos (digits x)).";
-  pp "  red; auto.";
-  pp " case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0.";
-  pp " case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1.";
-  pp "   apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith.";
-  pp " case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3.";
-  pp " generalize F3; rewrite <- (spec_double_size x); intros F4.";
-  pp " absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))).";
-  pp "   apply Zle_not_lt.";
-  pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp "   split; auto with zarith.";
-  pp "   rewrite Zpos_xO; auto with zarith.";
-  pp " case (spec_head0 x F3).";
-  pp " rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH.";
-  pp " apply Zle_lt_trans with (2 := HH).";
-  pp " case (spec_head0 _ F4).";
-  pp " rewrite (spec_double_size x); rewrite (spec_double_size_digits x).";
-  pp " rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto.";
-  pp " generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith.";
-  pp " Qed.";
-  pr "";
-
-  (* even *)
-  pr " Definition is_even x :=";
-  pr "  match x with";
-  for i = 0 to size do
-    pr "  | %s%i wx => w%i_op.(znz_is_even) wx" c i i
-  done;
-  pr "  | %sn n wx => (make_op n).(znz_is_even) wx" c;
-  pr "  end.";
-  pr "";
-
-
-  pr " Theorem spec_is_even: forall x,";
-  pr "   if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x; unfold is_even, to_Z; clear x.";
-  for i = 0 to size do
-    pp "   intros x; exact (spec_is_even w%i_spec x)." i;
-  done;
-  pp "  intros n x; exact (spec_is_even (wn_spec n) x).";
-  pp " Qed.";
-  pr "";
-
-  pr "End Make.";
-  pr "";
-
+  pr "  Eval lazy beta iota delta [reduce_n] in";
+  pr "   reduce_n _ _ (N0 zero0) reduce_%i Nn n." (size + 1);
+  pr "";
+
+pr " Definition reduce n : dom_t n -> t :=";
+pr "  match n with";
+for i = 0 to size do
+pr "   | %i => reduce_%i" i i;
+done;
+pr "   | %s(S n) => reduce_n n" (if size=0 then "" else "SizePlus ");
+pr "  end.";
+pr "";
+
+pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ",");
+
+pr "
+ Ltac solve_red :=
+ let H := fresh in let G := fresh in
+ match goal with
+  | |- ?P (S ?n) => assert (H:P n) by solve_red
+  | _ => idtac
+ end;
+ intros n G x; destruct (le_lt_eq_dec _ _ G) as [LT|EQ];
+ solve [
+  apply (H _ (lt_n_Sm_le _ _ LT)) |
+  inversion LT |
+  subst; change (reduce 0 x = red_t 0 x); reflexivity |
+  specialize (H (pred n)); subst; destruct x;
+   [|unfold_red; rewrite H; auto]; reflexivity
+ ].
+
+ Lemma reduce_equiv : forall n x, n <= Size -> reduce n x = red_t n x.
+ Proof.
+ set (P N := forall n, n <= N -> forall x, reduce n x = red_t n x).
+ intros n x H. revert n H x. change (P Size). solve_red.
+ Qed.
+
+ Lemma spec_reduce_n : forall n x, [reduce_n n x] = [Nn n x].
+ Proof.
+ assert (H : forall x, reduce_%i x = red_t (SizePlus 1) x).
+  destruct x; [|unfold reduce_%i; rewrite (reduce_equiv Size)]; auto.
+ induction n.
+   intros. rewrite H. apply spec_red_t.
+ destruct x as [|xh xl].
+ simpl. rewrite make_op_S. exact ZnZ.spec_0.
+ fold word in *.
+ destruct xh; auto.
+ simpl reduce_n.
+ rewrite IHn.
+ rewrite spec_extend_WW; auto.
+ Qed.
+" (size+1) (size+1);
+
+pr
+" Lemma spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x.
+ Proof.
+ do_size (destruct n;
+       [intros; rewrite reduce_equiv;[apply spec_red_t|auto with arith]|]).
+ apply spec_reduce_n.
+ Qed.
+
+End Make.
+";
diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v
index cdd41647..4717d0b2 100644
--- a/theories/Numbers/Natural/BigN/Nbasic.v
+++ b/theories/Numbers/Natural/BigN/Nbasic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,9 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: Nbasic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import ZArith.
+Require Import ZArith Ndigits.
 Require Import BigNumPrelude.
 Require Import Max.
 Require Import DoubleType.
@@ -18,6 +16,26 @@ Require Import DoubleBase.
 Require Import CyclicAxioms.
 Require Import DoubleCyclic.
 
+Arguments mk_zn2z_ops [t] ops.
+Arguments mk_zn2z_ops_karatsuba [t] ops.
+Arguments mk_zn2z_specs [t ops] specs.
+Arguments mk_zn2z_specs_karatsuba [t ops] specs.
+Arguments ZnZ.digits [t] Ops.
+Arguments ZnZ.zdigits [t] Ops.
+
+Lemma Pshiftl_nat_Zpower : forall n p,
+  Zpos (Pos.shiftl_nat p n) = Zpos p * 2 ^ Z.of_nat n.
+Proof.
+ intros.
+ rewrite Z.mul_comm.
+ induction n. simpl; auto.
+ transitivity (2 * (2 ^ Z.of_nat n * Zpos p)).
+ rewrite <- IHn. auto.
+ rewrite Z.mul_assoc.
+ rewrite inj_S.
+ rewrite <- Z.pow_succ_r; auto with zarith.
+Qed.
+
 (* To compute the necessary height *)
 
 Fixpoint plength (p: positive) : positive :=
@@ -212,8 +230,8 @@ Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) :=
 
 End ExtendMax.
 
-Implicit Arguments extend_tr[w m].
-Implicit Arguments castm[w m n].
+Arguments extend_tr [w m] v n.
+Arguments castm     [w m n] H x.
 
 
 
@@ -287,11 +305,7 @@ Section CompareRec.
  Variable w_to_Z: w -> Z.
  Variable w_to_Z_0: w_to_Z w_0 = 0.
  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
-    | Gt => w_to_Z w_0 > wm_to_Z x
-    end.
+   compare0_m x = (w_to_Z w_0 ?= wm_to_Z x).
  Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base.
 
  Let double_to_Z := double_to_Z wm_base wm_to_Z.
@@ -308,29 +322,25 @@ Section CompareRec.
 
 
  Lemma spec_compare0_mn: forall n x,
-    match compare0_mn n x with
-      Eq => 0 = double_to_Z n x
-    | Lt => 0 < double_to_Z n x
-    | Gt => 0 > double_to_Z n x
-    end.
-  Proof.
+   compare0_mn n x = (0 ?= double_to_Z n x).
+ Proof.
   intros n; elim n; clear n; auto.
-  intros x; generalize (spec_compare0_m x); rewrite w_to_Z_0; auto.
+  intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto.
   intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto.
+  fold word in *.
   intros xh xl.
-  generalize (Hrec xh); case compare0_mn; auto.
-  generalize (Hrec xl); case compare0_mn; auto.
-  simpl double_to_Z; intros H1 H2; rewrite H1; rewrite <- H2; auto.
-  simpl double_to_Z; intros H1 H2; rewrite <- H2; auto.
-  case (double_to_Z_pos n xl); auto with zarith.
-  intros H1; simpl double_to_Z.
-  set (u := DoubleBase.double_wB wm_base n).
-  case (double_to_Z_pos n xl); intros H2 H3.
-  assert (0 < u); auto with zarith.
-  unfold u, DoubleBase.double_wB, base; auto with zarith.
+  rewrite 2 Hrec.
+  simpl double_to_Z.
+  set (wB := DoubleBase.double_wB wm_base n).
+  case Zcompare_spec; intros Cmp.
+  rewrite <- Cmp. reflexivity.
+  symmetry. apply Zgt_lt, Zlt_gt. (* ;-) *)
+  assert (0 < wB).
+   unfold wB, DoubleBase.double_wB, base; auto with zarith.
   change 0 with (0 + 0); apply Zplus_lt_le_compat; auto with zarith.
   apply Zmult_lt_0_compat; auto with zarith.
-  case (double_to_Z_pos n xh); auto with zarith.
+  case (double_to_Z_pos n xl); auto with zarith.
+  case (double_to_Z_pos n xh); intros; exfalso; omega.
   Qed.
 
  Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
@@ -348,17 +358,9 @@ Section CompareRec.
   end.
 
  Variable spec_compare: forall x y,
-   match compare x y with
-     Eq => w_to_Z x = w_to_Z y
-   | Lt => w_to_Z x < w_to_Z y
-   | Gt => w_to_Z x > w_to_Z y
-   end.
+   compare x y = Zcompare (w_to_Z x) (w_to_Z y).
  Variable spec_compare_m: forall x y,
-   match compare_m x y with
-     Eq => wm_to_Z x = w_to_Z y
-   | Lt => wm_to_Z x < w_to_Z y
-   | Gt => wm_to_Z x > w_to_Z y
-   end.
+   compare_m x y = Zcompare (wm_to_Z x) (w_to_Z y).
  Variable wm_base_lt: forall x,
    0 <= w_to_Z x < base (wm_base).
 
@@ -369,8 +371,8 @@ Section CompareRec.
  intros n (H0, H); split; auto.
  apply Zlt_le_trans with (1:= H).
  unfold double_wB, DoubleBase.double_wB; simpl.
- rewrite base_xO.
- set (u := base (double_digits wm_base n)).
+ rewrite Pshiftl_nat_S, base_xO.
+ set (u := base (Pos.shiftl_nat wm_base n)).
  assert (0 < u).
   unfold u, base; auto with zarith.
  replace (u^2) with (u * u); simpl; auto with zarith.
@@ -380,26 +382,23 @@ Section CompareRec.
 
 
  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
-   | Lt => double_to_Z n x < w_to_Z y
-   | Gt => double_to_Z n x > w_to_Z y
-   end.
+   compare_mn_1 n x y = Zcompare (double_to_Z n x) (w_to_Z y).
  Proof.
  intros n; elim n; simpl; auto; clear n.
  intros n Hrec x; case x; clear x; auto.
- intros y; generalize (spec_compare w_0 y); rewrite w_to_Z_0; case compare; auto.
- intros xh xl y; simpl; generalize (spec_compare0_mn n xh); case compare0_mn; intros H1b.
+ intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity.
+ intros xh xl y; simpl;
+ rewrite spec_compare0_mn, Hrec. case Zcompare_spec.
+ intros H1b.
  rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
- apply Hrec.
- apply Zlt_gt.
+ symmetry. apply Zlt_gt.
  case (double_wB_lt n y); intros _ H0.
  apply Zlt_le_trans with (1:= H0).
  fold double_wB.
  case (double_to_Z_pos n xl); intros H1 H2.
  apply Zle_trans with (double_to_Z n xh * double_wB n); auto with zarith.
  apply Zle_trans with (1 * double_wB n); auto with zarith.
- case (double_to_Z_pos n xh); auto with zarith.
+ case (double_to_Z_pos n xh); intros; exfalso; omega.
  Qed.
 
 End CompareRec.
@@ -433,22 +432,6 @@ Section AddS.
 
 End AddS.
 
-
- Lemma spec_opp: forall u x y,
-  match u with
-  | Eq => y = x
-  | Lt => y < x
-  | Gt => y > x
-  end ->
-  match CompOpp u with
-  | Eq => x = y
-  | Lt => x < y
-  | Gt => x > y
-  end.
- Proof.
- intros u x y; case u; simpl; auto with zarith.
- Qed.
-
  Fixpoint length_pos x :=
   match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end.
 
@@ -474,34 +457,112 @@ End AddS.
 
  Variable w: Type.
 
- Theorem digits_zop: forall w (x: znz_op w),
-  znz_digits (mk_zn2z_op x) = xO (znz_digits x).
+ Theorem digits_zop: forall t (ops : ZnZ.Ops t),
+  ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops).
+ Proof.
  intros ww x; auto.
  Qed.
 
- Theorem digits_kzop: forall w (x: znz_op w),
-  znz_digits (mk_zn2z_op_karatsuba x) = xO (znz_digits x).
+ Theorem digits_kzop: forall t (ops : ZnZ.Ops t),
+  ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops).
+ Proof.
  intros ww x; auto.
  Qed.
 
- Theorem make_zop: forall w (x: znz_op w),
-  znz_to_Z (mk_zn2z_op x) =
+ Theorem make_zop: forall t (ops : ZnZ.Ops t),
+  @ZnZ.to_Z _ (mk_zn2z_ops ops) =
     fun z => match z with
-                W0 => 0
-             | WW xh xl => znz_to_Z x xh * base (znz_digits x)
-                                + znz_to_Z x xl
+             | W0 => 0
+             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
+                                + ZnZ.to_Z xl
              end.
+ Proof.
  intros ww x; auto.
  Qed.
 
- Theorem make_kzop: forall w (x: znz_op w),
-  znz_to_Z (mk_zn2z_op_karatsuba x) =
+ Theorem make_kzop: forall t (ops: ZnZ.Ops t),
+  @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) =
     fun z => match z with
-                W0 => 0
-             | WW xh xl => znz_to_Z x xh * base (znz_digits x)
-                                + znz_to_Z x xl
+             | W0 => 0
+             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
+                                + ZnZ.to_Z xl
              end.
+ Proof.
  intros ww x; auto.
  Qed.
 
  End SimplOp.
+
+(** Abstract vision of a datatype of arbitrary-large numbers.
+    Concrete operations can be derived from these generic
+    fonctions, in particular from [iter_t] and [same_level].
+*)
+
+Module Type NAbstract.
+
+(** The domains: a sequence of [Z/nZ] structures *)
+
+Parameter dom_t : nat -> Type.
+Declare Instance dom_op n : ZnZ.Ops (dom_t n).
+Declare Instance dom_spec n : ZnZ.Specs (dom_op n).
+
+Axiom digits_dom_op : forall n,
+  ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op 0)) n.
+
+(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t]
+    and destructor [destr_t] and iterator [iter_t] *)
+
+Parameter t : Type.
+
+Parameter mk_t : forall (n:nat), dom_t n -> t.
+
+Inductive View_t : t -> Prop :=
+ Mk_t : forall n (x : dom_t n), View_t (mk_t n x).
+
+Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *)
+
+Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A.
+
+Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A),
+ forall n x, iter_t f (mk_t n x) = f n x.
+
+(** Conversion to [ZArith] *)
+
+Parameter to_Z : t -> Z.
+Local Notation "[ x ]" := (to_Z x).
+
+Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x.
+
+(** [reduce] is like [mk_t], but try to minimise the level of the number *)
+
+Parameter reduce : forall (n:nat), dom_t n -> t.
+Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x.
+
+(** Number of level in the tree representation of a number.
+    NB: This function isn't a morphism for setoid [eq]. *)
+
+Definition level := iter_t (fun n _ => n).
+
+(** [same_level] and its rich specification, indexed by [level] *)
+
+Parameter same_level : forall {A:Type}
+ (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A.
+
+Axiom spec_same_level_dep :
+  forall res
+   (P : nat -> Z -> Z -> res -> Prop)
+   (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r)
+   (f : forall n, dom_t n -> dom_t n -> res)
+   (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)),
+   forall x y, P (level x) [x] [y] (same_level f x y).
+
+(** [mk_t_S] : building a number of the next level *)
+
+Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t.
+
+Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)),
+  [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.
+
+Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n.
+
+End NAbstract.
diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v
index 029fdfca..43ca67dd 100644
--- a/theories/Numbers/Natural/Binary/NBinary.v
+++ b/theories/Numbers/Natural/Binary/NBinary.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,150 +8,15 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NBinary.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 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.
+(** * [BinNat.N] already implements [NAxiomSig] *)
 
-Module Export NBinaryPropMod := NPropFunct NBinaryAxiomsMod.
+Module N <: NAxiomsSig := N.
 
 (*
 Require Import NDefOps.
diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index fbc63c04..d5df6329 100644
--- a/theories/Numbers/Natural/Peano/NPeano.v
+++ b/theories/Numbers/Natural/Peano/NPeano.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,13 +8,571 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NPeano.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Import
+ Bool Peano Peano_dec Compare_dec Plus Mult Minus Le Lt EqNat Div2 Wf_nat
+ NAxioms NProperties.
 
-Require Import Arith MinMax NAxioms NProperties.
+(** Functions not already defined *)
+
+Fixpoint leb n m :=
+  match n, m with
+    | O, _ => true
+    | _, O => false
+    | S n', S m' => leb n' m'
+  end.
+
+Definition ltb n m := leb (S n) m.
+
+Infix "<=?" := leb (at level 70) : nat_scope.
+Infix "<?" := ltb (at level 70) : nat_scope.
+
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
+Proof.
+ revert m.
+ induction n. split; auto with arith.
+ destruct m; simpl. now split.
+ rewrite IHn. split; auto with arith.
+Qed.
+
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
+Proof.
+ unfold ltb, lt. apply leb_le.
+Qed.
+
+Fixpoint pow n m :=
+  match m with
+    | O => 1
+    | S m => n * (pow n m)
+  end.
+
+Infix "^" := pow : nat_scope.
+
+Lemma pow_0_r : forall a, a^0 = 1.
+Proof. reflexivity. Qed.
+
+Lemma pow_succ_r : forall a b, 0<=b -> a^(S b) = a * a^b.
+Proof. reflexivity. Qed.
+
+Definition square n := n * n.
+
+Lemma square_spec n : square n = n * n.
+Proof. reflexivity. Qed.
+
+Definition Even n := exists m, n = 2*m.
+Definition Odd n := exists m, n = 2*m+1.
+
+Fixpoint even n :=
+  match n with
+    | O => true
+    | 1 => false
+    | S (S n') => even n'
+  end.
+
+Definition odd n := negb (even n).
+
+Lemma even_spec : forall n, even n = true <-> Even n.
+Proof.
+ fix 1.
+  destruct n as [|[|n]]; simpl; try rewrite even_spec; split.
+  now exists 0.
+  trivial.
+  discriminate.
+  intros (m,H). destruct m. discriminate.
+   simpl in H. rewrite <- plus_n_Sm in H. discriminate.
+  intros (m,H). exists (S m). rewrite H. simpl. now rewrite plus_n_Sm.
+  intros (m,H). destruct m. discriminate. exists m.
+   simpl in H. rewrite <- plus_n_Sm in H. inversion H. reflexivity.
+Qed.
+
+Lemma odd_spec : forall n, odd n = true <-> Odd n.
+Proof.
+ unfold odd.
+ fix 1.
+  destruct n as [|[|n]]; simpl; try rewrite odd_spec; split.
+  discriminate.
+  intros (m,H). rewrite <- plus_n_Sm in H; discriminate.
+  now exists 0.
+  trivial.
+  intros (m,H). exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m).
+  intros (m,H). destruct m. discriminate. exists m.
+   simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl.
+   now rewrite <- !plus_n_Sm, <- !plus_n_O.
+Qed.
+
+Lemma Even_equiv : forall n, Even n <-> Even.even n.
+Proof.
+ split. intros (p,->). apply Even.even_mult_l. do 3 constructor.
+ intros H. destruct (even_2n n H) as (p,->).
+ exists p. unfold double. simpl. now rewrite <- plus_n_O.
+Qed.
+
+Lemma Odd_equiv : forall n, Odd n <-> Even.odd n.
+Proof.
+ split. intros (p,->). rewrite <- plus_n_Sm, <- plus_n_O.
+ apply Even.odd_S. apply Even.even_mult_l. do 3 constructor.
+ intros H. destruct (odd_S2n n H) as (p,->).
+ exists p. unfold double. simpl. now rewrite <- plus_n_Sm, <- !plus_n_O.
+Qed.
+
+(* A linear, tail-recursive, division for nat.
+
+   In [divmod], [y] is the predecessor of the actual divisor,
+   and [u] is [y] minus the real remainder
+*)
+
+Fixpoint divmod x y q u :=
+  match x with
+    | 0 => (q,u)
+    | S x' => match u with
+                | 0 => divmod x' y (S q) y
+                | S u' => divmod x' y q u'
+              end
+  end.
+
+Definition div x y :=
+  match y with
+    | 0 => y
+    | S y' => fst (divmod x y' 0 y')
+  end.
+
+Definition modulo x y :=
+  match y with
+    | 0 => y
+    | S y' => y' - snd (divmod x y' 0 y')
+  end.
+
+Infix "/" := div : nat_scope.
+Infix "mod" := modulo (at level 40, no associativity) : nat_scope.
+
+Lemma divmod_spec : forall x y q u, u <= y ->
+ let (q',u') := divmod x y q u in
+ x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y.
+Proof.
+ induction x. simpl. intuition.
+ intros y q u H. destruct u; simpl divmod.
+ generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u').
+ intros (EQ,LE); split; trivial.
+ rewrite <- EQ, <- minus_n_O, minus_diag, <- plus_n_O.
+ now rewrite !plus_Sn_m, plus_n_Sm, <- plus_assoc, mult_n_Sm.
+ generalize (IHx y q u (le_Sn_le _ _ H)). destruct divmod as (q',u').
+ intros (EQ,LE); split; trivial.
+ rewrite <- EQ.
+ rewrite !plus_Sn_m, plus_n_Sm. f_equal. now apply minus_Sn_m.
+Qed.
+
+Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y.
+Proof.
+ intros x y Hy.
+ destruct y; [ now elim Hy | clear Hy ].
+ unfold div, modulo.
+ generalize (divmod_spec x y 0 y (le_n y)).
+ destruct divmod as (q,u).
+ intros (U,V).
+ simpl in *.
+ now rewrite <- mult_n_O, minus_diag, <- !plus_n_O in U.
+Qed.
+
+Lemma mod_bound_pos : forall x y, 0<=x -> 0<y -> 0 <= x mod y < y.
+Proof.
+ intros x y Hx Hy. split. auto with arith.
+ destruct y; [ now elim Hy | clear Hy ].
+ unfold modulo.
+ apply le_n_S, le_minus.
+Qed.
+
+(** Square root *)
+
+(** The following square root function is linear (and tail-recursive).
+  With Peano representation, we can't do better. For faster algorithm,
+  see Psqrt/Zsqrt/Nsqrt...
+
+  We search the square root of n = k + p^2 + (q - r)
+  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
+  looking for the square root of n = k. Then we progressively
+  decrease k and r. When k = S k' and r=0, it means we can use (S p)
+  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
+  When k reaches 0, we have found the biggest p^2 square contained
+  in n, hence the square root of n is p.
+*)
+
+Fixpoint sqrt_iter k p q r :=
+  match k with
+    | O => p
+    | S k' => match r with
+                | O => sqrt_iter k' (S p) (S (S q)) (S (S q))
+                | S r' => sqrt_iter k' p q r'
+              end
+  end.
+
+Definition sqrt n := sqrt_iter n 0 0 0.
+
+Lemma sqrt_iter_spec : forall k p q r,
+ q = p+p -> r<=q ->
+ let s := sqrt_iter k p q r in
+ s*s <= k + p*p + (q - r) < (S s)*(S s).
+Proof.
+ induction k.
+ (* k = 0 *)
+ simpl; intros p q r Hq Hr.
+ split.
+ apply le_plus_l.
+ apply le_lt_n_Sm.
+ rewrite <- mult_n_Sm.
+ rewrite plus_assoc, (plus_comm p), <- plus_assoc.
+ apply plus_le_compat; trivial.
+ rewrite <- Hq. apply le_minus.
+ (* k = S k' *)
+ destruct r.
+ (* r = 0 *)
+ intros Hq _.
+ replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))).
+ apply IHk.
+ simpl. rewrite <- plus_n_Sm. congruence.
+ auto with arith.
+ rewrite minus_diag, <- minus_n_O, <- plus_n_O. simpl.
+ rewrite <- plus_n_Sm; f_equal. rewrite <- plus_assoc; f_equal.
+ rewrite <- mult_n_Sm, (plus_comm p), <- plus_assoc. congruence.
+ (* r = S r' *)
+ intros Hq Hr.
+ replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)).
+ apply IHk; auto with arith.
+ simpl. rewrite plus_n_Sm. f_equal. rewrite minus_Sn_m; auto.
+Qed.
+
+Lemma sqrt_spec : forall n,
+ (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n).
+Proof.
+ intros.
+ set (s:=sqrt n).
+ replace n with (n + 0*0 + (0-0)).
+ apply sqrt_iter_spec; auto.
+ simpl. now rewrite <- 2 plus_n_O.
+Qed.
+
+(** A linear tail-recursive base-2 logarithm
+
+  In [log2_iter], we maintain the logarithm [p] of the counter [q],
+  while [r] is the distance between [q] and the next power of 2,
+  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
+  recursive call, [q] goes up while [r] goes down. When [r]
+  is 0, we know that [q] has almost reached a power of 2,
+  and we increase [p] at the next call, while resetting [r]
+  to [q].
+
+  Graphically (numbers are [q], stars are [r]) :
+
+<<
+                    10
+                  9
+                8
+              7   *
+            6       *
+          5           ...
+        4
+      3   *
+    2       *
+  1   *       *
+0   *   *       *
+>>
+
+  We stop when [k], the global downward counter reaches 0.
+  At that moment, [q] is the number we're considering (since
+  [k+q] is invariant), and [p] its logarithm.
+*)
+
+Fixpoint log2_iter k p q r :=
+  match k with
+    | O => p
+    | S k' => match r with
+                | O => log2_iter k' (S p) (S q) q
+                | S r' => log2_iter k' p (S q) r'
+              end
+  end.
+
+Definition log2 n := log2_iter (pred n) 0 1 0.
+
+Lemma log2_iter_spec : forall k p q r,
+ 2^(S p) = q + S r -> r < 2^p ->
+ let s := log2_iter k p q r in
+ 2^s <= k + q < 2^(S s).
+Proof.
+ induction k.
+ (* k = 0 *)
+ intros p q r EQ LT. simpl log2_iter. cbv zeta.
+ split.
+ rewrite plus_O_n.
+ apply plus_le_reg_l with (2^p).
+ simpl pow in EQ. rewrite <- plus_n_O in EQ. rewrite EQ.
+ rewrite plus_comm. apply plus_le_compat_r. now apply lt_le_S.
+ rewrite EQ, plus_comm. apply plus_lt_compat_l. apply lt_0_Sn.
+ (* k = S k' *)
+ intros p q r EQ LT. destruct r.
+ (* r = 0 *)
+ rewrite <- plus_n_Sm, <- plus_n_O in EQ.
+ rewrite plus_Sn_m, plus_n_Sm. apply IHk.
+ rewrite <- EQ. remember (S p) as p'; simpl. now rewrite <- plus_n_O.
+ unfold lt. now rewrite EQ.
+ (* r = S r' *)
+ rewrite plus_Sn_m, plus_n_Sm. apply IHk.
+ now rewrite plus_Sn_m, plus_n_Sm.
+ unfold lt.
+ now apply lt_le_weak.
+Qed.
+
+Lemma log2_spec : forall n, 0<n ->
+ 2^(log2 n) <= n < 2^(S (log2 n)).
+Proof.
+ intros.
+ set (s:=log2 n).
+ replace n with (pred n + 1).
+ apply log2_iter_spec; auto.
+ rewrite <- plus_n_Sm, <- plus_n_O.
+ symmetry. now apply S_pred with 0.
+Qed.
+
+Lemma log2_nonpos : forall n, n<=0 -> log2 n = 0.
+Proof.
+ inversion 1; now subst.
+Qed.
+
+(** * Gcd *)
+
+(** We use Euclid algorithm, which is normally not structural,
+    but Coq is now clever enough to accept this (behind modulo
+    there is a subtraction, which now preserves being a subterm)
+*)
+
+Fixpoint gcd a b :=
+  match a with
+   | O => b
+   | S a' => gcd (b mod (S a')) (S a')
+  end.
+
+Definition divide x y := exists z, y=z*x.
+Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.
+
+Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b).
+Proof.
+ fix 1.
+ intros [|a] b; simpl.
+ split.
+  now exists 0.
+  exists 1. simpl. now rewrite <- plus_n_O.
+ fold (b mod (S a)).
+ destruct (gcd_divide (b mod (S a)) (S a)) as (H,H').
+ set (a':=S a) in *.
+ split; auto.
+ rewrite (div_mod b a') at 2 by discriminate.
+ destruct H as (u,Hu), H' as (v,Hv).
+ rewrite mult_comm.
+ exists ((b/a')*v + u).
+ rewrite mult_plus_distr_r.
+ now rewrite <- mult_assoc, <- Hv, <- Hu.
+Qed.
+
+Lemma gcd_divide_l : forall a b, (gcd a b | a).
+Proof.
+ intros. apply gcd_divide.
+Qed.
+
+Lemma gcd_divide_r : forall a b, (gcd a b | b).
+Proof.
+ intros. apply gcd_divide.
+Qed.
+
+Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b).
+Proof.
+ fix 1.
+ intros [|a] b; simpl; auto.
+ fold (b mod (S a)).
+ intros c H H'. apply gcd_greatest; auto.
+ set (a':=S a) in *.
+ rewrite (div_mod b a') in H' by discriminate.
+ destruct H as (u,Hu), H' as (v,Hv).
+ exists (v - (b/a')*u).
+ rewrite mult_comm in Hv.
+ now rewrite mult_minus_distr_r, <- Hv, <-mult_assoc, <-Hu, minus_plus.
+Qed.
+
+(** * Bitwise operations *)
+
+(** We provide here some bitwise operations for unary numbers.
+  Some might be really naive, they are just there for fullfiling
+  the same interface as other for natural representations. As
+  soon as binary representations such as NArith are available,
+  it is clearly better to convert to/from them and use their ops.
+*)
+
+Fixpoint testbit a n :=
+ match n with
+   | O => odd a
+   | S n => testbit (div2 a) n
+ end.
+
+Definition shiftl a n := iter_nat n _ double a.
+Definition shiftr a n := iter_nat n _ div2 a.
+
+Fixpoint bitwise (op:bool->bool->bool) n a b :=
+ match n with
+  | O => O
+  | S n' =>
+    (if op (odd a) (odd b) then 1 else 0) +
+    2*(bitwise op n' (div2 a) (div2 b))
+ end.
+
+Definition land a b := bitwise andb a a b.
+Definition lor a b := bitwise orb (max a b) a b.
+Definition ldiff a b := bitwise (fun b b' => b && negb b') a a b.
+Definition lxor a b := bitwise xorb (max a b) a b.
+
+Lemma double_twice : forall n, double n = 2*n.
+Proof.
+ simpl; intros. now rewrite <- plus_n_O.
+Qed.
+
+Lemma testbit_0_l : forall n, testbit 0 n = false.
+Proof.
+ now induction n.
+Qed.
+
+Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
+Proof.
+ unfold testbit. rewrite odd_spec. now exists a.
+Qed.
+
+Lemma testbit_even_0 a : testbit (2*a) 0 = false.
+Proof.
+ unfold testbit, odd. rewrite (proj2 (even_spec _)); trivial.
+ now exists a.
+Qed.
+
+Lemma testbit_odd_succ a n : testbit (2*a+1) (S n) = testbit a n.
+Proof.
+ unfold testbit; fold testbit.
+ rewrite <- plus_n_Sm, <- plus_n_O. f_equal.
+ apply div2_double_plus_one.
+Qed.
+
+Lemma testbit_even_succ a n : testbit (2*a) (S n) = testbit a n.
+Proof.
+ unfold testbit; fold testbit. f_equal. apply div2_double.
+Qed.
+
+Lemma shiftr_spec : forall a n m,
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ induction n; intros m. trivial.
+ now rewrite <- plus_n_O.
+ now rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn.
+Qed.
+
+Lemma shiftl_spec_high : forall a n m, n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ induction n; intros m H. trivial.
+ now rewrite <- minus_n_O.
+ destruct m. inversion H.
+ simpl. apply le_S_n in H.
+ change (shiftl a (S n)) with (double (shiftl a n)).
+ rewrite double_twice, div2_double. now apply IHn.
+Qed.
+
+Lemma shiftl_spec_low : forall a n m, m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ induction n; intros m H. inversion H.
+ change (shiftl a (S n)) with (double (shiftl a n)).
+ destruct m; simpl.
+ unfold odd. apply negb_false_iff.
+ apply even_spec. exists (shiftl a n). apply double_twice.
+ rewrite double_twice, div2_double. apply IHn.
+ now apply lt_S_n.
+Qed.
+
+Lemma div2_bitwise : forall op n a b,
+ div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b).
+Proof.
+ intros. unfold bitwise; fold bitwise.
+ destruct (op (odd a) (odd b)).
+ now rewrite div2_double_plus_one.
+ now rewrite plus_O_n, div2_double.
+Qed.
+
+Lemma odd_bitwise : forall op n a b,
+ odd (bitwise op (S n) a b) = op (odd a) (odd b).
+Proof.
+ intros. unfold bitwise; fold bitwise.
+ destruct (op (odd a) (odd b)).
+ apply odd_spec. rewrite plus_comm. eexists; eauto.
+ unfold odd. apply negb_false_iff. apply even_spec.
+ rewrite plus_O_n; eexists; eauto.
+Qed.
+
+Lemma div2_decr : forall a n, a <= S n -> div2 a <= n.
+Proof.
+ destruct a; intros. apply le_0_n.
+ apply le_trans with a.
+ apply lt_n_Sm_le, lt_div2, lt_0_Sn. now apply le_S_n.
+Qed.
+
+Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) ->
+ forall n m a b, a<=n ->
+ testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
+Proof.
+ intros op Hop.
+ induction n; intros m a b Ha.
+ simpl. inversion Ha; subst. now rewrite testbit_0_l.
+ destruct m.
+ apply odd_bitwise.
+ unfold testbit; fold testbit. rewrite div2_bitwise.
+ apply IHn; now apply div2_decr.
+Qed.
+
+Lemma testbit_bitwise_2 : forall op, op false false = false ->
+ forall n m a b, a<=n -> b<=n ->
+ testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
+Proof.
+ intros op Hop.
+ induction n; intros m a b Ha Hb.
+ simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l.
+ destruct m.
+ apply odd_bitwise.
+ unfold testbit; fold testbit. rewrite div2_bitwise.
+ apply IHn; now apply div2_decr.
+Qed.
+
+Lemma land_spec : forall a b n,
+ testbit (land a b) n = testbit a n && testbit b n.
+Proof.
+ intros. unfold land. apply testbit_bitwise_1; trivial.
+Qed.
+
+Lemma ldiff_spec : forall a b n,
+ testbit (ldiff a b) n = testbit a n && negb (testbit b n).
+Proof.
+ intros. unfold ldiff. apply testbit_bitwise_1; trivial.
+Qed.
+
+Lemma lor_spec : forall a b n,
+ testbit (lor a b) n = testbit a n || testbit b n.
+Proof.
+ intros. unfold lor. apply testbit_bitwise_2. trivial.
+ destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
+ destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
+Qed.
+
+Lemma lxor_spec : forall a b n,
+ testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
+Proof.
+ intros. unfold lxor. apply testbit_bitwise_2. trivial.
+ destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
+ destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
+Qed.
 
 (** * Implementation of [NAxiomsSig] by [nat] *)
 
-Module NPeanoAxiomsMod <: NAxiomsSig.
+Module Nat
+ <: NAxiomsSig <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder.
 
 (** Bi-directional induction. *)
 
@@ -40,6 +598,16 @@ Proof.
 reflexivity.
 Qed.
 
+Theorem one_succ : 1 = S 0.
+Proof.
+reflexivity.
+Qed.
+
+Theorem two_succ : 2 = S 1.
+Proof.
+reflexivity.
+Qed.
+
 Theorem add_0_l : forall n : nat, 0 + n = n.
 Proof.
 reflexivity.
@@ -57,7 +625,7 @@ Qed.
 
 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 sub_0_r.
+induction n; destruct m; simpl; auto. apply sub_0_r.
 Qed.
 
 Theorem mul_0_l : forall n : nat, 0 * n = 0.
@@ -67,49 +635,32 @@ Qed.
 
 Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m.
 Proof.
-intros n m; now rewrite plus_comm.
+assert (add_S_r : forall n m, n+S m = S(n+m)) by (induction n; auto).
+assert (add_comm : forall n m, n+m = m+n).
+ induction n; simpl; auto. intros; rewrite add_S_r; auto.
+intros n m; now rewrite add_comm.
 Qed.
 
 (** Order on natural numbers *)
 
 Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
 
-Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m.
-Proof.
-intros n m; split.
-apply le_lt_or_eq.
-intro H; destruct H as [H | H].
-now apply lt_le_weak. rewrite H; apply le_refl.
-Qed.
-
-Theorem lt_irrefl : forall n : nat, ~ (n < n).
-Proof.
-exact lt_irrefl.
-Qed.
-
 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].
+unfold lt; split. apply le_S_n. induction 1; auto.
 Qed.
 
-Theorem min_l : forall n m : nat, n <= m -> min n m = n.
-Proof.
-exact min_l.
-Qed.
-
-Theorem min_r : forall n m : nat, m <= n -> min n m = m.
-Proof.
-exact min_r.
-Qed.
 
-Theorem max_l : forall n m : nat, m <= n -> max n m = n.
+Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m.
 Proof.
-exact max_l.
+split.
+inversion 1; auto. rewrite lt_succ_r; auto.
+destruct 1; [|subst; auto]. rewrite <- lt_succ_r; auto.
 Qed.
 
-Theorem max_r : forall n m : nat, n <= m -> max n m = m.
+Theorem lt_irrefl : forall n : nat, ~ (n < n).
 Proof.
-exact max_r.
+induction n. intro H; inversion H. rewrite lt_succ_r; auto.
 Qed.
 
 (** Facts specific to natural numbers, not integers. *)
@@ -119,25 +670,26 @@ Proof.
 reflexivity.
 Qed.
 
-Definition recursion (A : Type) : A -> (nat -> A -> A) -> nat -> A :=
+(** Recursion fonction *)
+
+Definition recursion {A} : 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).
+Instance recursion_wd {A} (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
 Proof.
 intros a a' Ha f f' Hf n n' Hn. subst n'.
 induction n; simpl; auto. apply Hf; auto.
 Qed.
 
 Theorem recursion_0 :
-  forall (A : Type) (a : A) (f : nat -> A -> A), recursion a f 0 = a.
+  forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a.
 Proof.
 reflexivity.
 Qed.
 
 Theorem recursion_succ :
-  forall (A : Type) (Aeq : relation A) (a : A) (f : nat -> A -> A),
+  forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A),
     Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
       forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
 Proof.
@@ -149,7 +701,11 @@ Qed.
 
 Definition t := nat.
 Definition eq := @eq nat.
+Definition eqb := beq_nat.
+Definition compare := nat_compare.
 Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
 Definition succ := S.
 Definition pred := pred.
 Definition add := plus.
@@ -157,81 +713,101 @@ Definition sub := minus.
 Definition mul := mult.
 Definition lt := lt.
 Definition le := le.
+Definition ltb := ltb.
+Definition leb := leb.
+
 Definition min := min.
 Definition max := max.
-
-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.
+Definition max_l := max_l.
+Definition max_r := max_r.
+Definition min_l := min_l.
+Definition min_r := min_r.
+
+Definition eqb_eq := beq_nat_true_iff.
+Definition compare_spec := nat_compare_spec.
+Definition eq_dec := eq_nat_dec.
+Definition leb_le := leb_le.
+Definition ltb_lt := ltb_lt.
+
+Definition Even := Even.
+Definition Odd := Odd.
+Definition even := even.
+Definition odd := odd.
+Definition even_spec := even_spec.
+Definition odd_spec := odd_spec.
+
+Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
+Definition pow_0_r := pow_0_r.
+Definition pow_succ_r := pow_succ_r.
+Lemma pow_neg_r : forall a b, b<0 -> a^b = 0. inversion 1. Qed.
+Definition pow := pow.
+
+Definition square := square.
+Definition square_spec := square_spec.
+
+Definition log2_spec := log2_spec.
+Definition log2_nonpos := log2_nonpos.
+Definition log2 := log2.
+
+Definition sqrt_spec a (Ha:0<=a) := sqrt_spec a.
+Lemma sqrt_neg : forall a, a<0 -> sqrt a = 0. inversion 1. Qed.
+Definition sqrt := sqrt.
+
+Definition div := div.
+Definition modulo := modulo.
+Program Instance div_wd : Proper (eq==>eq==>eq) div.
+Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+Definition div_mod := div_mod.
+Definition mod_bound_pos := mod_bound_pos.
+
+Definition divide := divide.
+Definition gcd := gcd.
+Definition gcd_divide_l := gcd_divide_l.
+Definition gcd_divide_r := gcd_divide_r.
+Definition gcd_greatest := gcd_greatest.
+Lemma gcd_nonneg : forall a b, 0<=gcd a b.
+Proof. intros. apply le_O_n. Qed.
+
+Definition testbit := testbit.
+Definition shiftl := shiftl.
+Definition shiftr := shiftr.
+Definition lxor := lxor.
+Definition land := land.
+Definition lor := lor.
+Definition ldiff := ldiff.
+Definition div2 := div2.
+
+Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.
+Definition testbit_odd_0 := testbit_odd_0.
+Definition testbit_even_0 := testbit_even_0.
+Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ a n.
+Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ a n.
+Lemma testbit_neg_r a n (H:n<0) : testbit a n = false.
+Proof. inversion H. Qed.
+Definition shiftl_spec_low := shiftl_spec_low.
+Definition shiftl_spec_high a n m (_:0<=m) := shiftl_spec_high a n m.
+Definition shiftr_spec a n m (_:0<=m) := shiftr_spec a n m.
+Definition lxor_spec := lxor_spec.
+Definition land_spec := land_spec.
+Definition lor_spec := lor_spec.
+Definition ldiff_spec := ldiff_spec.
+Definition div2_spec a : div2 a = shiftr a 1 := eq_refl _.
+
+(** Generic Properties *)
+
+Include NProp
+ <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+End Nat.
+
+(** [Nat] contains an [order] tactic for natural numbers *)
+
+(** Note that [Nat.order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
+Section TestOrder.
+ Let test : forall x y, x<=y -> y<=x -> x=y.
+ Proof.
+ Nat.order.
+ Qed.
+End TestOrder.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v
index 7893a82d..aaf44ca6 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSig.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSig.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,9 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: NSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import ZArith Znumtheory.
+Require Import BinInt.
 
 Open Scope Z_scope.
 
@@ -29,60 +27,83 @@ Module Type NType.
  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).
+ Parameter spec_of_N: forall x, to_Z (of_N x) = Z.of_N x.
+ Definition to_N n := Z.to_N (to_Z n).
 
  Definition eq n m := [n] = [m].
  Definition lt n m := [n] < [m].
  Definition le n m := [n] <= [m].
 
  Parameter compare : t -> t -> comparison.
- Parameter eq_bool : t -> t -> bool.
+ Parameter eqb : t -> t -> bool.
+ Parameter ltb : t -> t -> bool.
+ Parameter leb : t -> t -> bool.
  Parameter max : t -> t -> t.
  Parameter min : t -> t -> t.
  Parameter zero : t.
  Parameter one : t.
+ Parameter two : t.
  Parameter succ : t -> t.
  Parameter pred : t -> t.
  Parameter add  : t -> t -> t.
  Parameter sub : t -> t -> t.
  Parameter mul : t -> t -> t.
  Parameter square : t -> t.
- Parameter power_pos : t -> positive -> t.
- Parameter power : t -> N -> t.
+ Parameter pow_pos : t -> positive -> t.
+ Parameter pow_N : t -> N -> t.
+ Parameter pow : t -> t -> t.
  Parameter sqrt : t -> t.
+ Parameter log2 : t -> t.
  Parameter div_eucl : t -> t -> t * t.
  Parameter div : t -> t -> t.
  Parameter modulo : t -> t -> t.
  Parameter gcd : t -> t -> t.
+ Parameter even : t -> bool.
+ Parameter odd : t -> bool.
+ Parameter testbit : t -> t -> bool.
  Parameter shiftr : t -> t -> t.
  Parameter shiftl : t -> t -> t.
- Parameter is_even : t -> bool.
+ Parameter land : t -> t -> t.
+ Parameter lor : t -> t -> t.
+ Parameter ldiff : t -> t -> t.
+ Parameter lxor : t -> t -> t.
+ Parameter div2 : 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_max : forall x y, [max x y] = Zmax [x] [y].
- Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
+ Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]).
+ Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]).
+ Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]).
+ Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]).
+ Parameter spec_max : forall x y, [max x y] = Z.max [x] [y].
+ Parameter spec_min : forall x y, [min x y] = Z.min [x] [y].
  Parameter spec_0: [zero] = 0.
  Parameter spec_1: [one] = 1.
+ Parameter spec_2: [two] = 2.
  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_pred: forall x, [pred x] = Z.max 0 ([x] - 1).
+ Parameter spec_sub: forall x y, [sub x y] = Z.max 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_square: forall x, [square x] = [x] * [x].
+ Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
+ Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n.
+ Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
+ Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x].
+ Parameter spec_log2: forall x, [log2 x] = Z.log2 [x].
  Parameter spec_div_eucl: forall x y,
-  let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
+  let (q,r) := div_eucl x y in ([q], [r]) = Z.div_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.
+ Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b].
+ Parameter spec_even: forall x, even x = Z.even [x].
+ Parameter spec_odd: forall x, odd x = Z.odd [x].
+ Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p].
+ Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p].
+ Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p].
+ Parameter spec_land: forall x y, [land x y] = Z.land [x] [y].
+ Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
+ Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
+ Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
+ Parameter spec_div2: forall x, [div2 x] = Z.div2 [x].
 
 End NType.
 
@@ -90,9 +111,12 @@ Module Type NType_Notation (Import N:NType).
  Notation "[ x ]" := (to_Z x).
  Infix "==" := eq (at level 70).
  Notation "0" := zero.
+ Notation "1" := one.
+ Notation "2" := two.
  Infix "+" := add.
  Infix "-" := sub.
  Infix "*" := mul.
+ Infix "^" := pow.
  Infix "<=" := le.
  Infix "<" := lt.
 End NType_Notation.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
index a0e096be..2c7884ac 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
@@ -1,27 +1,28 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NSigNAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import ZArith Nnat NAxioms NDiv NSig.
+Require Import ZArith OrdersFacts Nnat NAxioms NSig.
 
 (** * The interface [NSig.NType] implies the interface [NAxiomsSig] *)
 
-Module NTypeIsNAxioms (Import N : NType').
+Module NTypeIsNAxioms (Import NN : NType').
 
 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
+ spec_0 spec_1 spec_2 spec_succ spec_add spec_mul spec_pred spec_sub
+ spec_div spec_modulo spec_gcd spec_compare spec_eqb spec_ltb spec_leb
+ spec_square spec_sqrt spec_log2 spec_max spec_min spec_pow_pos spec_pow_N
+ spec_pow spec_even spec_odd spec_testbit spec_shiftl spec_shiftr
+ spec_land spec_lor spec_ldiff spec_lxor spec_div2 spec_of_N
  : nsimpl.
 Ltac nsimpl := autorewrite with nsimpl.
-Ltac ncongruence := unfold eq; repeat red; intros; nsimpl; congruence.
-Ltac zify := unfold eq, lt, le in *; nsimpl.
+Ltac ncongruence := unfold eq, to_N; repeat red; intros; nsimpl; congruence.
+Ltac zify := unfold eq, lt, le, to_N in *; nsimpl.
+Ltac omega_pos n := generalize (spec_pos n); omega with *.
 
 Local Obligation Tactic := ncongruence.
 
@@ -36,14 +37,29 @@ Program Instance mul_wd : Proper (eq==>eq==>eq) mul.
 
 Theorem pred_succ : forall n, pred (succ n) == n.
 Proof.
-intros. zify. generalize (spec_pos n); omega with *.
+intros. zify. omega_pos n.
 Qed.
 
-Definition N_of_Z z := of_N (Zabs_N z).
+Theorem one_succ : 1 == succ 0.
+Proof.
+now zify.
+Qed.
+
+Theorem two_succ : 2 == succ 1.
+Proof.
+now zify.
+Qed.
+
+Definition N_of_Z z := of_N (Z.to_N z).
+
+Lemma spec_N_of_Z z : (0<=z)%Z -> [N_of_Z z] = z.
+Proof.
+ unfold N_of_Z. zify. apply Z2N.id.
+Qed.
 
 Section Induction.
 
-Variable A : N.t -> Prop.
+Variable A : NN.t -> Prop.
 Hypothesis A_wd : Proper (eq==>iff) A.
 Hypothesis A0 : A 0.
 Hypothesis AS : forall n, A n <-> A (succ n).
@@ -62,9 +78,7 @@ Proof.
 intros z H1 H2.
 unfold B in *. apply -> AS in H2.
 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 spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith.
+unfold eq. rewrite spec_succ, 2 spec_N_of_Z; auto with zarith.
 Qed.
 
 Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z.
@@ -76,9 +90,7 @@ Theorem bi_induction : forall n, A n.
 Proof.
 intro n. setoid_replace n with (N_of_Z (to_Z n)).
 apply B_holds. apply spec_pos.
-red; unfold N_of_Z.
-rewrite spec_of_N, Z_of_N_abs, Zabs_eq; auto.
-apply spec_pos.
+red. now rewrite spec_N_of_Z by apply spec_pos.
 Qed.
 
 End Induction.
@@ -95,7 +107,7 @@ Qed.
 
 Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-intros. zify. generalize (spec_pos n); omega with *.
+intros. zify. omega_pos n.
 Qed.
 
 Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
@@ -115,39 +127,69 @@ Qed.
 
 (** Order *)
 
-Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Lemma eqb_eq x y : eqb x y = true <-> x == y.
+Proof.
+ zify. apply Z.eqb_eq.
+Qed.
+
+Lemma leb_le x y : leb x y = true <-> x <= y.
+Proof.
+ zify. apply Z.leb_le.
+Qed.
+
+Lemma ltb_lt x y : ltb x y = true <-> x < y.
+Proof.
+ zify. apply Z.ltb_lt.
+Qed.
+
+Lemma compare_eq_iff n m : compare n m = Eq <-> n == m.
 Proof.
- intros. zify. destruct (Zcompare_spec [x] [y]); auto.
+ intros. zify. apply Z.compare_eq_iff.
 Qed.
 
-Definition eqb := eq_bool.
+Lemma compare_lt_iff n m : compare n m = Lt <-> n < m.
+Proof.
+ intros. zify. reflexivity.
+Qed.
 
-Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
+Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m.
 Proof.
- intros. zify. symmetry. apply Zeq_is_eq_bool.
+ intros. zify. reflexivity.
 Qed.
 
+Lemma compare_antisym n m : compare m n = CompOpp (compare n m).
+Proof.
+ intros. zify. apply Z.compare_antisym.
+Qed.
+
+Include BoolOrderFacts NN NN NN [no inline].
+
 Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
 Proof.
-intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
+Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb.
 Proof.
-intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
+Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb.
 Proof.
-intros. zify. omega.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Theorem lt_irrefl : forall n, ~ n < n.
+Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb.
 Proof.
-intros. zify. omega.
+intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
 Qed.
 
-Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
+Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
+Proof.
+intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
+Qed.
+
+Theorem lt_succ_r : forall n m, n < succ m <-> n <= m.
 Proof.
 intros. zify. omega.
 Qed.
@@ -179,6 +221,98 @@ Proof.
 zify. auto.
 Qed.
 
+(** Power *)
+
+Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
+
+Lemma pow_0_r : forall a, a^0 == 1.
+Proof.
+ intros. now zify.
+Qed.
+
+Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
+Proof.
+ intros a b. zify. intros. now Z.nzsimpl.
+Qed.
+
+Lemma pow_neg_r : forall a b, b<0 -> a^b == 0.
+Proof.
+ intros a b. zify. intro Hb. exfalso. omega_pos b.
+Qed.
+
+Lemma pow_pow_N : forall a b, a^b == pow_N a (to_N b).
+Proof.
+ intros. zify. f_equal.
+ now rewrite Z2N.id by apply spec_pos.
+Qed.
+
+Lemma pow_N_pow : forall a b, pow_N a b == a^(of_N b).
+Proof.
+ intros. now zify.
+Qed.
+
+Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p).
+Proof.
+ intros. now zify.
+Qed.
+
+(** Square *)
+
+Lemma square_spec n : square n == n * n.
+Proof.
+ now zify.
+Qed.
+
+(** Sqrt *)
+
+Lemma sqrt_spec : forall n, 0<=n ->
+ (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)).
+Proof.
+ intros n. zify. apply Z.sqrt_spec.
+Qed.
+
+Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0.
+Proof.
+ intros n. zify. intro H. exfalso. omega_pos n.
+Qed.
+
+(** Log2 *)
+
+Lemma log2_spec : forall n, 0<n ->
+ 2^(log2 n) <= n /\ n < 2^(succ (log2 n)).
+Proof.
+ intros n. zify. change (Z.log2 [n]+1)%Z with (Z.succ (Z.log2 [n])).
+ apply Z.log2_spec.
+Qed.
+
+Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0.
+Proof.
+ intros n. zify. apply Z.log2_nonpos.
+Qed.
+
+(** Even / Odd *)
+
+Definition Even n := exists m, n == 2*m.
+Definition Odd n := exists m, n == 2*m+1.
+
+Lemma even_spec n : even n = true <-> Even n.
+Proof.
+ unfold Even. zify. rewrite Z.even_spec.
+ split; intros (m,Hm).
+ - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n.
+ - exists [m]. revert Hm; now zify.
+Qed.
+
+Lemma odd_spec n : odd n = true <-> Odd n.
+Proof.
+ unfold Odd. zify. rewrite Z.odd_spec.
+ split; intros (m,Hm).
+ - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n.
+ - exists [m]. revert Hm; now zify.
+Qed.
+
+(** Div / Mod *)
+
 Program Instance div_wd : Proper (eq==>eq==>eq) div.
 Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 
@@ -187,16 +321,131 @@ Proof.
 intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
 Qed.
 
-Theorem mod_upper_bound : forall a b, ~b==0 -> modulo a b < b.
+Theorem mod_bound_pos : forall a b, 0<=a -> 0<b ->
+ 0 <= modulo a b /\ modulo a b < b.
+Proof.
+intros a b. zify. apply Z.mod_bound_pos.
+Qed.
+
+(** Gcd *)
+
+Definition divide n m := exists p, m == p*n.
+Local Notation "( x | y )" := (divide x y) (at level 0).
+
+Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m].
+Proof.
+ intros n m. split.
+ - intros (p,H). exists [p]. revert H; now zify.
+ - intros (z,H). exists (of_N (Z.abs_N z)). zify.
+   rewrite N2Z.inj_abs_N.
+   rewrite <- (Z.abs_eq [m]), <- (Z.abs_eq [n]) by apply spec_pos.
+   now rewrite H, Z.abs_mul.
+Qed.
+
+Lemma gcd_divide_l : forall n m, (gcd n m | n).
 Proof.
-intros a b. zify. intros.
-destruct (Z_mod_lt [a] [b]); auto.
-generalize (spec_pos b); auto with zarith.
+ intros n m. apply spec_divide. zify. apply Z.gcd_divide_l.
 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].
+Lemma gcd_divide_r : forall n m, (gcd n m | m).
+Proof.
+ intros n m. apply spec_divide. zify. apply Z.gcd_divide_r.
+Qed.
+
+Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m).
+Proof.
+ intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest.
+Qed.
+
+Lemma gcd_nonneg : forall n m, 0 <= gcd n m.
+Proof.
+ intros. zify. apply Z.gcd_nonneg.
+Qed.
+
+(** Bitwise operations *)
+
+Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.
+
+Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true.
+Proof.
+ intros. zify. apply Z.testbit_odd_0.
+Qed.
+
+Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false.
+Proof.
+ intros. zify. apply Z.testbit_even_0.
+Qed.
+
+Lemma testbit_odd_succ : forall a n, 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a n.
+Proof.
+ intros a n. zify. apply Z.testbit_odd_succ.
+Qed.
+
+Lemma testbit_even_succ : forall a n, 0<=n ->
+ testbit (2*a) (succ n) = testbit a n.
+Proof.
+ intros a n. zify. apply Z.testbit_even_succ.
+Qed.
+
+Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false.
+Proof.
+ intros a n. zify. apply Z.testbit_neg_r.
+Qed.
+
+Lemma shiftr_spec : forall a n m, 0<=m ->
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ intros a n m. zify. apply Z.shiftr_spec.
+Qed.
+
+Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ intros a n m. zify. intros Hn H. rewrite Z.max_r by auto with zarith.
+ now apply Z.shiftl_spec_high.
+Qed.
+
+Lemma shiftl_spec_low : forall a n m, m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ intros a n m. zify. intros H. now apply Z.shiftl_spec_low.
+Qed.
+
+Lemma land_spec : forall a b n,
+ testbit (land a b) n = testbit a n && testbit b n.
+Proof.
+ intros a n m. zify. now apply Z.land_spec.
+Qed.
+
+Lemma lor_spec : forall a b n,
+ testbit (lor a b) n = testbit a n || testbit b n.
+Proof.
+ intros a n m. zify. now apply Z.lor_spec.
+Qed.
+
+Lemma ldiff_spec : forall a b n,
+ testbit (ldiff a b) n = testbit a n && negb (testbit b n).
+Proof.
+ intros a n m. zify. now apply Z.ldiff_spec.
+Qed.
+
+Lemma lxor_spec : forall a b n,
+ testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
+Proof.
+ intros a n m. zify. now apply Z.lxor_spec.
+Qed.
+
+Lemma div2_spec : forall a, div2 a == shiftr a 1.
+Proof.
+ intros a. zify. now apply Z.div2_spec.
+Qed.
+
+(** Recursion *)
+
+Definition recursion (A : Type) (a : A) (f : NN.t -> A -> A) (n : NN.t) :=
+  Nrect (fun _ => A) a (fun n a => f (NN.of_N n) a) (NN.to_N n).
+Arguments recursion [A] a f n.
 
 Instance recursion_wd (A : Type) (Aeq : relation A) :
  Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
@@ -204,53 +453,35 @@ Proof.
 unfold eq.
 intros a a' Eaa' f f' Eff' x x' Exx'.
 unfold recursion.
-unfold N.to_N.
+unfold NN.to_N.
 rewrite <- Exx'; clear x' Exx'.
-replace (Zabs_N [x]) with (N_of_nat (Zabs_nat [x])).
-induction (Zabs_nat [x]).
+induction (Z.to_N [x]) using N.peano_ind.
 simpl; 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.
+rewrite 2 Nrect_step. now apply Eff'.
 Qed.
 
 Theorem recursion_0 :
-  forall (A : Type) (a : A) (f : N.t -> A -> A), recursion a f 0 = a.
+  forall (A : Type) (a : A) (f : NN.t -> A -> A), recursion a f 0 = a.
 Proof.
-intros A a f; unfold recursion, N.to_N; rewrite N.spec_0; simpl; auto.
+intros A a f; unfold recursion, NN.to_N; rewrite NN.spec_0; simpl; auto.
 Qed.
 
 Theorem recursion_succ :
-  forall (A : Type) (Aeq : relation A) (a : A) (f : N.t -> A -> A),
+  forall (A : Type) (Aeq : relation A) (a : A) (f : NN.t -> A -> A),
     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; intros A Aeq a f EAaa f_wd n.
-replace (N.to_N (succ n)) with (Nsucc (N.to_N n)).
+unfold eq, recursion; intros A Aeq a f EAaa f_wd n.
+replace (to_N (succ n)) with (N.succ (to_N n)) by
+ (zify; now rewrite <- Z2N.inj_succ by apply spec_pos).
 rewrite Nrect_step.
 apply f_wd; auto.
-unfold N.to_N.
-rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto.
- apply N.spec_pos.
-
-fold (recursion a f n).
-apply recursion_wd; auto.
-red; auto.
-unfold N.to_N.
-
-rewrite N.spec_succ.
-change ([n]+1)%Z with (Zsucc [n]).
-apply Z_of_N_eq_rev.
-rewrite Z_of_N_succ.
-rewrite 2 Z_of_N_abs.
-rewrite 2 Zabs_eq; auto.
-generalize (spec_pos n); auto with zarith.
-apply spec_pos; auto.
+zify. now rewrite Z2N.id by apply spec_pos.
+fold (recursion a f n). apply recursion_wd; auto. red; auto.
 Qed.
 
 End NTypeIsNAxioms.
 
-Module NType_NAxioms (N : NType)
- <: NAxiomsSig <: NDivSig <: HasCompare N <: HasEqBool N <: HasMinMax N
- := N <+ NTypeIsNAxioms.
+Module NType_NAxioms (NN : NType)
+ <: NAxiomsSig <: OrderFunctions NN <: HasMinMax NN
+ := NN <+ NTypeIsNAxioms.
diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v
index 124faba1..ba7859ee 100644
--- a/theories/Numbers/NumPrelude.v
+++ b/theories/Numbers/NumPrelude.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,132 +8,17 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NumPrelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Export Setoid Morphisms.
+Require Export Setoid Morphisms Morphisms_Prop.
 
 Set Implicit Arguments.
-(*
-Contents:
-- Coercion from bool to Prop
-- Extension of the tactics stepl and stepr
-- Extentional properties of predicates, relations and functions
-  (well-definedness and equality)
-- Relations on cartesian product
-- Miscellaneous
-*)
-
-(** Coercion from bool to Prop *)
-
-(*Definition eq_bool := (@eq bool).*)
-
-(*Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.*)
-(* This has been added to theories/Datatypes.v *)
-(*Coercion eq_true : bool >-> Sortclass.*)
-
-(*Theorem eq_true_unfold_pos : forall b : bool, b <-> b = true.
-Proof.
-intro b; split; intro H. now inversion H. now rewrite H.
-Qed.
-
-Theorem eq_true_unfold_neg : forall b : bool, ~ b <-> b = false.
-Proof.
-intros b; destruct b; simpl; rewrite eq_true_unfold_pos.
-split; intro H; [elim (H (refl_equal true)) | discriminate H].
-split; intro H; [reflexivity | discriminate].
-Qed.
-
-Theorem eq_true_or : forall b1 b2 : bool, b1 || b2 <-> b1 \/ b2.
-Proof.
-destruct b1; destruct b2; simpl; tauto.
-Qed.
-
-Theorem eq_true_and : forall b1 b2 : bool, b1 && b2 <-> b1 /\ b2.
-Proof.
-destruct b1; destruct b2; simpl; tauto.
-Qed.
-
-Theorem eq_true_neg : forall b : bool, negb b <-> ~ b.
-Proof.
-destruct b; simpl; rewrite eq_true_unfold_pos; rewrite eq_true_unfold_neg;
-split; now intro.
-Qed.
-
-Theorem eq_true_iff : forall b1 b2 : bool, b1 = b2 <-> (b1 <-> b2).
-Proof.
-intros b1 b2; split; intro H.
-now rewrite H.
-destruct b1; destruct b2; simpl; try reflexivity.
-apply -> eq_true_unfold_neg. rewrite H. now intro.
-symmetry; apply -> eq_true_unfold_neg. rewrite <- H; now intro.
-Qed.*)
-
-(** Extension of the tactics stepl and stepr to make them
-applicable to hypotheses *)
-
-Tactic Notation "stepl" constr(t1') "in" hyp(H) :=
-match (type of H) with
-| ?R ?t1 ?t2 =>
-  let H1 := fresh in
-  cut (R t1' t2); [clear H; intro H | stepl t1; [assumption |]]
-| _ => fail 1 ": the hypothesis" H "does not have the form (R t1 t2)"
-end.
-
-Tactic Notation "stepl" constr(t1') "in" hyp(H) "by" tactic(r) := stepl t1' in H; [| r].
-
-Tactic Notation "stepr" constr(t2') "in" hyp(H) :=
-match (type of H) with
-| ?R ?t1 ?t2 =>
-  let H1 := fresh in
-  cut (R t1 t2'); [clear H; intro H | stepr t2; [assumption |]]
-| _ => fail 1 ": the hypothesis" H "does not have the form (R t1 t2)"
-end.
-
-Tactic Notation "stepr" constr(t2') "in" hyp(H) "by" tactic(r) := stepr t2' in H; [| r].
-
-(** Predicates, relations, functions *)
-
-Definition predicate (A : Type) := A -> Prop.
-
-Instance well_founded_wd A :
- Proper (@relation_equivalence A ==> iff) (@well_founded A).
-Proof.
-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 [Proper (?==>iff) P]
-    for P consisting of morphisms and quantifiers *)
-
-Ltac solve_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 [Proper (?==>?==>iff) R]
-    for R consisting of morphisms and quantifiers *)
-
-Ltac solve_relation_wd :=
-let x1 := fresh "x" in
-let y1 := fresh "y" in
-let H1 := fresh "H" in
-let x2 := fresh "x" in
-let y2 := fresh "y" in
-let H2 := fresh "H" in
-  intros x1 y1 H1 x2 y2 H2;
-  rewrite H1; setoid_rewrite H2; reflexivity.
 
-(* The following tactic uses solve_predicate_wd to solve the goals
-relating to well-defidedness that are produced by applying induction.
+(* The following tactic uses solve_proper to solve the goals
+relating to well-definedness that are produced by applying induction.
 We declare it to take the tactic that applies the induction theorem
 and not the induction theorem itself because the tactic may, for
 example, supply additional arguments, as does NZinduct_center in
 NZBase.v *)
 
 Ltac induction_maker n t :=
-  try intros until n;
-  pattern n; t; clear n;
-  [solve_predicate_wd | ..].
+  try intros until n; pattern n; t; clear n; [solve_proper | ..].
 
diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v
index 82190f94..424db5b7 100644
--- a/theories/Numbers/Rational/BigQ/BigQ.v
+++ b/theories/Numbers/Rational/BigQ/BigQ.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -35,47 +35,21 @@ End BigN_BigZ.
 
 (** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *)
 
-Module BigQ <: QType <: OrderedTypeFull <: TotalOrder :=
- QMake.Make BigN BigZ BigN_BigZ <+ !QProperties <+ HasEqBool2Dec
- <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
+Delimit Scope bigQ_scope with bigQ.
 
-(** Notations about [BigQ] *)
+Module BigQ <: QType <: OrderedTypeFull <: TotalOrder.
+ Include QMake.Make BigN BigZ BigN_BigZ [scope abstract_scope to bigQ_scope].
+ Bind Scope bigQ_scope with t t_.
+ Include !QProperties <+ HasEqBool2Dec
+  <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
+End BigQ.
 
-Notation bigQ := BigQ.t.
+(** Notations about [BigQ] *)
 
-Delimit Scope bigQ_scope with bigQ.
-Bind Scope bigQ_scope with bigQ.
-Bind Scope bigQ_scope with BigQ.t.
-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.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].
+Local Open Scope bigQ_scope.
 
+Notation bigQ := BigQ.t.
+Bind Scope bigQ_scope with bigQ BigQ.t BigQ.t_.
 (** 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.
@@ -88,19 +62,17 @@ 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.
+Notation "x != y" := (~x==y) (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 "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_scope.
+Notation "x < y <= z" := (x<y /\ y<=z) : bigQ_scope.
+Notation "x <= y < z" := (x<=y /\ y<z) : bigQ_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z) : bigQ_scope.
 Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope.
 
-Local Open Scope bigQ_scope.
-
 (** [BigQ] is a field *)
 
 Lemma BigQfieldth :
diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v
index 49e9d075..995fbb9e 100644
--- a/theories/Numbers/Rational/BigQ/QMake.v
+++ b/theories/Numbers/Rational/BigQ/QMake.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -39,6 +39,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition t := t_.
 
+ Bind Scope abstract_scope with t t_.
+
  (** Specification with respect to [QArith] *)
 
  Local Open Scope Q_scope.
@@ -55,7 +57,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  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
+   | Qq x y => if N.eqb y N.zero then 0
                else Z.to_Z x # Z2P (N.to_Z y)
  end.
 
@@ -66,26 +68,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  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_zcompare := case Z.compare_spec; intros ?H.
+
  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));
+   | |- context [Z.eqb ?x ?y] =>
+     rewrite (Z.spec_eqb x y);
+     case (Z.eqb_spec (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));
+   | |- context [N.eqb ?x ?y] =>
+     rewrite (N.spec_eqb x y);
+     case (Z.eqb_spec (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
@@ -100,6 +94,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   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;
@@ -143,13 +138,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   match x, y with
   | Qz zx, Qz zy => Z.compare zx zy
   | Qz zx, Qq ny dy =>
-    if N.eq_bool dy N.zero then Z.compare zx Z.zero
+    if N.eqb 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
+    if N.eqb 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
+    match N.eqb dx N.zero, N.eqb dy N.zero with
     | true, true => Eq
     | true, false => Z.compare Z.zero ny
     | false, true => Z.compare nx Z.zero
@@ -299,15 +294,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
     match y with
     | Qz zy => Qz (Z.add zx zy)
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
+      if N.eqb 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.eqb 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 =>
-      if N.eq_bool dy N.zero then x
+      if N.eqb dy N.zero then x
       else
        let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in
        let d := N.mul dx dy in
@@ -331,15 +326,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
     match y with
     | Qz zy => Qz (Z.add zx zy)
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
+      if N.eqb 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.eqb 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 =>
-      if N.eq_bool dy N.zero then x
+      if N.eqb dy N.zero then x
       else
        let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in
        let d := N.mul dx dy in
@@ -376,8 +371,8 @@ 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] =>
-  generalize (N.spec_eq_bool X Y); case N.eq_bool
+ match goal with  |- context[N.eqb ?X ?Y] =>
+  generalize (N.spec_eqb X Y); case N.eqb
  end; auto; rewrite N.spec_0.
  rewrite Z.spec_opp; auto.
  Qed.
@@ -427,26 +422,29 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy)
   end.
 
+ Ltac nsubst :=
+  match goal with E : N.to_Z _ = _ |- _ => rewrite E in * end.
+
  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, 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.
+ nsubst; auto with zarith.
+ nsubst; auto with zarith.
+ nsubst; nzsimpl; auto with zarith.
  rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
  Qed.
 
  Definition norm_denum n d :=
-  if N.eq_bool d N.one then Qz n else Qq n d.
+  if N.eqb 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.
  unfold norm_denum; intros; simpl; qsimpl.
  congruence.
- rewrite H0 in *; auto with zarith.
+ nsubst; auto with zarith.
  Qed.
 
  Definition irred n d :=
@@ -526,7 +524,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Qed.
 
  Definition mul_norm_Qz_Qq z n d :=
-   if Z.eq_bool z Z.zero then zero
+   if Z.eqb z Z.zero then zero
    else
     let gcd := N.gcd (Zabs_N z) d in
     match N.compare gcd N.one with
@@ -554,12 +552,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
  destr_eqb; nzsimpl; intros Hz.
  qsimpl; rewrite Hz; auto.
- destruct Z_le_gt_dec; intros.
+ destruct Z_le_gt_dec as [LE|GT].
  qsimpl.
  rewrite spec_norm_denum.
  qsimpl.
- rewrite Zdiv_gcd_zero in z0; auto with zarith.
- rewrite H in *. rewrite Zdiv_0_l in *; discriminate.
+ rewrite Zdiv_gcd_zero in GT; auto with zarith.
+ nsubst. rewrite Zdiv_0_l in *; discriminate.
  rewrite <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc.
  rewrite Zgcd_div_swap0; try romega.
  ring.
@@ -635,13 +633,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite spec_norm_denum.
  qsimpl.
 
- destruct (Zmult_integral _ _ H0) as [Eq|Eq].
+ match goal with E : (_ * _ = 0)%Z |- _ =>
+  destruct (Zmult_integral _ _ E) as [Eq|Eq] end.
  rewrite Eq in *; simpl in *.
  rewrite <- Hg2' in *; auto with zarith.
  rewrite Eq in *; simpl in *.
  rewrite <- Hg2 in *; auto with zarith.
 
- destruct (Zmult_integral _ _ H) as [Eq|Eq].
+ match goal with E : (_ * _ = 0)%Z |- _ =>
+  destruct (Zmult_integral _ _ E) as [Eq|Eq] end.
  rewrite Hz' in Eq; rewrite Eq in *; auto with zarith.
  rewrite Hz in Eq; rewrite Eq in *; auto with zarith.
 
@@ -689,13 +689,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  rewrite Zgcd_1_rel_prime in *.
  apply bezout_rel_prime.
- destruct (rel_prime_bezout _ _ H4) as [u v Huv].
+ destruct (rel_prime_bezout (Z.to_Z ny) (N.to_Z dy)) as [u v Huv]; trivial.
  apply Bezout_intro with (u*g')%Z (v*g)%Z.
  rewrite <- Huv, <- Hg1', <- Hg2. ring.
 
  rewrite Zgcd_1_rel_prime in *.
  apply bezout_rel_prime.
- destruct (rel_prime_bezout _ _ H3) as [u v Huv].
+ destruct (rel_prime_bezout (Z.to_Z nx) (N.to_Z dx)) as [u v Huv]; trivial.
  apply Bezout_intro with (u*g)%Z (v*g')%Z.
  rewrite <- Huv, <- Hg2', <- Hg1. ring.
  Qed.
@@ -753,10 +753,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destr_eqb; nzsimpl; intros.
  intros; rewrite Zabs_eq in *; romega.
  intros; rewrite Zabs_eq in *; romega.
- clear H1.
- rewrite H0.
- compute; auto.
- clear H1.
+ nsubst; compute; auto.
  set (n':=Z.to_Z n) in *; clearbody n'.
  rewrite Zabs_eq by romega.
  red; simpl.
@@ -768,9 +765,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destr_eqb; nzsimpl; intros.
  intros; rewrite Zabs_non_eq in *; romega.
  intros; rewrite Zabs_non_eq in *; romega.
- clear H1.
- red; nzsimpl; rewrite H0; compute; auto.
- clear H1.
+ nsubst; compute; auto.
  set (n':=Z.to_Z n) in *; clearbody n'.
  red; simpl; nzsimpl.
  rewrite Zabs_non_eq by romega.
@@ -789,7 +784,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
          | Gt => Qq Z.minus_one (Zabs_N z)
        end
      | Qq n d =>
-       if N.eq_bool d N.zero then zero else
+       if N.eqb d N.zero then zero else
        match Z.compare Z.zero n with
          | Eq => zero
          | Lt =>
@@ -926,9 +921,9 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destr_eqb; nzsimpl; intros.
  apply Qeq_refl.
  rewrite N.spec_square in *; nzsimpl.
- elim (Zmult_integral _ _ H0); romega.
- rewrite N.spec_square in *; nzsimpl.
- rewrite H in H0; romega.
+ match goal with E : (_ * _ = 0)%Z |- _ =>
+  elim (Zmult_integral _ _ E); romega end.
+ rewrite N.spec_square in *; nzsimpl; nsubst; romega.
  rewrite Z.spec_square, N.spec_square.
  red; simpl.
  rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto.
@@ -937,8 +932,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition power_pos (x : t) p : t :=
   match x with
-  | Qz zx => Qz (Z.power_pos zx p)
-  | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p)
+  | Qz zx => Qz (Z.pow_pos zx p)
+  | Qq nx dx => Qq (Z.pow_pos nx p) (N.pow_pos dx p)
   end.
 
  Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p.
@@ -946,25 +941,26 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  intros [ z | n d ] p; unfold power_pos.
  (* Qz *)
  simpl.
- rewrite Z.spec_power_pos.
+ rewrite Z.spec_pow_pos.
  rewrite Qpower_decomp.
  red; simpl; f_equal.
  rewrite Zpower_pos_1_l; auto.
  (* Qq *)
  simpl.
- rewrite Z.spec_power_pos.
+ rewrite Z.spec_pow_pos.
  destr_eqb; nzsimpl; intros.
  apply Qeq_sym; apply Qpower_positive_0.
- rewrite N.spec_power_pos in *.
+ rewrite N.spec_pow_pos in *.
  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; [romega|discriminate].
+ exfalso.
+ rewrite N.spec_pow_pos in *. nsubst.
+ rewrite Zpower_0_l in *; [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.
+ rewrite N.spec_pow_pos. auto.
  Qed.
 
  Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p).
@@ -979,10 +975,11 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  revert H.
  unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl.
  destr_eqb; nzsimpl; simpl; intros.
- rewrite N.spec_power_pos in H0.
- rewrite H, Zpower_0_l in *; [romega|discriminate].
+ exfalso.
+ rewrite N.spec_pow_pos in *. nsubst.
+ rewrite Zpower_0_l in *; [romega|discriminate].
  rewrite Z2P_correct in *; auto.
- rewrite N.spec_power_pos, Z.spec_power_pos; auto.
+ rewrite N.spec_pow_pos, Z.spec_pow_pos; auto.
  rewrite Zgcd_1_rel_prime in *.
  apply rel_prime_Zpower; auto with zarith.
  Qed.
@@ -1274,7 +1271,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply Qred_complete; apply spec_power_pos; auto.
  induction p using Pind.
  simpl; ring.
- rewrite nat_of_P_succ_morphism; simpl Qcpower.
+ rewrite Psucc_S; simpl Qcpower.
  rewrite <- IHp; clear IHp.
  unfold Qcmult, Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index 0fea26df..29e1e795 100644
--- a/theories/Numbers/Rational/SpecViaQ/QSig.v
+++ b/theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax.
 
 Open Scope Q_scope.
@@ -117,7 +115,7 @@ Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy.
 Local Obligation Tactic := solve_wd2 || solve_wd1.
 
 Instance : Measure to_Q.
-Instance eq_equiv : Equivalence eq.
+Instance eq_equiv : Equivalence eq := {}.
 
 Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
 Program Instance le_wd : Proper (eq==>eq==>iff) le.
@@ -137,13 +135,13 @@ Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power.
 
 (** Let's implement [HasCompare] *)
 
-Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Lemma compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y).
 Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed.
 
 (** Let's implement [TotalOrder] *)
 
 Definition lt_compat := lt_wd.
-Instance lt_strorder : StrictOrder lt.
+Instance lt_strorder : StrictOrder lt := {}.
 
 Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
 Proof. intros. qify. apply Qle_lteq. Qed.
@@ -222,4 +220,4 @@ End QProperties.
 
 Module QTypeExt (Q : QType)
  <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q
- := Q <+ QProperties.
\ No newline at end of file
+ := Q <+ QProperties.
diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget
index 175a15e9..c69af03f 100644
--- a/theories/Numbers/vo.itarget
+++ b/theories/Numbers/vo.itarget
@@ -1,3 +1,4 @@
+BinNums.vo
 BigNumPrelude.vo
 Cyclic/Abstract/CyclicAxioms.vo
 Cyclic/Abstract/NZCyclic.vo
@@ -23,10 +24,16 @@ 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/Abstract/ZMaxMin.vo
+Integer/Abstract/ZParity.vo
+Integer/Abstract/ZPow.vo
+Integer/Abstract/ZGcd.vo
+Integer/Abstract/ZLcm.vo
+Integer/Abstract/ZBits.vo
+Integer/Abstract/ZProperties.vo
 Integer/BigZ/BigZ.vo
 Integer/BigZ/ZMake.vo
 Integer/Binary/ZBinary.vo
@@ -43,7 +50,13 @@ NatInt/NZMul.vo
 NatInt/NZOrder.vo
 NatInt/NZProperties.vo
 NatInt/NZDomain.vo
+NatInt/NZParity.vo
 NatInt/NZDiv.vo
+NatInt/NZPow.vo
+NatInt/NZSqrt.vo
+NatInt/NZLog.vo
+NatInt/NZGcd.vo
+NatInt/NZBits.vo
 Natural/Abstract/NAddOrder.vo
 Natural/Abstract/NAdd.vo
 Natural/Abstract/NAxioms.vo
@@ -56,6 +69,14 @@ Natural/Abstract/NStrongRec.vo
 Natural/Abstract/NSub.vo
 Natural/Abstract/NProperties.vo
 Natural/Abstract/NDiv.vo
+Natural/Abstract/NMaxMin.vo
+Natural/Abstract/NParity.vo
+Natural/Abstract/NPow.vo
+Natural/Abstract/NSqrt.vo
+Natural/Abstract/NLog.vo
+Natural/Abstract/NGcd.vo
+Natural/Abstract/NLcm.vo
+Natural/Abstract/NBits.vo
 Natural/BigN/BigN.vo
 Natural/BigN/Nbasic.vo
 Natural/BigN/NMake_gen.vo
diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v
new file mode 100644
index 00000000..2e4d52a2
--- /dev/null
+++ b/theories/PArith/BinPos.v
@@ -0,0 +1,2132 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export BinNums.
+Require Import Eqdep_dec EqdepFacts RelationClasses Morphisms Setoid
+ Equalities Orders OrdersFacts GenericMinMax Le Plus.
+
+Require Export BinPosDef.
+
+(**********************************************************************)
+(** * Binary positive numbers, operations and properties *)
+(**********************************************************************)
+
+(** Initial development by Pierre Crégut, CNET, Lannion, France *)
+
+(** The type [positive] and its constructors [xI] and [xO] and [xH]
+    are now defined in [BinNums.v] *)
+
+Local Open Scope positive_scope.
+Local Unset Boolean Equality Schemes.
+Local Unset Case Analysis Schemes.
+
+(** Every definitions and early properties about positive numbers
+    are placed in a module [Pos] for qualification purpose. *)
+
+Module Pos
+ <: UsualOrderedTypeFull
+ <: UsualDecidableTypeFull
+ <: TotalOrder.
+
+(** * Definitions of operations, now in a separate file *)
+
+Include BinPosDef.Pos.
+
+(** In functor applications that follow, we only inline t and eq *)
+
+Set Inline Level 30.
+
+(** * Logical Predicates *)
+
+Definition eq := @Logic.eq positive.
+Definition eq_equiv := @eq_equivalence positive.
+Include BackportEq.
+
+Definition lt x y := (x ?= y) = Lt.
+Definition gt x y := (x ?= y) = Gt.
+Definition le x y := (x ?= y) <> Gt.
+Definition ge x y := (x ?= y) <> Lt.
+
+Infix "<=" := le : positive_scope.
+Infix "<" := lt : positive_scope.
+Infix ">=" := ge : positive_scope.
+Infix ">" := gt : positive_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope.
+Notation "x < y < z" := (x < y /\ y < z) : positive_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope.
+
+(**********************************************************************)
+(** * Properties of operations over positive numbers *)
+
+(** ** Decidability of equality on binary positive numbers *)
+
+Lemma eq_dec : forall x y:positive, {x = y} + {x <> y}.
+Proof.
+  decide equality.
+Defined.
+
+(**********************************************************************)
+(** * Properties of successor on binary positive numbers *)
+
+(** ** Specification of [xI] in term of [succ] and [xO] *)
+
+Lemma xI_succ_xO p : p~1 = succ p~0.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma succ_discr p : p <> succ p.
+Proof.
+  now destruct p.
+Qed.
+
+(** ** Successor and double *)
+
+Lemma pred_double_spec p : pred_double p = pred (p~0).
+Proof.
+  reflexivity.
+Qed.
+
+Lemma succ_pred_double p : succ (pred_double p) = p~0.
+Proof.
+  induction p; simpl; now f_equal.
+Qed.
+
+Lemma pred_double_succ p : pred_double (succ p) = p~1.
+Proof.
+  induction p; simpl; now f_equal.
+Qed.
+
+Lemma double_succ p : (succ p)~0 = succ (succ p~0).
+Proof.
+  now destruct p.
+Qed.
+
+Lemma pred_double_xO_discr p : pred_double p <> p~0.
+Proof.
+  now destruct p.
+Qed.
+
+(** ** Successor and predecessor *)
+
+Lemma succ_not_1 p : succ p <> 1.
+Proof.
+  now destruct p.
+Qed.
+
+Lemma pred_succ p : pred (succ p) = p.
+Proof.
+  destruct p; simpl; trivial. apply pred_double_succ.
+Qed.
+
+Lemma succ_pred_or p : p = 1 \/ succ (pred p) = p.
+Proof.
+  destruct p; simpl; auto.
+  right; apply succ_pred_double.
+Qed.
+
+Lemma succ_pred p : p <> 1 -> succ (pred p) = p.
+Proof.
+  destruct p; intros H; simpl; trivial.
+  apply succ_pred_double.
+  now destruct H.
+Qed.
+
+(** ** Injectivity of successor *)
+
+Lemma succ_inj p q : succ p = succ q -> p = q.
+Proof.
+  revert q.
+  induction p; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto.
+  elim (succ_not_1 p); auto.
+  elim (succ_not_1 q); auto.
+Qed.
+
+(** ** Predecessor to [N] *)
+
+Lemma pred_N_succ p : pred_N (succ p) = Npos p.
+Proof.
+ destruct p; simpl; trivial. f_equal. apply pred_double_succ.
+Qed.
+
+
+(**********************************************************************)
+(** * Properties of addition on binary positive numbers *)
+
+(** ** Specification of [succ] in term of [add] *)
+
+Lemma add_1_r p : p + 1 = succ p.
+Proof.
+  now destruct p.
+Qed.
+
+Lemma add_1_l p : 1 + p = succ p.
+Proof.
+  now destruct p.
+Qed.
+
+(** ** Specification of [add_carry] *)
+
+Theorem add_carry_spec p q : add_carry p q = succ (p + q).
+Proof.
+  revert q. induction p; destruct q; simpl; now f_equal.
+Qed.
+
+(** ** Commutativity *)
+
+Theorem add_comm p q : p + q = q + p.
+Proof.
+  revert q. induction p; destruct q; simpl; f_equal; trivial.
+  rewrite 2 add_carry_spec; now f_equal.
+Qed.
+
+(** ** Permutation of [add] and [succ] *)
+
+Theorem add_succ_r p q : p + succ q = succ (p + q).
+Proof.
+  revert q.
+  induction p; destruct q; simpl; f_equal;
+   auto using add_1_r; rewrite add_carry_spec; auto.
+Qed.
+
+Theorem add_succ_l p q : succ p + q = succ (p + q).
+Proof.
+  rewrite add_comm, (add_comm p). apply add_succ_r.
+Qed.
+
+(** ** No neutral elements for addition *)
+
+Lemma add_no_neutral p q : q + p <> p.
+Proof.
+  revert q.
+  induction p as [p IHp|p IHp| ]; intros [q|q| ] H;
+   destr_eq H; apply (IHp q H).
+Qed.
+
+(** ** Simplification *)
+
+Lemma add_carry_add p q r s :
+  add_carry p r = add_carry q s -> p + r = q + s.
+Proof.
+  intros H; apply succ_inj; now rewrite <- 2 add_carry_spec.
+Qed.
+
+Lemma add_reg_r p q r : p + r = q + r -> p = q.
+Proof.
+  revert p q. induction r.
+  intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal;
+   auto using add_carry_add; contradict H;
+   rewrite add_carry_spec, <- add_succ_r; auto using add_no_neutral.
+  intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto;
+    contradict H; auto using add_no_neutral.
+  intros p q H. apply succ_inj. now rewrite <- 2 add_1_r.
+Qed.
+
+Lemma add_reg_l p q r : p + q = p + r -> q = r.
+Proof.
+  rewrite 2 (add_comm p). now apply add_reg_r.
+Qed.
+
+Lemma add_cancel_r p q r : p + r = q + r <-> p = q.
+Proof.
+ split. apply add_reg_r. congruence.
+Qed.
+
+Lemma add_cancel_l p q r : r + p = r + q <-> p = q.
+Proof.
+ split. apply add_reg_l. congruence.
+Qed.
+
+Lemma add_carry_reg_r p q r :
+  add_carry p r = add_carry q r -> p = q.
+Proof.
+ intros H. apply add_reg_r with (r:=r); now apply add_carry_add.
+Qed.
+
+Lemma add_carry_reg_l p q r :
+  add_carry p q = add_carry p r -> q = r.
+Proof.
+  intros H; apply add_reg_r with (r:=p);
+  rewrite (add_comm r), (add_comm q); now apply add_carry_add.
+Qed.
+
+(** ** Addition is associative *)
+
+Theorem add_assoc p q r : p + (q + r) = p + q + r.
+Proof.
+  revert q r. induction p.
+  intros [q|q| ] [r|r| ]; simpl; f_equal; trivial;
+    rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r;
+    f_equal; trivial.
+  intros [q|q| ] [r|r| ]; simpl; f_equal; trivial;
+    rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r;
+    f_equal; trivial.
+  intros q r; rewrite 2 add_1_l, add_succ_l; auto.
+Qed.
+
+(** ** Commutation of addition and double *)
+
+Lemma add_xO p q : (p + q)~0 = p~0 + q~0.
+Proof.
+  now destruct p, q.
+Qed.
+
+Lemma add_xI_pred_double p q :
+  (p + q)~0 = p~1 + pred_double q.
+Proof.
+  change (p~1) with (p~0 + 1).
+  now rewrite <- add_assoc, add_1_l, succ_pred_double.
+Qed.
+
+Lemma add_xO_pred_double p q :
+  pred_double (p + q) = p~0 + pred_double q.
+Proof.
+  revert q. induction p as [p IHp| p IHp| ]; destruct q; simpl;
+   rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double;
+   try reflexivity.
+  rewrite IHp; auto.
+  rewrite <- succ_pred_double, <- add_1_l. reflexivity.
+Qed.
+
+(** ** Miscellaneous *)
+
+Lemma add_diag p : p + p = p~0.
+Proof.
+  induction p as [p IHp| p IHp| ]; simpl;
+  now rewrite ?add_carry_spec, ?IHp.
+Qed.
+
+(**********************************************************************)
+(** * Peano induction and recursion on binary positive positive numbers *)
+
+(** The Peano-like recursor function for [positive] (due to Daniel Schepler) *)
+
+Fixpoint peano_rect (P:positive->Type) (a:P 1)
+  (f: forall p:positive, P p -> P (succ p)) (p:positive) : P p :=
+let f2 := peano_rect (fun p:positive => P (p~0)) (f _ a)
+  (fun (p:positive) (x:P (p~0)) => f _ (f _ x))
+in
+match p with
+  | q~1 => f _ (f2 q)
+  | q~0 => f2 q
+  | 1 => a
+end.
+
+Theorem peano_rect_succ (P:positive->Type) (a:P 1)
+  (f:forall p, P p -> P (succ p)) (p:positive) :
+  peano_rect P a f (succ p) = f _ (peano_rect P a f p).
+Proof.
+ revert P a f. induction p; trivial.
+ intros. simpl. now rewrite IHp.
+Qed.
+
+Theorem peano_rect_base (P:positive->Type) (a:P 1)
+  (f:forall p, P p -> P (succ p)) :
+  peano_rect P a f 1 = a.
+Proof.
+  trivial.
+Qed.
+
+Definition peano_rec (P:positive->Set) := peano_rect P.
+
+(** Peano induction *)
+
+Definition peano_ind (P:positive->Prop) := peano_rect P.
+
+(** Peano case analysis *)
+
+Theorem peano_case :
+  forall P:positive -> Prop,
+    P 1 -> (forall n:positive, P (succ n)) -> forall p:positive, P p.
+Proof.
+  intros; apply peano_ind; auto.
+Qed.
+
+(** Earlier, the Peano-like recursor was built and proved in a way due to
+    Conor McBride, see "The view from the left" *)
+
+Inductive PeanoView : positive -> Type :=
+| PeanoOne : PeanoView 1
+| PeanoSucc : forall p, PeanoView p -> PeanoView (succ p).
+
+Fixpoint peanoView_xO p (q:PeanoView p) : PeanoView (p~0) :=
+  match q in PeanoView x return PeanoView (x~0) with
+    | PeanoOne => PeanoSucc _ PeanoOne
+    | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xO _ q))
+  end.
+
+Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) :=
+  match q in PeanoView x return PeanoView (x~1) with
+    | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne)
+    | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q))
+  end.
+
+Fixpoint peanoView p : PeanoView p :=
+  match p return PeanoView p with
+    | 1 => PeanoOne
+    | p~0 => peanoView_xO p (peanoView p)
+    | p~1 => peanoView_xI p (peanoView p)
+  end.
+
+Definition PeanoView_iter (P:positive->Type)
+  (a:P 1) (f:forall p, P p -> P (succ p)) :=
+  (fix iter p (q:PeanoView p) : P p :=
+    match q in PeanoView p return P p with
+      | PeanoOne => a
+      | PeanoSucc _ q => f _ (iter _ q)
+    end).
+
+Theorem eq_dep_eq_positive :
+  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'.
+Proof.
+  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 p; intros; discriminate.
+  trivial.
+  apply eq_dep_eq_positive.
+  cut (succ p=succ p). pattern (succ p) at 1 2 5, q'. destruct q'.
+  intro. destruct p; discriminate.
+  intro. apply succ_inj in H.
+  generalize q'. rewrite H. intro.
+  rewrite (IHq q'0).
+  trivial.
+  trivial.
+Qed.
+
+Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p :
+   PeanoView_iter P a f p (peanoView p) = peano_rect P a f p.
+Proof.
+  revert P a f. induction p using peano_rect.
+  trivial.
+  intros; simpl. rewrite peano_rect_succ.
+  rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))).
+  simpl; now f_equal.
+Qed.
+
+(**********************************************************************)
+(** * Properties of multiplication on binary positive numbers *)
+
+(** ** One is neutral for multiplication *)
+
+Lemma mul_1_l p : 1 * p = p.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma mul_1_r p : p * 1 = p.
+Proof.
+  induction p; simpl; now f_equal.
+Qed.
+
+(** ** Right reduction properties for multiplication *)
+
+Lemma mul_xO_r p q : p * q~0 = (p * q)~0.
+Proof.
+  induction p; simpl; f_equal; f_equal; trivial.
+Qed.
+
+Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0.
+Proof.
+  induction p as [p IHp|p IHp| ]; simpl; f_equal; trivial.
+  now rewrite IHp, 2 add_assoc, (add_comm p).
+Qed.
+
+(** ** Commutativity of multiplication *)
+
+Theorem mul_comm p q : p * q = q * p.
+Proof.
+  induction q as [q IHq|q IHq| ]; simpl; rewrite <- ? IHq;
+  auto using mul_xI_r, mul_xO_r, mul_1_r.
+Qed.
+
+(** ** Distributivity of multiplication over addition *)
+
+Theorem mul_add_distr_l p q r :
+  p * (q + r) = p * q + p * r.
+Proof.
+  induction p as [p IHp|p IHp| ]; simpl.
+  rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0).
+  change ((p*q+p*r)~0) with (m+n).
+  rewrite 2 add_assoc; f_equal.
+  rewrite <- 2 add_assoc; f_equal.
+  apply add_comm.
+  f_equal; auto.
+  reflexivity.
+Qed.
+
+Theorem mul_add_distr_r p q r :
+  (p + q) * r = p * r + q * r.
+Proof.
+  rewrite 3 (mul_comm _ r); apply mul_add_distr_l.
+Qed.
+
+(** ** Associativity of multiplication *)
+
+Theorem mul_assoc p q r : p * (q * r) = p * q * r.
+Proof.
+  induction p as [p IHp| p IHp | ]; simpl; rewrite ?IHp; trivial.
+  now rewrite mul_add_distr_r.
+Qed.
+
+(** ** Successor and multiplication *)
+
+Lemma mul_succ_l p q : (succ p) * q = q + p * q.
+Proof.
+  induction p as [p IHp | p IHp | ]; simpl; trivial.
+  now rewrite IHp, add_assoc, add_diag, <-add_xO.
+  symmetry; apply add_diag.
+Qed.
+
+Lemma mul_succ_r p q : p * (succ q) = p + p * q.
+Proof.
+  rewrite mul_comm, mul_succ_l. f_equal. apply mul_comm.
+Qed.
+
+(** ** Parity properties of multiplication *)
+
+Lemma mul_xI_mul_xO_discr p q r : p~1 * r <> q~0 * r.
+Proof.
+  induction r; try discriminate.
+  rewrite 2 mul_xO_r; intro H; destr_eq H; auto.
+Qed.
+
+Lemma mul_xO_discr p q : p~0 * q <> q.
+Proof.
+  induction q; try discriminate.
+  rewrite mul_xO_r; injection; assumption.
+Qed.
+
+(** ** Simplification properties of multiplication *)
+
+Theorem mul_reg_r p q r : p * r = q * r -> p = q.
+Proof.
+  revert q r.
+  induction p as [p IHp| p IHp| ]; intros [q|q| ] r H;
+    reflexivity || apply f_equal || exfalso.
+  apply IHp with (r~0). simpl in *.
+    rewrite 2 mul_xO_r. apply add_reg_l with (1:=H).
+  contradict H. apply mul_xI_mul_xO_discr.
+  contradict H. simpl. rewrite add_comm. apply add_no_neutral.
+  symmetry in H. contradict H. apply mul_xI_mul_xO_discr.
+  apply IHp with (r~0). simpl. now rewrite 2 mul_xO_r.
+  contradict H. apply mul_xO_discr.
+  symmetry in H. contradict H. simpl. rewrite add_comm.
+   apply add_no_neutral.
+  symmetry in H. contradict H. apply mul_xO_discr.
+Qed.
+
+Theorem mul_reg_l p q r : r * p = r * q -> p = q.
+Proof.
+  rewrite 2 (mul_comm r). apply mul_reg_r.
+Qed.
+
+Lemma mul_cancel_r p q r : p * r = q * r <-> p = q.
+Proof.
+ split. apply mul_reg_r. congruence.
+Qed.
+
+Lemma mul_cancel_l p q r : r * p = r * q <-> p = q.
+Proof.
+ split. apply mul_reg_l. congruence.
+Qed.
+
+(** ** Inversion of multiplication *)
+
+Lemma mul_eq_1_l p q : p * q = 1 -> p = 1.
+Proof.
+  now destruct p, q.
+Qed.
+
+Lemma mul_eq_1_r p q : p * q = 1 -> q = 1.
+Proof.
+  now destruct p, q.
+Qed.
+
+Notation mul_eq_1 := mul_eq_1_l.
+
+(** ** Square *)
+
+Lemma square_xO p : p~0 * p~0 = (p*p)~0~0.
+Proof.
+ simpl. now rewrite mul_comm.
+Qed.
+
+Lemma square_xI p : p~1 * p~1 = (p*p+p)~0~1.
+Proof.
+ simpl. rewrite mul_comm. simpl. f_equal.
+ rewrite add_assoc, add_diag. simpl. now rewrite add_comm.
+Qed.
+
+(** ** Properties of [iter] *)
+
+Lemma iter_swap_gen : forall A B (f:A->B)(g:A->A)(h:B->B),
+ (forall a, f (g a) = h (f a)) -> forall p a,
+ f (iter p g a) = iter p h (f a).
+Proof.
+ induction p; simpl; intros; now rewrite ?H, ?IHp.
+Qed.
+
+Theorem iter_swap :
+  forall p (A:Type) (f:A -> A) (x:A),
+    iter p f (f x) = f (iter p f x).
+Proof.
+ intros. symmetry. now apply iter_swap_gen.
+Qed.
+
+Theorem iter_succ :
+  forall p (A:Type) (f:A -> A) (x:A),
+    iter (succ p) f x = f (iter p f x).
+Proof.
+ induction p as [p IHp|p IHp|]; intros; simpl; trivial.
+ now rewrite !IHp, iter_swap.
+Qed.
+
+Theorem iter_add :
+  forall p q (A:Type) (f:A -> A) (x:A),
+    iter (p+q) f x = iter p f (iter q f x).
+Proof.
+ induction p using peano_ind; intros.
+ now rewrite add_1_l, iter_succ.
+ now rewrite add_succ_l, !iter_succ, IHp.
+Qed.
+
+Theorem iter_invariant :
+  forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop),
+    (forall x:A, Inv x -> Inv (f x)) ->
+    forall x:A, Inv x -> Inv (iter p f x).
+Proof.
+ induction p as [p IHp|p IHp|]; simpl; trivial.
+ intros A f Inv H x H0. apply H, IHp, IHp; trivial.
+ intros A f Inv H x H0. apply IHp, IHp; trivial.
+Qed.
+
+(** ** Properties of power *)
+
+Lemma pow_1_r p : p^1 = p.
+Proof.
+ unfold pow. simpl. now rewrite mul_comm.
+Qed.
+
+Lemma pow_succ_r p q : p^(succ q) = p * p^q.
+Proof.
+ unfold pow. now rewrite iter_succ.
+Qed.
+
+(** ** Properties of square *)
+
+Lemma square_spec p : square p = p * p.
+Proof.
+ induction p.
+ - rewrite square_xI. simpl. now rewrite IHp.
+ - rewrite square_xO. simpl. now rewrite IHp.
+ - trivial.
+Qed.
+
+(** ** Properties of [sub_mask] *)
+
+Lemma sub_mask_succ_r p q :
+  sub_mask p (succ q) = sub_mask_carry p q.
+Proof.
+ revert q. induction p; destruct q; simpl; f_equal; trivial; now destruct p.
+Qed.
+
+Theorem sub_mask_carry_spec p q :
+  sub_mask_carry p q = pred_mask (sub_mask p q).
+Proof.
+  revert q. induction p as [p IHp|p IHp| ]; destruct q; simpl;
+   try reflexivity; try rewrite IHp;
+   destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto.
+Qed.
+
+Inductive SubMaskSpec (p q : positive) : mask -> Prop :=
+ | SubIsNul : p = q -> SubMaskSpec p q IsNul
+ | SubIsPos : forall r, q + r = p -> SubMaskSpec p q (IsPos r)
+ | SubIsNeg : forall r, p + r = q -> SubMaskSpec p q IsNeg.
+
+Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q).
+Proof.
+ revert q. induction p; destruct q; simpl; try constructor; trivial.
+ (* p~1 q~1 *)
+ destruct (IHp q); subst; try now constructor.
+  now apply SubIsNeg with r~0.
+ (* p~1 q~0 *)
+ destruct (IHp q); subst; try now constructor.
+  apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double.
+ (* p~0 q~1 *)
+ rewrite sub_mask_carry_spec.
+ destruct (IHp q); subst; try constructor.
+  now apply SubIsNeg with 1.
+  destruct r; simpl; try constructor; simpl.
+   now rewrite add_carry_spec, <- add_succ_r.
+   now rewrite add_carry_spec, <- add_succ_r, succ_pred_double.
+   now rewrite add_1_r.
+  now apply SubIsNeg with r~1.
+ (* p~0 q~0 *)
+ destruct (IHp q); subst; try now constructor.
+  now apply SubIsNeg with r~0.
+ (* p~0 1 *)
+ now rewrite add_1_l, succ_pred_double.
+ (* 1 q~1 *)
+ now apply SubIsNeg with q~0.
+ (* 1 q~0 *)
+ apply SubIsNeg with (pred_double q). now rewrite add_1_l, succ_pred_double.
+Qed.
+
+Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q.
+Proof.
+ split.
+ now case sub_mask_spec.
+ intros <-. induction p; simpl; now rewrite ?IHp.
+Qed.
+
+Theorem sub_mask_diag p : sub_mask p p = IsNul.
+Proof.
+  now apply sub_mask_nul_iff.
+Qed.
+
+Lemma sub_mask_add p q r : sub_mask p q = IsPos r -> q + r = p.
+Proof.
+ case sub_mask_spec; congruence.
+Qed.
+
+Lemma sub_mask_add_diag_l p q : sub_mask (p+q) p = IsPos q.
+Proof.
+ case sub_mask_spec.
+ intros H. rewrite add_comm in H. elim (add_no_neutral _ _ H).
+ intros r H. apply add_cancel_l in H. now f_equal.
+ intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H).
+Qed.
+
+Lemma sub_mask_pos_iff p q r : sub_mask p q = IsPos r <-> q + r = p.
+Proof.
+ split. apply sub_mask_add. intros <-; apply sub_mask_add_diag_l.
+Qed.
+
+Lemma sub_mask_add_diag_r p q : sub_mask p (p+q) = IsNeg.
+Proof.
+ case sub_mask_spec; trivial.
+ intros H. symmetry in H; rewrite add_comm in H. elim (add_no_neutral _ _ H).
+ intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H).
+Qed.
+
+Lemma sub_mask_neg_iff p q : sub_mask p q = IsNeg <-> exists r, p + r = q.
+Proof.
+ split.
+ case sub_mask_spec; try discriminate. intros r Hr _; now exists r.
+ intros (r,<-). apply sub_mask_add_diag_r.
+Qed.
+
+(*********************************************************************)
+(** * Properties of boolean comparisons *)
+
+Theorem eqb_eq p q : (p =? q) = true <-> p=q.
+Proof.
+ revert q. induction p; destruct q; simpl; rewrite ?IHp; split; congruence.
+Qed.
+
+Theorem ltb_lt p q : (p <? q) = true <-> p < q.
+Proof.
+  unfold ltb, lt. destruct compare; easy'.
+Qed.
+
+Theorem leb_le p q : (p <=? q) = true <-> p <= q.
+Proof.
+  unfold leb, le. destruct compare; easy'.
+Qed.
+
+(** More about [eqb] *)
+
+Include BoolEqualityFacts.
+
+(**********************************************************************)
+(** * Properties of comparison on binary positive numbers *)
+
+(** First, we express [compare_cont] in term of [compare] *)
+
+Definition switch_Eq c c' :=
+ match c' with
+  | Eq => c
+  | Lt => Lt
+  | Gt => Gt
+ end.
+
+Lemma compare_cont_spec p q c :
+  compare_cont p q c = switch_Eq c (p ?= q).
+Proof.
+  unfold compare.
+  revert q c.
+  induction p; destruct q; simpl; trivial.
+  intros c.
+  rewrite 2 IHp. now destruct (compare_cont p q Eq).
+  intros c.
+  rewrite 2 IHp. now destruct (compare_cont p q Eq).
+Qed.
+
+(** From this general result, we now describe particular cases
+    of [compare_cont p q c = c'] :
+    - When [c=Eq], this is directly [compare]
+    - When [c<>Eq], we'll show first that [c'<>Eq]
+    - That leaves only 4 lemmas for [c] and [c'] being [Lt] or [Gt]
+*)
+
+Theorem compare_cont_Eq p q c :
+ compare_cont p q c = Eq -> c = Eq.
+Proof.
+  rewrite compare_cont_spec. now destruct (p ?= q).
+Qed.
+
+Lemma compare_cont_Lt_Gt p q :
+  compare_cont p q Lt = Gt <-> p > q.
+Proof.
+  rewrite compare_cont_spec. unfold gt. destruct (p ?= q); now split.
+Qed.
+
+Lemma compare_cont_Lt_Lt p q :
+  compare_cont p q Lt = Lt <-> p <= q.
+Proof.
+  rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'.
+Qed.
+
+Lemma compare_cont_Gt_Lt p q :
+  compare_cont p q Gt = Lt <-> p < q.
+Proof.
+  rewrite compare_cont_spec. unfold lt. destruct (p ?= q); now split.
+Qed.
+
+Lemma compare_cont_Gt_Gt p q :
+  compare_cont p q Gt = Gt <-> p >= q.
+Proof.
+  rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'.
+Qed.
+
+(** We can express recursive equations for [compare] *)
+
+Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q).
+Proof. reflexivity. Qed.
+
+Lemma compare_xI_xI p q : (p~1 ?= q~1) = (p ?= q).
+Proof. reflexivity. Qed.
+
+Lemma compare_xI_xO p q :
+ (p~1 ?= q~0) = switch_Eq Gt (p ?= q).
+Proof. exact (compare_cont_spec p q Gt). Qed.
+
+Lemma compare_xO_xI p q :
+ (p~0 ?= q~1) = switch_Eq Lt (p ?= q).
+Proof. exact (compare_cont_spec p q Lt). Qed.
+
+Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare.
+
+Ltac simpl_compare := autorewrite with compare.
+Ltac simpl_compare_in H := autorewrite with compare in H.
+
+(** Relation between [compare] and [sub_mask] *)
+
+Definition mask2cmp (p:mask) : comparison :=
+ match p with
+  | IsNul => Eq
+  | IsPos _ => Gt
+  | IsNeg => Lt
+ end.
+
+Lemma compare_sub_mask p q : (p ?= q) = mask2cmp (sub_mask p q).
+Proof.
+  revert q.
+  induction p as [p IHp| p IHp| ]; intros [q|q| ]; simpl; trivial;
+  specialize (IHp q); rewrite ?sub_mask_carry_spec;
+  destruct (sub_mask p q) as [|r|]; simpl in *;
+  try clear r; try destruct r; simpl; trivial;
+  simpl_compare; now rewrite IHp.
+Qed.
+
+(** Alternative characterisation of strict order in term of addition *)
+
+Lemma lt_iff_add p q : p < q <-> exists r, p + r = q.
+Proof.
+ unfold "<". rewrite <- sub_mask_neg_iff, compare_sub_mask.
+ destruct sub_mask; now split.
+Qed.
+
+Lemma gt_iff_add p q : p > q <-> exists r, q + r = p.
+Proof.
+ unfold ">". rewrite compare_sub_mask.
+ split.
+ case_eq (sub_mask p q); try discriminate; intros r Hr _.
+  exists r. now apply sub_mask_pos_iff.
+ intros (r,Hr). apply sub_mask_pos_iff in Hr. now rewrite Hr.
+Qed.
+
+(** Basic facts about [compare_cont] *)
+
+Theorem compare_cont_refl p c :
+  compare_cont p p c = c.
+Proof.
+  now induction p.
+Qed.
+
+Lemma compare_cont_antisym p q c :
+  CompOpp (compare_cont p q c) = compare_cont q p (CompOpp c).
+Proof.
+  revert q c.
+  induction p as [p IHp|p IHp| ]; intros [q|q| ] c; simpl;
+   trivial; apply IHp.
+Qed.
+
+(** Basic facts about [compare] *)
+
+Lemma compare_eq_iff p q : (p ?= q) = Eq <-> p = q.
+Proof.
+ rewrite compare_sub_mask, <- sub_mask_nul_iff.
+ destruct sub_mask; now split.
+Qed.
+
+Lemma compare_antisym p q : (q ?= p) = CompOpp (p ?= q).
+Proof.
+  unfold compare. now rewrite compare_cont_antisym.
+Qed.
+
+Lemma compare_lt_iff p q : (p ?= q) = Lt <-> p < q.
+Proof. reflexivity. Qed.
+
+Lemma compare_le_iff p q : (p ?= q) <> Gt <-> p <= q.
+Proof. reflexivity. Qed.
+
+(** More properties about [compare] and boolean comparisons,
+  including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)
+
+Include BoolOrderFacts.
+
+Definition le_lteq := lt_eq_cases.
+
+(** ** Facts about [gt] and [ge] *)
+
+(** The predicates [lt] and [le] are now favored in the statements
+  of theorems, the use of [gt] and [ge] is hence not recommended.
+  We provide here the bare minimal results to related them with
+  [lt] and [le]. *)
+
+Lemma gt_lt_iff p q : p > q <-> q < p.
+Proof.
+ unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
+Qed.
+
+Lemma gt_lt p q : p > q -> q < p.
+Proof.
+ apply gt_lt_iff.
+Qed.
+
+Lemma lt_gt p q : p < q -> q > p.
+Proof.
+ apply gt_lt_iff.
+Qed.
+
+Lemma ge_le_iff p q : p >= q <-> q <= p.
+Proof.
+ unfold le, ge. now rewrite compare_antisym, CompOpp_iff.
+Qed.
+
+Lemma ge_le p q : p >= q -> q <= p.
+Proof.
+ apply ge_le_iff.
+Qed.
+
+Lemma le_ge p q : p <= q -> q >= p.
+Proof.
+ apply ge_le_iff.
+Qed.
+
+(** ** Comparison and the successor *)
+
+Lemma compare_succ_r p q :
+  switch_Eq Gt (p ?= succ q) = switch_Eq Lt (p ?= q).
+Proof.
+  revert q.
+  induction p as [p IH|p IH| ]; intros [q|q| ]; simpl;
+   simpl_compare; rewrite ?IH; trivial;
+   (now destruct compare) || (now destruct p).
+Qed.
+
+Lemma compare_succ_l p q :
+  switch_Eq Lt (succ p ?= q) = switch_Eq Gt (p ?= q).
+Proof.
+  rewrite 2 (compare_antisym q). generalize (compare_succ_r q p).
+  now do 2 destruct compare.
+Qed.
+
+Theorem lt_succ_r p q : p < succ q <-> p <= q.
+Proof.
+  unfold lt, le. generalize (compare_succ_r p q).
+  do 2 destruct compare; try discriminate; now split.
+Qed.
+
+Lemma lt_succ_diag_r p : p < succ p.
+Proof.
+ rewrite lt_iff_add. exists 1. apply add_1_r.
+Qed.
+
+Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q).
+Proof.
+ revert q.
+ induction p; destruct q; simpl; simpl_compare; trivial;
+  apply compare_succ_l || apply compare_succ_r ||
+  (now destruct p) || (now destruct q).
+Qed.
+
+(** ** 1 is the least positive number *)
+
+Lemma le_1_l p : 1 <= p.
+Proof.
+  now destruct p.
+Qed.
+
+Lemma nlt_1_r p : ~ p < 1.
+Proof.
+  now destruct p.
+Qed.
+
+Lemma lt_1_succ p : 1 < succ p.
+Proof.
+  apply lt_succ_r, le_1_l.
+Qed.
+
+(** ** Properties of the order *)
+
+Lemma le_nlt p q : p <= q <-> ~ q < p.
+Proof.
+  now rewrite <- ge_le_iff.
+Qed.
+
+Lemma lt_nle p q : p < q <-> ~ q <= p.
+Proof.
+ intros. unfold lt, le. rewrite compare_antisym.
+ destruct compare; split; auto; easy'.
+Qed.
+
+Lemma lt_le_incl p q : p<q -> p<=q.
+Proof.
+  intros. apply le_lteq. now left.
+Qed.
+
+Lemma lt_lt_succ n m : n < m -> n < succ m.
+Proof.
+  intros. now apply lt_succ_r, lt_le_incl.
+Qed.
+
+Lemma succ_lt_mono n m : n < m <-> succ n < succ m.
+Proof.
+  unfold lt. now rewrite compare_succ_succ.
+Qed.
+
+Lemma succ_le_mono n m : n <= m <-> succ n <= succ m.
+Proof.
+  unfold le. now rewrite compare_succ_succ.
+Qed.
+
+Lemma lt_trans n m p : n < m -> m < p -> n < p.
+Proof.
+ rewrite 3 lt_iff_add. intros (r,Hr) (s,Hs).
+ exists (r+s). now rewrite add_assoc, Hr, Hs.
+Qed.
+
+Theorem lt_ind : forall (A : positive -> Prop) (n : positive),
+  A (succ n) ->
+    (forall m : positive, n < m -> A m -> A (succ m)) ->
+      forall m : positive, n < m -> A m.
+Proof.
+  intros A n AB AS m. induction m using peano_ind; intros H.
+  elim (nlt_1_r _ H).
+  apply lt_succ_r, le_lteq in H. destruct H as [H|H]; subst; auto.
+Qed.
+
+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.
+
+Lemma lt_total p q : p < q \/ p = q \/ q < p.
+Proof.
+ case (compare_spec p q); intuition.
+Qed.
+
+Lemma le_refl p : p <= p.
+Proof.
+ intros. unfold le. now rewrite compare_refl.
+Qed.
+
+Lemma le_lt_trans n m p : n <= m -> m < p -> n < p.
+Proof.
+ intros H H'. apply le_lteq in H. destruct H.
+ now apply lt_trans with m. now subst.
+Qed.
+
+Lemma lt_le_trans n m p : n < m -> m <= p -> n < p.
+Proof.
+ intros H H'. apply le_lteq in H'. destruct H'.
+ now apply lt_trans with m. now subst.
+Qed.
+
+Lemma le_trans n m p : n <= m -> m <= p -> n <= p.
+Proof.
+ intros H H'.
+ apply le_lteq in H. destruct H.
+ apply le_lteq; left. now apply lt_le_trans with m.
+ now subst.
+Qed.
+
+Lemma le_succ_l n m : succ n <= m <-> n < m.
+Proof.
+ rewrite <- lt_succ_r. symmetry. apply succ_lt_mono.
+Qed.
+
+Lemma le_antisym p q : p <= q -> q <= p -> p = q.
+Proof.
+ rewrite le_lteq; destruct 1; auto.
+ rewrite le_lteq; destruct 1; auto.
+ elim (lt_irrefl p). now transitivity q.
+Qed.
+
+Instance le_preorder : PreOrder le.
+Proof. split. exact le_refl. exact le_trans. Qed.
+
+Instance le_partorder : PartialOrder Logic.eq le.
+Proof.
+ intros x y. change (x=y <-> x <= y <= x).
+ split. intros; now subst.
+ destruct 1; now apply le_antisym.
+Qed.
+
+(** ** Comparison and addition *)
+
+Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r).
+Proof.
+ revert p q r. induction p using peano_ind; intros q r.
+ rewrite 2 add_1_l. apply compare_succ_succ.
+ now rewrite 2 add_succ_l, compare_succ_succ.
+Qed.
+
+Lemma add_compare_mono_r p q r : (q+p ?= r+p) = (q ?= r).
+Proof.
+ rewrite 2 (add_comm _ p). apply add_compare_mono_l.
+Qed.
+
+(** ** Order and addition *)
+
+Lemma lt_add_diag_r p q : p < p + q.
+Proof.
+ rewrite lt_iff_add. now exists q.
+Qed.
+
+Lemma add_lt_mono_l p q r : q<r <-> p+q < p+r.
+Proof.
+ unfold lt. rewrite add_compare_mono_l. apply iff_refl.
+Qed.
+
+Lemma add_lt_mono_r p q r : q<r <-> q+p < r+p.
+Proof.
+ unfold lt. rewrite add_compare_mono_r. apply iff_refl.
+Qed.
+
+Lemma add_lt_mono p q r s : p<q -> r<s -> p+r<q+s.
+Proof.
+ intros. apply lt_trans with (p+s).
+ now apply add_lt_mono_l.
+ now apply add_lt_mono_r.
+Qed.
+
+Lemma add_le_mono_l p q r : q<=r <-> p+q<=p+r.
+Proof.
+ unfold le. rewrite add_compare_mono_l. apply iff_refl.
+Qed.
+
+Lemma add_le_mono_r p q r : q<=r <-> q+p<=r+p.
+Proof.
+ unfold le. rewrite add_compare_mono_r. apply iff_refl.
+Qed.
+
+Lemma add_le_mono p q r s : p<=q -> r<=s -> p+r <= q+s.
+Proof.
+ intros. apply le_trans with (p+s).
+ now apply add_le_mono_l.
+ now apply add_le_mono_r.
+Qed.
+
+(** ** Comparison and multiplication *)
+
+Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r).
+Proof.
+ revert q r. induction p; simpl; trivial.
+ intros q r. specialize (IHp q r).
+ destruct (compare_spec q r).
+ subst. apply compare_refl.
+ now apply add_lt_mono.
+ now apply lt_gt, add_lt_mono, gt_lt.
+Qed.
+
+Lemma mul_compare_mono_r p q r : (q*p ?= r*p) = (q ?= r).
+Proof.
+ rewrite 2 (mul_comm _ p). apply mul_compare_mono_l.
+Qed.
+
+(** ** Order and multiplication *)
+
+Lemma mul_lt_mono_l p q r : q<r <-> p*q < p*r.
+Proof.
+ unfold lt. rewrite mul_compare_mono_l. apply iff_refl.
+Qed.
+
+Lemma mul_lt_mono_r p q r : q<r <-> q*p < r*p.
+Proof.
+ unfold lt. rewrite mul_compare_mono_r. apply iff_refl.
+Qed.
+
+Lemma mul_lt_mono p q r s : p<q -> r<s -> p*r < q*s.
+Proof.
+ intros. apply lt_trans with (p*s).
+ now apply mul_lt_mono_l.
+ now apply mul_lt_mono_r.
+Qed.
+
+Lemma mul_le_mono_l p q r : q<=r <-> p*q<=p*r.
+Proof.
+ unfold le. rewrite mul_compare_mono_l. apply iff_refl.
+Qed.
+
+Lemma mul_le_mono_r p q r : q<=r <-> q*p<=r*p.
+Proof.
+ unfold le. rewrite mul_compare_mono_r. apply iff_refl.
+Qed.
+
+Lemma mul_le_mono p q r s : p<=q -> r<=s -> p*r <= q*s.
+Proof.
+ intros. apply le_trans with (p*s).
+ now apply mul_le_mono_l.
+ now apply mul_le_mono_r.
+Qed.
+
+Lemma lt_add_r p q : p < p+q.
+Proof.
+ induction q using peano_ind.
+ rewrite add_1_r. apply lt_succ_diag_r.
+ apply lt_trans with (p+q); auto.
+ apply add_lt_mono_l, lt_succ_diag_r.
+Qed.
+
+Lemma lt_not_add_l p q : ~ p+q < p.
+Proof.
+ intro H. elim (lt_irrefl p).
+ apply lt_trans with (p+q); auto using lt_add_r.
+Qed.
+
+Lemma pow_gt_1 n p : 1<n -> 1<n^p.
+Proof.
+ intros H. induction p using peano_ind.
+ now rewrite pow_1_r.
+ rewrite pow_succ_r.
+ apply lt_trans with (n*1).
+ now rewrite mul_1_r.
+ now apply mul_lt_mono_l.
+Qed.
+
+(**********************************************************************)
+(** * Properties of subtraction on binary positive numbers *)
+
+Lemma sub_1_r p : sub p 1 = pred p.
+Proof.
+  now destruct p.
+Qed.
+
+Lemma pred_sub p : pred p = sub p 1.
+Proof.
+  symmetry. apply sub_1_r.
+Qed.
+
+Theorem sub_succ_r p q : p - (succ q) = pred (p - q).
+Proof.
+  unfold sub; rewrite sub_mask_succ_r, sub_mask_carry_spec.
+  destruct (sub_mask p q) as [|[r|r| ]|]; auto.
+Qed.
+
+(** ** Properties of subtraction without underflow *)
+
+Lemma sub_mask_pos' p q :
+  q < p -> exists r, sub_mask p q = IsPos r /\ q + r = p.
+Proof.
+ rewrite lt_iff_add. intros (r,Hr). exists r. split; trivial.
+ now apply sub_mask_pos_iff.
+Qed.
+
+Lemma sub_mask_pos p q :
+  q < p -> exists r, sub_mask p q = IsPos r.
+Proof.
+ intros H. destruct (sub_mask_pos' p q H) as (r & Hr & _). now exists r.
+Qed.
+
+Theorem sub_add p q : q < p -> (p-q)+q = p.
+Proof.
+  intros H. destruct (sub_mask_pos p q H) as (r,U).
+  unfold sub. rewrite U. rewrite add_comm. now apply sub_mask_add.
+Qed.
+
+Lemma add_sub p q : (p+q)-q = p.
+Proof.
+ intros. apply add_reg_r with q.
+ rewrite sub_add; trivial.
+ rewrite add_comm. apply lt_add_r.
+Qed.
+
+Lemma mul_sub_distr_l p q r : r<q -> p*(q-r) = p*q-p*r.
+Proof.
+ intros H.
+ apply add_reg_r with (p*r).
+ rewrite <- mul_add_distr_l.
+ rewrite sub_add; trivial.
+ symmetry. apply sub_add; trivial.
+ now apply mul_lt_mono_l.
+Qed.
+
+Lemma mul_sub_distr_r p q r : q<p -> (p-q)*r = p*r-q*r.
+Proof.
+ intros H. rewrite 3 (mul_comm _ r). now apply mul_sub_distr_l.
+Qed.
+
+Lemma sub_lt_mono_l p q r: q<p -> p<r -> r-p < r-q.
+Proof.
+ intros Hqp Hpr.
+ apply (add_lt_mono_r p).
+ rewrite sub_add by trivial.
+ apply le_lt_trans with ((r-q)+q).
+ rewrite sub_add by (now apply lt_trans with p).
+ apply le_refl.
+ now apply add_lt_mono_l.
+Qed.
+
+Lemma sub_compare_mono_l p q r :
+ q<p -> r<p -> (p-q ?= p-r) = (r ?= q).
+Proof.
+ intros Hqp Hrp.
+ case (compare_spec r q); intros H. subst. apply compare_refl.
+ apply sub_lt_mono_l; trivial.
+ apply lt_gt, sub_lt_mono_l; trivial.
+Qed.
+
+Lemma sub_compare_mono_r p q r :
+ p<q -> p<r -> (q-p ?= r-p) = (q ?= r).
+Proof.
+ intros. rewrite <- (add_compare_mono_r p), 2 sub_add; trivial.
+Qed.
+
+Lemma sub_lt_mono_r p q r : q<p -> r<q -> q-r < p-r.
+Proof.
+ intros. unfold lt. rewrite sub_compare_mono_r; trivial.
+ now apply lt_trans with q.
+Qed.
+
+Lemma sub_decr n m : m<n -> n-m < n.
+Proof.
+ intros.
+ apply add_lt_mono_r with m.
+ rewrite sub_add; trivial.
+ apply lt_add_r.
+Qed.
+
+Lemma add_sub_assoc p q r : r<q -> p+(q-r) = p+q-r.
+Proof.
+ intros.
+ apply add_reg_r with r.
+ rewrite <- add_assoc, !sub_add; trivial.
+ rewrite add_comm. apply lt_trans with q; trivial using lt_add_r.
+Qed.
+
+Lemma sub_add_distr p q r : q+r < p -> p-(q+r) = p-q-r.
+Proof.
+ intros.
+ assert (q < p)
+  by (apply lt_trans with (q+r); trivial using lt_add_r).
+ rewrite (add_comm q r) in *.
+ apply add_reg_r with (r+q).
+ rewrite sub_add by trivial.
+ rewrite add_assoc, !sub_add; trivial.
+ apply (add_lt_mono_r q). rewrite sub_add; trivial.
+Qed.
+
+Lemma sub_sub_distr p q r : r<q -> q-r < p -> p-(q-r) = p+r-q.
+Proof.
+ intros.
+ apply add_reg_r with ((q-r)+r).
+ rewrite add_assoc, !sub_add; trivial.
+ rewrite <- (sub_add q r); trivial.
+ now apply add_lt_mono_r.
+Qed.
+
+(** Recursive equations for [sub] *)
+
+Lemma sub_xO_xO n m : m<n -> n~0 - m~0 = (n-m)~0.
+Proof.
+ intros H. unfold sub. simpl.
+ now destruct (sub_mask_pos n m H) as (p, ->).
+Qed.
+
+Lemma sub_xI_xI n m : m<n -> n~1 - m~1 = (n-m)~0.
+Proof.
+ intros H. unfold sub. simpl.
+ now destruct (sub_mask_pos n m H) as (p, ->).
+Qed.
+
+Lemma sub_xI_xO n m : m<n -> n~1 - m~0 = (n-m)~1.
+Proof.
+ intros H. unfold sub. simpl.
+ now destruct (sub_mask_pos n m) as (p, ->).
+Qed.
+
+Lemma sub_xO_xI n m : n~0 - m~1 = pred_double (n-m).
+Proof.
+ unfold sub. simpl. rewrite sub_mask_carry_spec.
+ now destruct (sub_mask n m) as [|[r|r|]|].
+Qed.
+
+(** Properties of subtraction with underflow *)
+
+Lemma sub_mask_neg_iff' p q : sub_mask p q = IsNeg <-> p < q.
+Proof.
+  rewrite lt_iff_add. apply sub_mask_neg_iff.
+Qed.
+
+Lemma sub_mask_neg p q : p<q -> sub_mask p q = IsNeg.
+Proof.
+  apply sub_mask_neg_iff'.
+Qed.
+
+Lemma sub_le p q : p<=q -> p-q = 1.
+Proof.
+  unfold le, sub. rewrite compare_sub_mask.
+  destruct sub_mask; easy'.
+Qed.
+
+Lemma sub_lt p q : p<q -> p-q = 1.
+Proof.
+  intros. now apply sub_le, lt_le_incl.
+Qed.
+
+Lemma sub_diag p : p-p = 1.
+Proof.
+  unfold sub. now rewrite sub_mask_diag.
+Qed.
+
+(** ** Results concerning [size] and [size_nat] *)
+
+Lemma size_nat_monotone p q : p<q -> (size_nat p <= size_nat q)%nat.
+Proof.
+  assert (le0 : forall n, (0<=n)%nat) by (induction n; auto).
+  assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto).
+  revert q.
+  induction p; destruct q; simpl; intros; auto; easy || apply leS;
+   red in H; simpl_compare_in H.
+  apply IHp. red. now destruct (p?=q).
+  destruct (compare_spec p q); subst; now auto.
+Qed.
+
+Lemma size_gt p : p < 2^(size p).
+Proof.
+ induction p; simpl; try rewrite pow_succ_r; try easy.
+ apply le_succ_l in IHp. now apply le_succ_l.
+Qed.
+
+Lemma size_le p : 2^(size p) <= p~0.
+Proof.
+ induction p; simpl; try rewrite pow_succ_r; try easy.
+ apply mul_le_mono_l.
+ apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp.
+Qed.
+
+(** ** Properties of [min] and [max] *)
+
+(** First, the specification *)
+
+Lemma max_l : forall x y, y<=x -> max x y = x.
+Proof.
+ intros x y H. unfold max. case compare_spec; auto.
+ intros H'. apply le_nlt in H. now elim H.
+Qed.
+
+Lemma max_r : forall x y, x<=y -> max x y = y.
+Proof.
+ unfold le, max. intros x y. destruct compare; easy'.
+Qed.
+
+Lemma min_l : forall x y, x<=y -> min x y = x.
+Proof.
+ unfold le, min. intros x y. destruct compare; easy'.
+Qed.
+
+Lemma min_r : forall x y, y<=x -> min x y = y.
+Proof.
+ intros x y H. unfold min. case compare_spec; auto.
+ intros H'. apply le_nlt in H. now elim H'.
+Qed.
+
+(** We hence obtain all the generic properties of [min] and [max]. *)
+
+Include !UsualMinMaxLogicalProperties.
+Include !UsualMinMaxDecProperties.
+
+(** Minimum, maximum and constant one *)
+
+Lemma max_1_l n : max 1 n = n.
+Proof.
+ unfold max. case compare_spec; auto.
+ intros H. apply lt_nle in H. elim H. apply le_1_l.
+Qed.
+
+Lemma max_1_r n : max n 1 = n.
+Proof. rewrite max_comm. apply max_1_l. Qed.
+
+Lemma min_1_l n : min 1 n = 1.
+Proof.
+ unfold min. case compare_spec; auto.
+ intros H. apply lt_nle in H. elim H. apply le_1_l.
+Qed.
+
+Lemma min_1_r n : min n 1 = 1.
+Proof. rewrite min_comm. apply min_1_l. Qed.
+
+(** Minimum, maximum and operations (consequences of monotonicity) *)
+
+Lemma succ_max_distr n m : succ (max n m) = max (succ n) (succ m).
+Proof.
+ symmetry. apply max_monotone.
+ intros x x'. apply succ_le_mono.
+Qed.
+
+Lemma succ_min_distr n m : succ (min n m) = min (succ n) (succ m).
+Proof.
+ symmetry. apply min_monotone.
+ intros x x'. apply succ_le_mono.
+Qed.
+
+Lemma add_max_distr_l n m p : max (p + n) (p + m) = p + max n m.
+Proof.
+ apply max_monotone. intros x x'. apply add_le_mono_l.
+Qed.
+
+Lemma add_max_distr_r n m p : max (n + p) (m + p) = max n m + p.
+Proof.
+ rewrite 3 (add_comm _ p). apply add_max_distr_l.
+Qed.
+
+Lemma add_min_distr_l n m p : min (p + n) (p + m) = p + min n m.
+Proof.
+ apply min_monotone. intros x x'. apply add_le_mono_l.
+Qed.
+
+Lemma add_min_distr_r n m p : min (n + p) (m + p) = min n m + p.
+Proof.
+ rewrite 3 (add_comm _ p). apply add_min_distr_l.
+Qed.
+
+Lemma mul_max_distr_l n m p : max (p * n) (p * m) = p * max n m.
+Proof.
+ apply max_monotone. intros x x'. apply mul_le_mono_l.
+Qed.
+
+Lemma mul_max_distr_r n m p : max (n * p) (m * p) = max n m * p.
+Proof.
+ rewrite 3 (mul_comm _ p). apply mul_max_distr_l.
+Qed.
+
+Lemma mul_min_distr_l n m p : min (p * n) (p * m) = p * min n m.
+Proof.
+ apply min_monotone. intros x x'. apply mul_le_mono_l.
+Qed.
+
+Lemma mul_min_distr_r n m p : min (n * p) (m * p) = min n m * p.
+Proof.
+ rewrite 3 (mul_comm _ p). apply mul_min_distr_l.
+Qed.
+
+
+(** ** Results concerning [iter_op] *)
+
+Lemma iter_op_succ : forall A (op:A->A->A),
+ (forall x y z, op x (op y z) = op (op x y) z) ->
+ forall p a,
+ iter_op op (succ p) a = op a (iter_op op p a).
+Proof.
+ induction p; simpl; intros; trivial.
+ rewrite H. apply IHp.
+Qed.
+
+(** ** Results about [of_nat] and [of_succ_nat] *)
+
+Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n).
+Proof.
+ induction n. trivial. simpl. f_equal. now rewrite IHn.
+Qed.
+
+Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n.
+Proof.
+ destruct n. trivial. simpl pred. rewrite pred_succ. apply of_nat_succ.
+Qed.
+
+Lemma succ_of_nat (n:nat) : n<>O -> succ (of_nat n) = of_succ_nat n.
+Proof.
+ rewrite of_nat_succ. destruct n; trivial. now destruct 1.
+Qed.
+
+(** ** Correctness proofs for the square root function *)
+
+Inductive SqrtSpec : positive*mask -> positive -> Prop :=
+ | SqrtExact s x : x=s*s -> SqrtSpec (s,IsNul) x
+ | SqrtApprox s r x : x=s*s+r -> r <= s~0 -> SqrtSpec (s,IsPos r) x.
+
+Lemma sqrtrem_step_spec f g p x :
+ (f=xO \/ f=xI) -> (g=xO \/ g=xI) ->
+ SqrtSpec p x -> SqrtSpec (sqrtrem_step f g p) (g (f x)).
+Proof.
+intros Hf Hg [ s _ -> | s r _ -> Hr ].
+(* exact *)
+unfold sqrtrem_step.
+destruct Hf,Hg; subst; simpl; constructor; now rewrite ?square_xO.
+(* approx *)
+assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q))
+ by (intros; destruct Hf, Hg; now subst).
+unfold sqrtrem_step, leb.
+case compare_spec; [intros EQ | intros LT | intros GT].
+(* - EQ *)
+rewrite <- EQ, sub_mask_diag. constructor.
+destruct Hg; subst g; destr_eq EQ.
+destruct Hf; subst f; destr_eq EQ.
+subst. now rewrite square_xI.
+(* - LT *)
+destruct (sub_mask_pos' _ _ LT) as (y & -> & H). constructor.
+rewrite Hfg, <- H. now rewrite square_xI, add_assoc. clear Hfg.
+rewrite <- lt_succ_r in Hr. change (r < s~1) in Hr.
+rewrite <- lt_succ_r, (add_lt_mono_l (s~0~1)), H. simpl.
+rewrite add_carry_spec, add_diag. simpl.
+destruct Hf,Hg; subst; red; simpl_compare; now rewrite Hr.
+(* - GT *)
+constructor. now rewrite Hfg, square_xO. apply lt_succ_r, GT.
+Qed.
+
+Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p.
+Proof.
+revert p. fix 1.
+ destruct p; try destruct p; try (constructor; easy);
+  apply sqrtrem_step_spec; auto.
+Qed.
+
+Lemma sqrt_spec p :
+ let s := sqrt p in s*s <= p < (succ s)*(succ s).
+Proof.
+ simpl.
+ assert (H:=sqrtrem_spec p).
+ unfold sqrt in *. destruct sqrtrem as (s,rm); simpl.
+ inversion_clear H; subst.
+ (* exact *)
+ split. reflexivity. apply mul_lt_mono; apply lt_succ_diag_r.
+ (* approx *)
+ split.
+ apply lt_le_incl, lt_add_r.
+ rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l.
+ rewrite add_assoc, (add_comm _ r). apply add_lt_mono_r.
+ now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r.
+Qed.
+
+(** ** Correctness proofs for the gcd function *)
+
+Lemma divide_add_cancel_l p q r : (p | r) -> (p | q + r) -> (p | q).
+Proof.
+ intros (s,Hs) (t,Ht).
+ exists (t-s).
+ rewrite mul_sub_distr_r.
+ rewrite <- Hs, <- Ht.
+ symmetry. apply add_sub.
+ apply mul_lt_mono_r with p.
+ rewrite <- Hs, <- Ht, add_comm.
+ apply lt_add_r.
+Qed.
+
+Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q).
+Proof.
+ intros (s,Hs) (t,Ht).
+ destruct p.
+ destruct s; try easy. simpl in Hs. destr_eq Hs. now exists s.
+ rewrite mul_xO_r in Ht; discriminate.
+ exists q; now rewrite mul_1_r.
+Qed.
+
+Lemma divide_xO_xO p q : (p~0|q~0) <-> (p|q).
+Proof.
+ split; intros (r,H); simpl in *.
+ rewrite mul_xO_r in H. destr_eq H. now exists r.
+ exists r; simpl. rewrite mul_xO_r. f_equal; auto.
+Qed.
+
+Lemma divide_mul_l p q r : (p|q) -> (p|q*r).
+Proof.
+ intros (s,H). exists (s*r).
+ rewrite <- mul_assoc, (mul_comm r p), mul_assoc. now f_equal.
+Qed.
+
+Lemma divide_mul_r p q r : (p|r) -> (p|q*r).
+Proof.
+ rewrite mul_comm. apply divide_mul_l.
+Qed.
+
+(** The first component of ggcd is gcd *)
+
+Lemma ggcdn_gcdn : forall n a b,
+  fst (ggcdn n a b) = gcdn n a b.
+Proof.
+ induction n.
+ simpl; auto.
+ destruct a, b; simpl; auto; try case compare_spec; simpl; trivial;
+  rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto.
+Qed.
+
+Lemma ggcd_gcd : forall a b, fst (ggcd a b) = gcd a b.
+Proof.
+ unfold ggcd, gcd. intros. apply ggcdn_gcdn.
+Qed.
+
+(** The other components of ggcd are indeed the correct factors. *)
+
+Ltac destr_pggcdn IHn :=
+ match goal with |- context [ ggcdn _ ?x ?y ] =>
+  generalize (IHn x y); destruct ggcdn as (g,(u,v)); simpl
+ end.
+
+Lemma ggcdn_correct_divisors : forall n a b,
+  let '(g,(aa,bb)) := ggcdn n a b in
+  a = g*aa /\ b = g*bb.
+Proof.
+ induction n.
+ simpl; auto.
+ destruct a, b; simpl; auto; try case compare_spec; try destr_pggcdn IHn.
+ (* Eq *)
+ intros ->. now rewrite mul_comm.
+ (* Lt *)
+ intros (H',H) LT; split; auto.
+ rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'.
+ simpl. f_equal. symmetry.
+ rewrite add_comm. now apply sub_add.
+ (* Gt *)
+ intros (H',H) LT; split; auto.
+ rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'.
+ simpl. f_equal. symmetry.
+ rewrite add_comm. now apply sub_add.
+ (* Then... *)
+ intros (H,H'); split; auto. rewrite mul_xO_r, H'; auto.
+ intros (H,H'); split; auto. rewrite mul_xO_r, H; auto.
+ intros (H,H'); split; subst; auto.
+Qed.
+
+Lemma ggcd_correct_divisors : forall a b,
+  let '(g,(aa,bb)) := ggcd a b in
+  a=g*aa /\ b=g*bb.
+Proof.
+ unfold ggcd. intros. apply ggcdn_correct_divisors.
+Qed.
+
+(** We can use this fact to prove a part of the gcd correctness *)
+
+Lemma gcd_divide_l : forall a b, (gcd a b | a).
+Proof.
+ intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa.
+  now rewrite mul_comm.
+Qed.
+
+Lemma gcd_divide_r : forall a b, (gcd a b | b).
+Proof.
+ intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb.
+  now rewrite mul_comm.
+Qed.
+
+(** We now prove directly that gcd is the greatest amongst common divisors *)
+
+Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat ->
+ forall p, (p|a) -> (p|b) -> (p|gcdn n a b).
+Proof.
+ induction n.
+ destruct a, b; simpl; inversion 1.
+ destruct a, b; simpl; try case compare_spec; simpl; auto.
+ (* Lt *)
+ intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial.
+ apply le_S_n in LE. eapply Le.le_trans; [|eapply LE].
+ rewrite plus_comm, <- plus_n_Sm, <- plus_Sn_m.
+ apply plus_le_compat; trivial.
+ apply size_nat_monotone, sub_decr, LT.
+ apply divide_xO_xI with a; trivial.
+ apply (divide_add_cancel_l p _ a~1); trivial.
+ now rewrite <- sub_xI_xI, sub_add.
+ (* Gt *)
+ intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial.
+ apply le_S_n in LE. eapply Le.le_trans; [|eapply LE].
+ apply plus_le_compat; trivial.
+ apply size_nat_monotone, sub_decr, LT.
+ apply divide_xO_xI with b; trivial.
+ apply (divide_add_cancel_l p _ b~1); trivial.
+ now rewrite <- sub_xI_xI, sub_add.
+ (* a~1 b~0 *)
+ intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial.
+ apply le_S_n in LE. simpl. now rewrite plus_n_Sm.
+ apply divide_xO_xI with a; trivial.
+ (* a~0 b~1 *)
+ intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial.
+ simpl. now apply le_S_n.
+ apply divide_xO_xI with b; trivial.
+ (* a~0 b~0 *)
+ intros LE p Hp1 Hp2.
+ destruct p.
+ change (gcdn n a b)~0 with (2*(gcdn n a b)).
+ apply divide_mul_r.
+ apply IHn; clear IHn.
+ apply le_S_n in LE. apply le_Sn_le. now rewrite plus_n_Sm.
+ apply divide_xO_xI with p; trivial. now exists 1.
+ apply divide_xO_xI with p; trivial. now exists 1.
+ apply divide_xO_xO.
+ apply IHn; clear IHn.
+ apply le_S_n in LE. apply le_Sn_le. now rewrite plus_n_Sm.
+ now apply divide_xO_xO.
+ now apply divide_xO_xO.
+ exists (gcdn n a b)~0. now rewrite mul_1_r.
+Qed.
+
+Lemma gcd_greatest : forall a b p, (p|a) -> (p|b) -> (p|gcd a b).
+Proof.
+ intros. apply gcdn_greatest; auto.
+Qed.
+
+(** As a consequence, the rests after division by gcd are relatively prime *)
+
+Lemma ggcd_greatest : forall a b,
+ let (aa,bb) := snd (ggcd a b) in
+ forall p, (p|aa) -> (p|bb) -> p=1.
+Proof.
+ intros. generalize (gcd_greatest a b) (ggcd_correct_divisors a b).
+ rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl.
+ intros H (EQa,EQb) p Hp1 Hp2; subst.
+ assert (H' : (g*p | g)).
+  apply H.
+  destruct Hp1 as (r,Hr). exists r.
+   now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr.
+  destruct Hp2 as (r,Hr). exists r.
+   now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr.
+ destruct H' as (q,H').
+ rewrite (mul_comm g p), mul_assoc in H'.
+ apply mul_eq_1 with q; rewrite mul_comm.
+ now apply mul_reg_r with g.
+Qed.
+
+End Pos.
+
+(** Exportation of notations *)
+
+Infix "+" := Pos.add : positive_scope.
+Infix "-" := Pos.sub : positive_scope.
+Infix "*" := Pos.mul : positive_scope.
+Infix "^" := Pos.pow : positive_scope.
+Infix "?=" := Pos.compare (at level 70, no associativity) : positive_scope.
+Infix "=?" := Pos.eqb (at level 70, no associativity) : positive_scope.
+Infix "<=?" := Pos.leb (at level 70, no associativity) : positive_scope.
+Infix "<?" := Pos.ltb (at level 70, no associativity) : positive_scope.
+Infix "<=" := Pos.le : positive_scope.
+Infix "<" := Pos.lt : positive_scope.
+Infix ">=" := Pos.ge : positive_scope.
+Infix ">" := Pos.gt : positive_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope.
+Notation "x < y < z" := (x < y /\ y < z) : positive_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope.
+
+Notation "( p | q )" := (Pos.divide p q) (at level 0) : positive_scope.
+
+(** Compatibility notations *)
+
+Notation positive := positive (only parsing).
+Notation positive_rect := positive_rect (only parsing).
+Notation positive_rec := positive_rec (only parsing).
+Notation positive_ind := positive_ind (only parsing).
+Notation xI := xI (only parsing).
+Notation xO := xO (only parsing).
+Notation xH := xH (only parsing).
+
+Notation Psucc := Pos.succ (only parsing).
+Notation Pplus := Pos.add (only parsing).
+Notation Pplus_carry := Pos.add_carry (only parsing).
+Notation Ppred := Pos.pred (only parsing).
+Notation Piter_op := Pos.iter_op (only parsing).
+Notation Piter_op_succ := Pos.iter_op_succ (only parsing).
+Notation Pmult_nat := (Pos.iter_op plus) (only parsing).
+Notation nat_of_P := Pos.to_nat (only parsing).
+Notation P_of_succ_nat := Pos.of_succ_nat (only parsing).
+Notation Pdouble_minus_one := Pos.pred_double (only parsing).
+Notation positive_mask := Pos.mask (only parsing).
+Notation IsNul := Pos.IsNul (only parsing).
+Notation IsPos := Pos.IsPos (only parsing).
+Notation IsNeg := Pos.IsNeg (only parsing).
+Notation positive_mask_rect := Pos.mask_rect (only parsing).
+Notation positive_mask_ind := Pos.mask_ind (only parsing).
+Notation positive_mask_rec := Pos.mask_rec (only parsing).
+Notation Pdouble_plus_one_mask := Pos.succ_double_mask (only parsing).
+Notation Pdouble_mask := Pos.double_mask (only parsing).
+Notation Pdouble_minus_two := Pos.double_pred_mask (only parsing).
+Notation Pminus_mask := Pos.sub_mask (only parsing).
+Notation Pminus_mask_carry := Pos.sub_mask_carry (only parsing).
+Notation Pminus := Pos.sub (only parsing).
+Notation Pmult := Pos.mul (only parsing).
+Notation iter_pos := @Pos.iter (only parsing).
+Notation Ppow := Pos.pow (only parsing).
+Notation Pdiv2 := Pos.div2 (only parsing).
+Notation Pdiv2_up := Pos.div2_up (only parsing).
+Notation Psize := Pos.size_nat (only parsing).
+Notation Psize_pos := Pos.size (only parsing).
+Notation Pcompare := Pos.compare_cont (only parsing).
+Notation Plt := Pos.lt (only parsing).
+Notation Pgt := Pos.gt (only parsing).
+Notation Ple := Pos.le (only parsing).
+Notation Pge := Pos.ge (only parsing).
+Notation Pmin := Pos.min (only parsing).
+Notation Pmax := Pos.max (only parsing).
+Notation Peqb := Pos.eqb (only parsing).
+Notation positive_eq_dec := Pos.eq_dec (only parsing).
+Notation xI_succ_xO := Pos.xI_succ_xO (only parsing).
+Notation Psucc_discr := Pos.succ_discr (only parsing).
+Notation Psucc_o_double_minus_one_eq_xO :=
+ Pos.succ_pred_double (only parsing).
+Notation Pdouble_minus_one_o_succ_eq_xI :=
+ Pos.pred_double_succ (only parsing).
+Notation xO_succ_permute := Pos.double_succ (only parsing).
+Notation double_moins_un_xO_discr :=
+ Pos.pred_double_xO_discr (only parsing).
+Notation Psucc_not_one := Pos.succ_not_1 (only parsing).
+Notation Ppred_succ := Pos.pred_succ (only parsing).
+Notation Psucc_pred := Pos.succ_pred_or (only parsing).
+Notation Psucc_inj := Pos.succ_inj (only parsing).
+Notation Pplus_carry_spec := Pos.add_carry_spec (only parsing).
+Notation Pplus_comm := Pos.add_comm (only parsing).
+Notation Pplus_succ_permute_r := Pos.add_succ_r (only parsing).
+Notation Pplus_succ_permute_l := Pos.add_succ_l (only parsing).
+Notation Pplus_no_neutral := Pos.add_no_neutral (only parsing).
+Notation Pplus_carry_plus := Pos.add_carry_add (only parsing).
+Notation Pplus_reg_r := Pos.add_reg_r (only parsing).
+Notation Pplus_reg_l := Pos.add_reg_l (only parsing).
+Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (only parsing).
+Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (only parsing).
+Notation Pplus_assoc := Pos.add_assoc (only parsing).
+Notation Pplus_xO := Pos.add_xO (only parsing).
+Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (only parsing).
+Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (only parsing).
+Notation Pplus_diag := Pos.add_diag (only parsing).
+Notation PeanoView := Pos.PeanoView (only parsing).
+Notation PeanoOne := Pos.PeanoOne (only parsing).
+Notation PeanoSucc := Pos.PeanoSucc (only parsing).
+Notation PeanoView_rect := Pos.PeanoView_rect (only parsing).
+Notation PeanoView_ind := Pos.PeanoView_ind (only parsing).
+Notation PeanoView_rec := Pos.PeanoView_rec (only parsing).
+Notation peanoView_xO := Pos.peanoView_xO (only parsing).
+Notation peanoView_xI := Pos.peanoView_xI (only parsing).
+Notation peanoView := Pos.peanoView (only parsing).
+Notation PeanoView_iter := Pos.PeanoView_iter (only parsing).
+Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (only parsing).
+Notation PeanoViewUnique := Pos.PeanoViewUnique (only parsing).
+Notation Prect := Pos.peano_rect (only parsing).
+Notation Prect_succ := Pos.peano_rect_succ (only parsing).
+Notation Prect_base := Pos.peano_rect_base (only parsing).
+Notation Prec := Pos.peano_rec (only parsing).
+Notation Pind := Pos.peano_ind (only parsing).
+Notation Pcase := Pos.peano_case (only parsing).
+Notation Pmult_1_r := Pos.mul_1_r (only parsing).
+Notation Pmult_Sn_m := Pos.mul_succ_l (only parsing).
+Notation Pmult_xO_permute_r := Pos.mul_xO_r (only parsing).
+Notation Pmult_xI_permute_r := Pos.mul_xI_r (only parsing).
+Notation Pmult_comm := Pos.mul_comm (only parsing).
+Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (only parsing).
+Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (only parsing).
+Notation Pmult_assoc := Pos.mul_assoc (only parsing).
+Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (only parsing).
+Notation Pmult_xO_discr := Pos.mul_xO_discr (only parsing).
+Notation Pmult_reg_r := Pos.mul_reg_r (only parsing).
+Notation Pmult_reg_l := Pos.mul_reg_l (only parsing).
+Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (only parsing).
+Notation Psquare_xO := Pos.square_xO (only parsing).
+Notation Psquare_xI := Pos.square_xI (only parsing).
+Notation iter_pos_swap_gen := Pos.iter_swap_gen (only parsing).
+Notation iter_pos_swap := Pos.iter_swap (only parsing).
+Notation iter_pos_succ := Pos.iter_succ (only parsing).
+Notation iter_pos_plus := Pos.iter_add (only parsing).
+Notation iter_pos_invariant := Pos.iter_invariant (only parsing).
+Notation Ppow_1_r := Pos.pow_1_r (only parsing).
+Notation Ppow_succ_r := Pos.pow_succ_r (only parsing).
+Notation Peqb_refl := Pos.eqb_refl (only parsing).
+Notation Peqb_eq := Pos.eqb_eq (only parsing).
+Notation Pcompare_refl_id := Pos.compare_cont_refl (only parsing).
+Notation Pcompare_eq_iff := Pos.compare_eq_iff (only parsing).
+Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (only parsing).
+Notation Pcompare_eq_Lt := Pos.compare_lt_iff (only parsing).
+Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (only parsing).
+
+Notation Pcompare_antisym := Pos.compare_cont_antisym (only parsing).
+Notation ZC1 := Pos.gt_lt (only parsing).
+Notation ZC2 := Pos.lt_gt (only parsing).
+Notation Pcompare_spec := Pos.compare_spec (only parsing).
+Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (only parsing).
+Notation Pcompare_succ_succ := Pos.compare_succ_succ (only parsing).
+Notation Pcompare_1 := Pos.nlt_1_r (only parsing).
+Notation Plt_1 := Pos.nlt_1_r (only parsing).
+Notation Plt_1_succ := Pos.lt_1_succ (only parsing).
+Notation Plt_lt_succ := Pos.lt_lt_succ (only parsing).
+Notation Plt_irrefl := Pos.lt_irrefl (only parsing).
+Notation Plt_trans := Pos.lt_trans (only parsing).
+Notation Plt_ind := Pos.lt_ind (only parsing).
+Notation Ple_lteq := Pos.le_lteq (only parsing).
+Notation Ple_refl := Pos.le_refl (only parsing).
+Notation Ple_lt_trans := Pos.le_lt_trans (only parsing).
+Notation Plt_le_trans := Pos.lt_le_trans (only parsing).
+Notation Ple_trans := Pos.le_trans (only parsing).
+Notation Plt_succ_r := Pos.lt_succ_r (only parsing).
+Notation Ple_succ_l := Pos.le_succ_l (only parsing).
+Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (only parsing).
+Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (only parsing).
+Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (only parsing).
+Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (only parsing).
+Notation Pplus_lt_mono := Pos.add_lt_mono (only parsing).
+Notation Pplus_le_mono_l := Pos.add_le_mono_l (only parsing).
+Notation Pplus_le_mono_r := Pos.add_le_mono_r (only parsing).
+Notation Pplus_le_mono := Pos.add_le_mono (only parsing).
+Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (only parsing).
+Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (only parsing).
+Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (only parsing).
+Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (only parsing).
+Notation Pmult_lt_mono := Pos.mul_lt_mono (only parsing).
+Notation Pmult_le_mono_l := Pos.mul_le_mono_l (only parsing).
+Notation Pmult_le_mono_r := Pos.mul_le_mono_r (only parsing).
+Notation Pmult_le_mono := Pos.mul_le_mono (only parsing).
+Notation Plt_plus_r := Pos.lt_add_r (only parsing).
+Notation Plt_not_plus_l := Pos.lt_not_add_l (only parsing).
+Notation Ppow_gt_1 := Pos.pow_gt_1 (only parsing).
+Notation Ppred_mask := Pos.pred_mask (only parsing).
+Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (only parsing).
+Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (only parsing).
+Notation Pminus_succ_r := Pos.sub_succ_r (only parsing).
+Notation Pminus_mask_diag := Pos.sub_mask_diag (only parsing).
+
+Notation Pplus_minus_eq := Pos.add_sub (only parsing).
+Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (only parsing).
+Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (only parsing).
+Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (only parsing).
+Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (only parsing).
+Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (only parsing).
+Notation Pminus_decr := Pos.sub_decr (only parsing).
+Notation Pminus_xI_xI := Pos.sub_xI_xI (only parsing).
+Notation Pplus_minus_assoc := Pos.add_sub_assoc (only parsing).
+Notation Pminus_plus_distr := Pos.sub_add_distr (only parsing).
+Notation Pminus_minus_distr := Pos.sub_sub_distr (only parsing).
+Notation Pminus_mask_Lt := Pos.sub_mask_neg (only parsing).
+Notation Pminus_Lt := Pos.sub_lt (only parsing).
+Notation Pminus_Eq := Pos.sub_diag (only parsing).
+Notation Psize_monotone := Pos.size_nat_monotone (only parsing).
+Notation Psize_pos_gt := Pos.size_gt (only parsing).
+Notation Psize_pos_le := Pos.size_le (only parsing).
+
+(** More complex compatibility facts, expressed as lemmas
+    (to preserve scopes for instance) *)
+
+Lemma Peqb_true_eq x y : Pos.eqb x y = true -> x=y.
+Proof. apply Pos.eqb_eq. Qed.
+Lemma Pcompare_eq_Gt p q : (p ?= q) = Gt <-> p > q.
+Proof. reflexivity. Qed.
+Lemma Pplus_one_succ_r p : Psucc p = p + 1.
+Proof (eq_sym (Pos.add_1_r p)).
+Lemma Pplus_one_succ_l p : Psucc p = 1 + p.
+Proof (eq_sym (Pos.add_1_l p)).
+Lemma Pcompare_refl p : Pcompare p p Eq = Eq.
+Proof (Pos.compare_cont_refl p Eq).
+Lemma Pcompare_Eq_eq : forall p q, Pcompare p q Eq = Eq -> p = q.
+Proof Pos.compare_eq.
+Lemma ZC4 p q : Pcompare p q Eq = CompOpp (Pcompare q p Eq).
+Proof (Pos.compare_antisym q p).
+Lemma Ppred_minus p : Ppred p = p - 1.
+Proof (eq_sym (Pos.sub_1_r p)).
+
+Lemma Pminus_mask_Gt p q :
+  p > q ->
+  exists h : positive,
+   Pminus_mask p q = IsPos h /\
+   q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred h)).
+Proof.
+ intros H. apply Pos.gt_lt in H.
+ destruct (Pos.sub_mask_pos p q H) as (r & U).
+ exists r. repeat split; trivial.
+ now apply Pos.sub_mask_pos_iff.
+ destruct (Pos.eq_dec r 1) as [EQ|NE]; [now left|right].
+ rewrite Pos.sub_mask_carry_spec, U. destruct r; trivial. now elim NE.
+Qed.
+
+Lemma Pplus_minus : forall p q, p > q -> q+(p-q) = p.
+Proof.
+ intros. rewrite Pos.add_comm. now apply Pos.sub_add, Pos.gt_lt.
+Qed.
+
+(** Discontinued results of little interest and little/zero use
+    in user contributions:
+
+    Pplus_carry_no_neutral
+    Pplus_carry_pred_eq_plus
+    Pcompare_not_Eq
+    Pcompare_Lt_Lt
+    Pcompare_Lt_eq_Lt
+    Pcompare_Gt_Gt
+    Pcompare_Gt_eq_Gt
+    Psucc_lt_compat
+    Psucc_le_compat
+    ZC3
+    Pcompare_p_Sq
+    Pminus_mask_carry_diag
+    Pminus_mask_IsNeg
+    ZL10
+    ZL11
+    double_eq_zero_inversion
+    double_plus_one_zero_discr
+    double_plus_one_eq_one_inversion
+    double_eq_one_discr
+
+    Infix "/" := Pdiv2 : positive_scope.
+*)
+
+(** Old stuff, to remove someday *)
+
+Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt.
+Proof.
+  destruct r; auto.
+Qed.
+
+(** Incompatibilities :
+
+ - [(_ ?= _)%positive] expects no arg now, and designates [Pos.compare]
+   which is convertible but syntactically distinct to
+   [Pos.compare_cont .. .. Eq].
+
+ - [Pmult_nat] cannot be unfolded (unfold [Pos.iter_op] instead).
+
+*)
diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v
new file mode 100644
index 00000000..7916511a
--- /dev/null
+++ b/theories/PArith/BinPosDef.v
@@ -0,0 +1,565 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(**********************************************************************)
+(** * Binary positive numbers, operations *)
+(**********************************************************************)
+
+(** Initial development by Pierre Crégut, CNET, Lannion, France *)
+
+(** The type [positive] and its constructors [xI] and [xO] and [xH]
+    are now defined in [BinNums.v] *)
+
+Require Export BinNums.
+
+(** 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)
+ (at level 7, left associativity, format "p '~' '1'") : positive_scope.
+Notation "p ~ 0" := (xO p)
+ (at level 7, left associativity, format "p '~' '0'") : positive_scope.
+
+Local Open Scope positive_scope.
+Local Unset Boolean Equality Schemes.
+Local Unset Case Analysis Schemes.
+
+Module Pos.
+
+Definition t := positive.
+
+(** * Operations over positive numbers *)
+
+(** ** Successor *)
+
+Fixpoint succ x :=
+  match x with
+    | p~1 => (succ p)~0
+    | p~0 => p~1
+    | 1 => 1~0
+  end.
+
+(** ** Addition *)
+
+Fixpoint add x y :=
+  match x, y with
+    | p~1, q~1 => (add_carry p q)~0
+    | p~1, q~0 => (add p q)~1
+    | p~1, 1 => (succ p)~0
+    | p~0, q~1 => (add p q)~1
+    | p~0, q~0 => (add p q)~0
+    | p~0, 1 => p~1
+    | 1, q~1 => (succ q)~0
+    | 1, q~0 => q~1
+    | 1, 1 => 1~0
+  end
+
+with add_carry x y :=
+  match x, y with
+    | p~1, q~1 => (add_carry p q)~1
+    | p~1, q~0 => (add_carry p q)~0
+    | p~1, 1 => (succ p)~1
+    | p~0, q~1 => (add_carry p q)~0
+    | p~0, q~0 => (add p q)~1
+    | p~0, 1 => (succ p)~0
+    | 1, q~1 => (succ q)~1
+    | 1, q~0 => (succ q)~0
+    | 1, 1 => 1~1
+  end.
+
+Infix "+" := add : positive_scope.
+
+(** ** Operation [x -> 2*x-1] *)
+
+Fixpoint pred_double x :=
+  match x with
+    | p~1 => p~0~1
+    | p~0 => (pred_double p)~1
+    | 1 => 1
+  end.
+
+(** ** Predecessor *)
+
+Definition pred x :=
+  match x with
+    | p~1 => p~0
+    | p~0 => pred_double p
+    | 1 => 1
+  end.
+
+(** ** The predecessor of a positive number can be seen as a [N] *)
+
+Definition pred_N x :=
+  match x with
+    | p~1 => Npos (p~0)
+    | p~0 => Npos (pred_double p)
+    | 1 => N0
+  end.
+
+(** ** An auxiliary type for subtraction *)
+
+Inductive mask : Set :=
+| IsNul : mask
+| IsPos : positive -> mask
+| IsNeg : mask.
+
+(** ** Operation [x -> 2*x+1] *)
+
+Definition succ_double_mask (x:mask) : mask :=
+  match x with
+    | IsNul => IsPos 1
+    | IsNeg => IsNeg
+    | IsPos p => IsPos p~1
+  end.
+
+(** ** Operation [x -> 2*x] *)
+
+Definition double_mask (x:mask) : mask :=
+  match x with
+    | IsNul => IsNul
+    | IsNeg => IsNeg
+    | IsPos p => IsPos p~0
+  end.
+
+(** ** Operation [x -> 2*x-2] *)
+
+Definition double_pred_mask x : mask :=
+  match x with
+    | p~1 => IsPos p~0~0
+    | p~0 => IsPos (pred_double p)~0
+    | 1 => IsNul
+  end.
+
+(** ** Predecessor with mask *)
+
+Definition pred_mask (p : mask) : mask :=
+  match p with
+    | IsPos 1 => IsNul
+    | IsPos q => IsPos (pred q)
+    | IsNul => IsNeg
+    | IsNeg => IsNeg
+  end.
+
+(** ** Subtraction, result as a mask *)
+
+Fixpoint sub_mask (x y:positive) {struct y} : mask :=
+  match x, y with
+    | p~1, q~1 => double_mask (sub_mask p q)
+    | p~1, q~0 => succ_double_mask (sub_mask p q)
+    | p~1, 1 => IsPos p~0
+    | p~0, q~1 => succ_double_mask (sub_mask_carry p q)
+    | p~0, q~0 => double_mask (sub_mask p q)
+    | p~0, 1 => IsPos (pred_double p)
+    | 1, 1 => IsNul
+    | 1, _ => IsNeg
+  end
+
+with sub_mask_carry (x y:positive) {struct y} : mask :=
+  match x, y with
+    | p~1, q~1 => succ_double_mask (sub_mask_carry p q)
+    | p~1, q~0 => double_mask (sub_mask p q)
+    | p~1, 1 => IsPos (pred_double p)
+    | p~0, q~1 => double_mask (sub_mask_carry p q)
+    | p~0, q~0 => succ_double_mask (sub_mask_carry p q)
+    | p~0, 1 => double_pred_mask p
+    | 1, _ => IsNeg
+  end.
+
+(** ** Subtraction, result as a positive, returning 1 if [x<=y] *)
+
+Definition sub x y :=
+  match sub_mask x y with
+    | IsPos z => z
+    | _ => 1
+  end.
+
+Infix "-" := sub : positive_scope.
+
+(** ** Multiplication *)
+
+Fixpoint mul x y :=
+  match x with
+    | p~1 => y + (mul p y)~0
+    | p~0 => (mul p y)~0
+    | 1 => y
+  end.
+
+Infix "*" := mul : positive_scope.
+
+(** ** Iteration over a positive number *)
+
+Fixpoint iter (n:positive) {A} (f:A -> A) (x:A) : A :=
+  match n with
+    | xH => f x
+    | xO n' => iter n' f (iter n' f x)
+    | xI n' => f (iter n' f (iter n' f x))
+  end.
+
+(** ** Power *)
+
+Definition pow (x y:positive) := iter y (mul x) 1.
+
+Infix "^" := pow : positive_scope.
+
+(** ** Square *)
+
+Fixpoint square p :=
+  match p with
+    | p~1 => (square p + p)~0~1
+    | p~0 => (square p)~0~0
+    | 1 => 1
+  end.
+
+(** ** Division by 2 rounded below but for 1 *)
+
+Definition div2 p :=
+  match p with
+    | 1 => 1
+    | p~0 => p
+    | p~1 => p
+  end.
+
+(** Division by 2 rounded up *)
+
+Definition div2_up p :=
+ match p with
+   | 1 => 1
+   | p~0 => p
+   | p~1 => succ p
+ end.
+
+(** ** Number of digits in a positive number *)
+
+Fixpoint size_nat p : nat :=
+  match p with
+    | 1 => S O
+    | p~1 => S (size_nat p)
+    | p~0 => S (size_nat p)
+  end.
+
+(** Same, with positive output *)
+
+Fixpoint size p :=
+  match p with
+    | 1 => 1
+    | p~1 => succ (size p)
+    | p~0 => succ (size p)
+  end.
+
+(** ** Comparison on binary positive numbers *)
+
+Fixpoint compare_cont (x y:positive) (r:comparison) {struct y} : comparison :=
+  match x, y with
+    | p~1, q~1 => compare_cont p q r
+    | p~1, q~0 => compare_cont p q Gt
+    | p~1, 1 => Gt
+    | p~0, q~1 => compare_cont p q Lt
+    | p~0, q~0 => compare_cont p q r
+    | p~0, 1 => Gt
+    | 1, q~1 => Lt
+    | 1, q~0 => Lt
+    | 1, 1 => r
+  end.
+
+Definition compare x y := compare_cont x y Eq.
+
+Infix "?=" := compare (at level 70, no associativity) : positive_scope.
+
+Definition min p p' :=
+ match p ?= p' with
+ | Lt | Eq => p
+ | Gt => p'
+ end.
+
+Definition max p p' :=
+ match p ?= p' with
+ | Lt | Eq => p'
+ | Gt => p
+ end.
+
+(** ** Boolean equality and comparisons *)
+
+(** Nota: this [eqb] is not convertible with the generated [positive_beq], due
+    to a different guard argument. We keep this version for compatibility. *)
+
+Fixpoint eqb p q {struct q} :=
+  match p, q with
+    | p~1, q~1 => eqb p q
+    | p~0, q~0 => eqb p q
+    | 1, 1 => true
+    | _, _ => false
+  end.
+
+Definition leb x y :=
+ match x ?= y with Gt => false | _ => true end.
+
+Definition ltb x y :=
+ match x ?= y with Lt => true | _ => false end.
+
+Infix "=?" := eqb (at level 70, no associativity) : positive_scope.
+Infix "<=?" := leb (at level 70, no associativity) : positive_scope.
+Infix "<?" := ltb (at level 70, no associativity) : positive_scope.
+
+(** ** A Square Root function for positive numbers *)
+
+(** We procede by blocks of two digits : if p is written qbb'
+    then sqrt(p) will be sqrt(q)~0 or sqrt(q)~1.
+    For deciding easily in which case we are, we store the remainder
+    (as a mask, since it can be null).
+    Instead of copy-pasting the following code four times, we
+    factorize as an auxiliary function, with f and g being either
+    xO or xI depending of the initial digits.
+    NB: (sub_mask (g (f 1)) 4) is a hack, morally it's g (f 0).
+*)
+
+Definition sqrtrem_step (f g:positive->positive) p :=
+ match p with
+  | (s, IsPos r) =>
+    let s' := s~0~1 in
+    let r' := g (f r) in
+    if s' <=? r' then (s~1, sub_mask r' s')
+    else (s~0, IsPos r')
+  | (s,_)  => (s~0, sub_mask (g (f 1)) 4)
+ end.
+
+Fixpoint sqrtrem p : positive * mask :=
+ match p with
+  | 1 => (1,IsNul)
+  | 2 => (1,IsPos 1)
+  | 3 => (1,IsPos 2)
+  | p~0~0 => sqrtrem_step xO xO (sqrtrem p)
+  | p~0~1 => sqrtrem_step xO xI (sqrtrem p)
+  | p~1~0 => sqrtrem_step xI xO (sqrtrem p)
+  | p~1~1 => sqrtrem_step xI xI (sqrtrem p)
+ end.
+
+Definition sqrt p := fst (sqrtrem p).
+
+
+(** ** Greatest Common Divisor *)
+
+Definition divide p q := exists r, q = r*p.
+Notation "( p | q )" := (divide p q) (at level 0) : positive_scope.
+
+(** Instead of the Euclid algorithm, we use here the Stein binary
+   algorithm, which is faster for this representation. This algorithm
+   is almost structural, but in the last cases we do some recursive
+   calls on subtraction, hence the need for a counter.
+*)
+
+Fixpoint gcdn (n : nat) (a b : positive) : positive :=
+  match n with
+    | O => 1
+    | S n =>
+      match a,b with
+	| 1, _ => 1
+	| _, 1 => 1
+	| a~0, b~0 => (gcdn n a b)~0
+	| _  , b~0 => gcdn n a b
+	| a~0, _   => gcdn n a b
+	| a'~1, b'~1 =>
+          match a' ?= b' with
+	    | Eq => a
+	    | Lt => gcdn n (b'-a') a
+	    | Gt => gcdn n (a'-b') b
+          end
+      end
+  end.
+
+(** We'll show later that we need at most (log2(a.b)) loops *)
+
+Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b.
+
+(** Generalized Gcd, also computing the division of a and b by the gcd *)
+
+Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) :=
+  match n with
+    | O => (1,(a,b))
+    | S n =>
+      match a,b with
+	| 1, _ => (1,(1,b))
+	| _, 1 => (1,(a,1))
+	| a~0, b~0 =>
+           let (g,p) := ggcdn n a b in
+           (g~0,p)
+	| _, b~0 =>
+           let '(g,(aa,bb)) := ggcdn n a b in
+           (g,(aa, bb~0))
+	| a~0, _ =>
+           let '(g,(aa,bb)) := ggcdn n a b in
+           (g,(aa~0, bb))
+	| a'~1, b'~1 =>
+           match a' ?= b' with
+	     | Eq => (a,(1,1))
+	     | Lt =>
+	        let '(g,(ba,aa)) := ggcdn n (b'-a') a in
+	        (g,(aa, aa + ba~0))
+	     | Gt =>
+		let '(g,(ab,bb)) := ggcdn n (a'-b') b in
+		(g,(bb + ab~0, bb))
+	   end
+      end
+  end.
+
+Definition ggcd (a b: positive) := ggcdn (size_nat a + size_nat b)%nat a b.
+
+(** Local copies of the not-yet-available [N.double] and [N.succ_double] *)
+
+Definition Nsucc_double x :=
+  match x with
+  | N0 => Npos 1
+  | Npos p => Npos p~1
+  end.
+
+Definition Ndouble n :=
+  match n with
+  | N0 => N0
+  | Npos p => Npos p~0
+  end.
+
+(** Operation over bits. *)
+
+(** Logical [or] *)
+
+Fixpoint lor (p q : positive) : positive :=
+  match p, q with
+    | 1, q~0 => q~1
+    | 1, _ => q
+    | p~0, 1 => p~1
+    | _, 1 => p
+    | p~0, q~0 => (lor p q)~0
+    | p~0, q~1 => (lor p q)~1
+    | p~1, q~0 => (lor p q)~1
+    | p~1, q~1 => (lor p q)~1
+  end.
+
+(** Logical [and] *)
+
+Fixpoint land (p q : positive) : N :=
+  match p, q with
+    | 1, q~0 => N0
+    | 1, _ => Npos 1
+    | p~0, 1 => N0
+    | _, 1 => Npos 1
+    | p~0, q~0 => Ndouble (land p q)
+    | p~0, q~1 => Ndouble (land p q)
+    | p~1, q~0 => Ndouble (land p q)
+    | p~1, q~1 => Nsucc_double (land p q)
+  end.
+
+(** Logical [diff] *)
+
+Fixpoint ldiff (p q:positive) : N :=
+  match p, q with
+    | 1, q~0 => Npos 1
+    | 1, _ => N0
+    | _~0, 1 => Npos p
+    | p~1, 1 => Npos (p~0)
+    | p~0, q~0 => Ndouble (ldiff p q)
+    | p~0, q~1 => Ndouble (ldiff p q)
+    | p~1, q~1 => Ndouble (ldiff p q)
+    | p~1, q~0 => Nsucc_double (ldiff p q)
+  end.
+
+(** [xor] *)
+
+Fixpoint lxor (p q:positive) : N :=
+  match p, q with
+    | 1, 1 => N0
+    | 1, q~0 => Npos (q~1)
+    | 1, q~1 => Npos (q~0)
+    | p~0, 1 => Npos (p~1)
+    | p~0, q~0 => Ndouble (lxor p q)
+    | p~0, q~1 => Nsucc_double (lxor p q)
+    | p~1, 1 => Npos (p~0)
+    | p~1, q~0 => Nsucc_double (lxor p q)
+    | p~1, q~1 => Ndouble (lxor p q)
+  end.
+
+(** Shifts. NB: right shift of 1 stays at 1. *)
+
+Definition shiftl_nat (p:positive)(n:nat) := nat_iter n xO p.
+Definition shiftr_nat (p:positive)(n:nat) := nat_iter n div2 p.
+
+Definition shiftl (p:positive)(n:N) :=
+  match n with
+    | N0 => p
+    | Npos n => iter n xO p
+  end.
+
+Definition shiftr (p:positive)(n:N) :=
+  match n with
+    | N0 => p
+    | Npos n => iter n div2 p
+  end.
+
+(** Checking whether a particular bit is set or not *)
+
+Fixpoint testbit_nat (p:positive) : nat -> bool :=
+  match p with
+    | 1 => fun n => match n with
+                      | O => true
+                      | S _ => false
+                    end
+    | p~0 => fun n => match n with
+                        | O => false
+                        | S n' => testbit_nat p n'
+                      end
+    | p~1 => fun n => match n with
+                        | O => true
+                        | S n' => testbit_nat p n'
+                      end
+  end.
+
+(** Same, but with index in N *)
+
+Fixpoint testbit (p:positive)(n:N) :=
+  match p, n with
+    | p~0, N0 => false
+    | _, N0 => true
+    | 1, _ => false
+    | p~0, Npos n => testbit p (pred_N n)
+    | p~1, Npos n => testbit p (pred_N n)
+  end.
+
+(** ** From binary positive numbers to Peano natural numbers *)
+
+Definition iter_op {A}(op:A->A->A) :=
+  fix iter (p:positive)(a:A) : A :=
+  match p with
+    | 1 => a
+    | p~0 => iter p (op a a)
+    | p~1 => op a (iter p (op a a))
+  end.
+
+Definition to_nat (x:positive) : nat := iter_op plus x (S O).
+
+(** ** From Peano natural numbers to binary positive numbers *)
+
+(** A version preserving positive numbers, and sending 0 to 1. *)
+
+Fixpoint of_nat (n:nat) : positive :=
+ match n with
+   | O => 1
+   | S O => 1
+   | S x => succ (of_nat x)
+ end.
+
+(* Another version that converts [n] into [n+1] *)
+
+Fixpoint of_succ_nat (n:nat) : positive :=
+  match n with
+    | O => 1
+    | S x => succ (of_succ_nat x)
+  end.
+
+End Pos.
\ No newline at end of file
diff --git a/ide/coq_tactics.mli b/theories/PArith/PArith.v
index 4c583d3a..26b8265b 100644
--- a/ide/coq_tactics.mli
+++ b/theories/PArith/PArith.v
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_tactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-val tactics : string list
+(** Library for positive natural numbers *)
 
+Require Export BinNums BinPos Pnat POrderedType.
diff --git a/theories/NArith/POrderedType.v b/theories/PArith/POrderedType.v
index 0ff03c31..de7b2b82 100644
--- a/theories/NArith/POrderedType.v
+++ b/theories/PArith/POrderedType.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,39 +12,15 @@ 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.
+Module Positive_as_DT <: UsualDecidableTypeFull := Pos.
 
 (** 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.
+Module Positive_as_OT <: OrderedTypeFull := Pos.
 
 (** Note that [Positive_as_OT] can also be seen as a [UsualOrderedType]
    and a [OrderedType] (and also as a [DecidableType]). *)
diff --git a/theories/PArith/Pnat.v b/theories/PArith/Pnat.v
new file mode 100644
index 00000000..f9df70bd
--- /dev/null
+++ b/theories/PArith/Pnat.v
@@ -0,0 +1,483 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinPos Le Lt Gt Plus Mult Minus Compare_dec.
+
+(** Properties of the injection from binary positive numbers
+    to Peano natural numbers *)
+
+(** Original development by Pierre Crégut, CNET, Lannion, France *)
+
+Local Open Scope positive_scope.
+Local Open Scope nat_scope.
+
+Module Pos2Nat.
+ Import Pos.
+
+(** [Pos.to_nat] is a morphism for successor, addition, multiplication *)
+
+Lemma inj_succ p : to_nat (succ p) = S (to_nat p).
+Proof.
+ unfold to_nat. rewrite iter_op_succ. trivial.
+ apply plus_assoc.
+Qed.
+
+Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q.
+Proof.
+ revert q. induction p using Pind; intros q.
+ now rewrite add_1_l, inj_succ.
+ now rewrite add_succ_l, !inj_succ, IHp.
+Qed.
+
+Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q.
+Proof.
+ revert q. induction p using peano_ind; simpl; intros; trivial.
+ now rewrite mul_succ_l, inj_add, IHp, inj_succ.
+Qed.
+
+(** Mapping of xH, xO and xI through [Pos.to_nat] *)
+
+Lemma inj_1 : to_nat 1 = 1.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_xO p : to_nat (xO p) = 2 * to_nat p.
+Proof.
+ exact (inj_mul 2 p).
+Qed.
+
+Lemma inj_xI p : to_nat (xI p) = S (2 * to_nat p).
+Proof.
+ now rewrite xI_succ_xO, inj_succ, inj_xO.
+Qed.
+
+(** [Pos.to_nat] maps to the strictly positive subset of [nat] *)
+
+Lemma is_succ : forall p, exists n, to_nat p = S n.
+Proof.
+ induction p using peano_ind.
+ now exists 0.
+ destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn.
+Qed.
+
+(** [Pos.to_nat] is strictly positive *)
+
+Lemma is_pos p : 0 < to_nat p.
+Proof.
+ destruct (is_succ p) as (n,->). auto with arith.
+Qed.
+
+(** [Pos.to_nat] is a bijection between [positive] and
+    non-zero [nat], with [Pos.of_nat] as reciprocal.
+    See [Nat2Pos.id] below for the dual equation. *)
+
+Theorem id p : of_nat (to_nat p) = p.
+Proof.
+ induction p using peano_ind. trivial.
+ rewrite inj_succ. rewrite <- IHp at 2.
+ now destruct (is_succ p) as (n,->).
+Qed.
+
+(** [Pos.to_nat] is hence injective *)
+
+Lemma inj p q : to_nat p = to_nat q -> p = q.
+Proof.
+ intros H. now rewrite <- (id p), <- (id q), H.
+Qed.
+
+Lemma inj_iff p q : to_nat p = to_nat q <-> p = q.
+Proof.
+ split. apply inj. intros; now subst.
+Qed.
+
+(** [Pos.to_nat] is a morphism for comparison *)
+
+Lemma inj_compare p q : (p ?= q) = nat_compare (to_nat p) (to_nat q).
+Proof.
+ revert q. induction p as [ |p IH] using peano_ind; intros q.
+ destruct (succ_pred_or q) as [Hq|Hq]; [now subst|].
+ rewrite <- Hq, lt_1_succ, inj_succ, inj_1, nat_compare_S.
+ symmetry. apply nat_compare_lt, is_pos.
+ destruct (succ_pred_or q) as [Hq|Hq]; [subst|].
+ rewrite compare_antisym, lt_1_succ, inj_succ. simpl.
+ symmetry. apply nat_compare_gt, is_pos.
+ now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH.
+Qed.
+
+(** [Pos.to_nat] is a morphism for [lt], [le], etc *)
+
+Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q.
+Proof.
+ unfold lt. now rewrite inj_compare, nat_compare_lt.
+Qed.
+
+Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q.
+Proof.
+ unfold le. now rewrite inj_compare, nat_compare_le.
+Qed.
+
+Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q.
+Proof.
+ unfold gt. now rewrite inj_compare, nat_compare_gt.
+Qed.
+
+Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q.
+Proof.
+ unfold ge. now rewrite inj_compare, nat_compare_ge.
+Qed.
+
+(** [Pos.to_nat] is a morphism for subtraction *)
+
+Theorem inj_sub p q : (q < p)%positive ->
+ to_nat (p - q) = to_nat p - to_nat q.
+Proof.
+ intro H; apply plus_reg_l with (to_nat q); rewrite le_plus_minus_r.
+ now rewrite <- inj_add, add_comm, sub_add.
+ now apply lt_le_weak, inj_lt.
+Qed.
+
+Theorem inj_sub_max p q :
+ to_nat (p - q) = Peano.max 1 (to_nat p - to_nat q).
+Proof.
+ destruct (ltb_spec q p).
+ rewrite <- inj_sub by trivial.
+ now destruct (is_succ (p - q)) as (m,->).
+ rewrite sub_le by trivial.
+ replace (to_nat p - to_nat q) with 0; trivial.
+ apply le_n_0_eq.
+ rewrite <- (minus_diag (to_nat p)).
+ now apply minus_le_compat_l, inj_le.
+Qed.
+
+Theorem inj_pred p : (1 < p)%positive ->
+ to_nat (pred p) = Peano.pred (to_nat p).
+Proof.
+ intros H. now rewrite <- Pos.sub_1_r, inj_sub, pred_of_minus.
+Qed.
+
+Theorem inj_pred_max p :
+ to_nat (pred p) = Peano.max 1 (Peano.pred (to_nat p)).
+Proof.
+ rewrite <- Pos.sub_1_r, pred_of_minus. apply inj_sub_max.
+Qed.
+
+(** [Pos.to_nat] and other operations *)
+
+Lemma inj_min p q :
+ to_nat (min p q) = Peano.min (to_nat p) (to_nat q).
+Proof.
+ unfold min. rewrite inj_compare.
+ case nat_compare_spec; intros H; symmetry.
+ apply Peano.min_l. now rewrite H.
+ now apply Peano.min_l, lt_le_weak.
+ now apply Peano.min_r, lt_le_weak.
+Qed.
+
+Lemma inj_max p q :
+ to_nat (max p q) = Peano.max (to_nat p) (to_nat q).
+Proof.
+ unfold max. rewrite inj_compare.
+ case nat_compare_spec; intros H; symmetry.
+ apply Peano.max_r. now rewrite H.
+ now apply Peano.max_r, lt_le_weak.
+ now apply Peano.max_l, lt_le_weak.
+Qed.
+
+Theorem inj_iter :
+  forall p {A} (f:A->A) (x:A),
+    Pos.iter p f x = nat_iter (to_nat p) f x.
+Proof.
+ induction p using peano_ind. trivial.
+ intros. rewrite inj_succ, iter_succ. simpl. now f_equal.
+Qed.
+
+End Pos2Nat.
+
+Module Nat2Pos.
+
+(** [Pos.of_nat] is a bijection between non-zero [nat] and
+    [positive], with [Pos.to_nat] as reciprocal.
+    See [Pos2Nat.id] above for the dual equation. *)
+
+Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n.
+Proof.
+ induction n as [|n H]; trivial. now destruct 1.
+ intros _. simpl. destruct n. trivial.
+ rewrite Pos2Nat.inj_succ. f_equal. now apply H.
+Qed.
+
+Theorem id_max (n:nat) : Pos.to_nat (Pos.of_nat n) = max 1 n.
+Proof.
+ destruct n. trivial. now rewrite id.
+Qed.
+
+(** [Pos.of_nat] is hence injective for non-zero numbers *)
+
+Lemma inj (n m : nat) : n<>0 -> m<>0 -> Pos.of_nat n = Pos.of_nat m -> n = m.
+Proof.
+ intros Hn Hm H. now rewrite <- (id n), <- (id m), H.
+Qed.
+
+Lemma inj_iff (n m : nat) : n<>0 -> m<>0 ->
+ (Pos.of_nat n = Pos.of_nat m <-> n = m).
+Proof.
+ split. now apply inj. intros; now subst.
+Qed.
+
+(** Usual operations are morphisms with respect to [Pos.of_nat]
+    for non-zero numbers. *)
+
+Lemma inj_succ (n:nat) : n<>0 -> Pos.of_nat (S n) = Pos.succ (Pos.of_nat n).
+Proof.
+intro H. apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id.
+Qed.
+
+Lemma inj_pred (n:nat) : Pos.of_nat (pred n) = Pos.pred (Pos.of_nat n).
+Proof.
+ destruct n as [|[|n]]; trivial. simpl. now rewrite Pos.pred_succ.
+Qed.
+
+Lemma inj_add (n m : nat) : n<>0 -> m<>0 ->
+ Pos.of_nat (n+m) = (Pos.of_nat n + Pos.of_nat m)%positive.
+Proof.
+intros Hn Hm. apply Pos2Nat.inj.
+rewrite Pos2Nat.inj_add, !id; trivial.
+intros H. destruct n. now destruct Hn. now simpl in H.
+Qed.
+
+Lemma inj_mul (n m : nat) : n<>0 -> m<>0 ->
+ Pos.of_nat (n*m) = (Pos.of_nat n * Pos.of_nat m)%positive.
+Proof.
+intros Hn Hm. apply Pos2Nat.inj.
+rewrite Pos2Nat.inj_mul, !id; trivial.
+intros H. apply mult_is_O in H. destruct H. now elim Hn. now elim Hm.
+Qed.
+
+Lemma inj_compare (n m : nat) : n<>0 -> m<>0 ->
+ nat_compare n m = (Pos.of_nat n ?= Pos.of_nat m).
+Proof.
+intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial.
+Qed.
+
+Lemma inj_sub (n m : nat) : m<>0 ->
+ Pos.of_nat (n-m) = (Pos.of_nat n - Pos.of_nat m)%positive.
+Proof.
+ intros Hm.
+ apply Pos2Nat.inj.
+ rewrite Pos2Nat.inj_sub_max.
+ rewrite (id m) by trivial. rewrite !id_max.
+ destruct n, m; trivial.
+Qed.
+
+Lemma inj_min (n m : nat) :
+ Pos.of_nat (min n m) = Pos.min (Pos.of_nat n) (Pos.of_nat m).
+Proof.
+ destruct n as [|n]. simpl. symmetry. apply Pos.min_l, Pos.le_1_l.
+ destruct m as [|m]. simpl. symmetry. apply Pos.min_r, Pos.le_1_l.
+ unfold Pos.min. rewrite <- inj_compare by easy.
+ case nat_compare_spec; intros H; f_equal; apply min_l || apply min_r.
+ rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak.
+Qed.
+
+Lemma inj_max (n m : nat) :
+ Pos.of_nat (max n m) = Pos.max (Pos.of_nat n) (Pos.of_nat m).
+Proof.
+ destruct n as [|n]. simpl. symmetry. apply Pos.max_r, Pos.le_1_l.
+ destruct m as [|m]. simpl. symmetry. apply Pos.max_l, Pos.le_1_l.
+ unfold Pos.max. rewrite <- inj_compare by easy.
+ case nat_compare_spec; intros H; f_equal; apply max_l || apply max_r.
+ rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak.
+Qed.
+
+End Nat2Pos.
+
+(**********************************************************************)
+(** Properties of the shifted injection from Peano natural numbers
+    to binary positive numbers *)
+
+Module Pos2SuccNat.
+
+(** Composition of [Pos.to_nat] and [Pos.of_succ_nat] is successor
+    on [positive] *)
+
+Theorem id_succ p : Pos.of_succ_nat (Pos.to_nat p) = Pos.succ p.
+Proof.
+rewrite Pos.of_nat_succ, <- Pos2Nat.inj_succ. apply Pos2Nat.id.
+Qed.
+
+(** Composition of [Pos.to_nat], [Pos.of_succ_nat] and [Pos.pred]
+    is identity on [positive] *)
+
+Theorem pred_id p : Pos.pred (Pos.of_succ_nat (Pos.to_nat p)) = p.
+Proof.
+now rewrite id_succ, Pos.pred_succ.
+Qed.
+
+End Pos2SuccNat.
+
+Module SuccNat2Pos.
+
+(** Composition of [Pos.of_succ_nat] and [Pos.to_nat] is successor on [nat] *)
+
+Theorem id_succ (n:nat) : Pos.to_nat (Pos.of_succ_nat n) = S n.
+Proof.
+rewrite Pos.of_nat_succ. now apply Nat2Pos.id.
+Qed.
+
+Theorem pred_id (n:nat) : pred (Pos.to_nat (Pos.of_succ_nat n)) = n.
+Proof.
+now rewrite id_succ.
+Qed.
+
+(** [Pos.of_succ_nat] is hence injective *)
+
+Lemma inj (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m -> n = m.
+Proof.
+ intro H. apply (f_equal Pos.to_nat) in H. rewrite !id_succ in H.
+ now injection H.
+Qed.
+
+Lemma inj_iff (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m <-> n = m.
+Proof.
+ split. apply inj. intros; now subst.
+Qed.
+
+(** Another formulation *)
+
+Theorem inv n p : Pos.to_nat p = S n -> Pos.of_succ_nat n = p.
+Proof.
+ intros H. apply Pos2Nat.inj. now rewrite id_succ.
+Qed.
+
+(** Successor and comparison are morphisms with respect to
+    [Pos.of_succ_nat] *)
+
+Lemma inj_succ n : Pos.of_succ_nat (S n) = Pos.succ (Pos.of_succ_nat n).
+Proof.
+apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ.
+Qed.
+
+Lemma inj_compare n m :
+ nat_compare n m = (Pos.of_succ_nat n ?= Pos.of_succ_nat m).
+Proof.
+rewrite Pos2Nat.inj_compare, !id_succ; trivial.
+Qed.
+
+(** Other operations, for instance [Pos.add] and [plus] aren't
+    directly related this way (we would need to compensate for
+    the successor hidden in [Pos.of_succ_nat] *)
+
+End SuccNat2Pos.
+
+(** For compatibility, old names and old-style lemmas *)
+
+Notation Psucc_S := Pos2Nat.inj_succ (only parsing).
+Notation Pplus_plus := Pos2Nat.inj_add (only parsing).
+Notation Pmult_mult := Pos2Nat.inj_mul (only parsing).
+Notation Pcompare_nat_compare := Pos2Nat.inj_compare (only parsing).
+Notation nat_of_P_xH := Pos2Nat.inj_1 (only parsing).
+Notation nat_of_P_xO := Pos2Nat.inj_xO (only parsing).
+Notation nat_of_P_xI := Pos2Nat.inj_xI (only parsing).
+Notation nat_of_P_is_S := Pos2Nat.is_succ (only parsing).
+Notation nat_of_P_pos := Pos2Nat.is_pos (only parsing).
+Notation nat_of_P_inj_iff := Pos2Nat.inj_iff (only parsing).
+Notation nat_of_P_inj := Pos2Nat.inj (only parsing).
+Notation Plt_lt := Pos2Nat.inj_lt (only parsing).
+Notation Pgt_gt := Pos2Nat.inj_gt (only parsing).
+Notation Ple_le := Pos2Nat.inj_le (only parsing).
+Notation Pge_ge := Pos2Nat.inj_ge (only parsing).
+Notation Pminus_minus := Pos2Nat.inj_sub (only parsing).
+Notation iter_nat_of_P := @Pos2Nat.inj_iter (only parsing).
+
+Notation nat_of_P_of_succ_nat := SuccNat2Pos.id_succ (only parsing).
+Notation P_of_succ_nat_of_P := Pos2SuccNat.id_succ (only parsing).
+
+Notation nat_of_P_succ_morphism := Pos2Nat.inj_succ (only parsing).
+Notation nat_of_P_plus_morphism := Pos2Nat.inj_add (only parsing).
+Notation nat_of_P_mult_morphism := Pos2Nat.inj_mul (only parsing).
+Notation nat_of_P_compare_morphism := Pos2Nat.inj_compare (only parsing).
+Notation lt_O_nat_of_P := Pos2Nat.is_pos (only parsing).
+Notation ZL4 := Pos2Nat.is_succ (only parsing).
+Notation nat_of_P_o_P_of_succ_nat_eq_succ := SuccNat2Pos.id_succ (only parsing).
+Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (only parsing).
+Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (only parsing).
+
+Lemma nat_of_P_minus_morphism p q :
+ Pcompare p q Eq = Gt -> Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q.
+Proof (fun H => Pos2Nat.inj_sub p q (ZC1 _ _ H)).
+
+Lemma nat_of_P_lt_Lt_compare_morphism p q :
+ Pcompare p q Eq = Lt -> Pos.to_nat p < Pos.to_nat q.
+Proof (proj1 (Pos2Nat.inj_lt p q)).
+
+Lemma nat_of_P_gt_Gt_compare_morphism p q :
+ Pcompare p q Eq = Gt -> Pos.to_nat p > Pos.to_nat q.
+Proof (proj1 (Pos2Nat.inj_gt p q)).
+
+Lemma nat_of_P_lt_Lt_compare_complement_morphism p q :
+ Pos.to_nat p < Pos.to_nat q -> Pcompare p q Eq = Lt.
+Proof (proj2 (Pos2Nat.inj_lt p q)).
+
+Definition nat_of_P_gt_Gt_compare_complement_morphism p q :
+ Pos.to_nat p > Pos.to_nat q -> Pcompare p q Eq = Gt.
+Proof (proj2 (Pos2Nat.inj_gt p q)).
+
+(** Old intermediate results about [Pmult_nat] *)
+
+Section ObsoletePmultNat.
+
+Lemma Pmult_nat_mult : forall p n,
+ Pmult_nat p n = Pos.to_nat p * n.
+Proof.
+ induction p; intros n; unfold Pos.to_nat; simpl.
+ f_equal. rewrite 2 IHp. rewrite <- mult_assoc.
+  f_equal. simpl. now rewrite <- plus_n_O.
+ rewrite 2 IHp. rewrite <- mult_assoc.
+  f_equal. simpl. now rewrite <- plus_n_O.
+ simpl. now rewrite <- plus_n_O.
+Qed.
+
+Lemma Pmult_nat_succ_morphism :
+ forall p n, Pmult_nat (Psucc p) n = n + Pmult_nat p n.
+Proof.
+ intros. now rewrite !Pmult_nat_mult, Pos2Nat.inj_succ.
+Qed.
+
+Theorem Pmult_nat_l_plus_morphism :
+ forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
+Proof.
+ intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply mult_plus_distr_r.
+Qed.
+
+Theorem Pmult_nat_plus_carry_morphism :
+ forall p q n, Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n.
+Proof.
+ intros. now rewrite Pos.add_carry_spec, Pmult_nat_succ_morphism.
+Qed.
+
+Lemma Pmult_nat_r_plus_morphism :
+ forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
+Proof.
+ intros. rewrite !Pmult_nat_mult. apply mult_plus_distr_l.
+Qed.
+
+Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p.
+Proof.
+ intros. rewrite Pmult_nat_mult, mult_comm. simpl. now rewrite <- plus_n_O.
+Qed.
+
+Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n.
+Proof.
+ intros. rewrite Pmult_nat_mult.
+ apply le_trans with (1*n). now rewrite mult_1_l.
+ apply mult_le_compat_r. apply Pos2Nat.is_pos.
+Qed.
+
+End ObsoletePmultNat.
diff --git a/theories/PArith/intro.tex b/theories/PArith/intro.tex
new file mode 100644
index 00000000..ffce881e
--- /dev/null
+++ b/theories/PArith/intro.tex
@@ -0,0 +1,4 @@
+\section{Binary positive integers : PArith}\label{PArith}
+
+Here are defined various arithmetical notions and their properties,
+similar to those of {\tt Arith}.
diff --git a/theories/PArith/vo.itarget b/theories/PArith/vo.itarget
new file mode 100644
index 00000000..73044e2c
--- /dev/null
+++ b/theories/PArith/vo.itarget
@@ -0,0 +1,5 @@
+BinPosDef.vo
+BinPos.vo
+Pnat.vo
+POrderedType.vo
+PArith.vo
\ No newline at end of file
diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v
index 37c4d94d..7cef5c5a 100644
--- a/theories/Program/Basics.v
+++ b/theories/Program/Basics.v
@@ -1,13 +1,11 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Basics.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Standard functions and combinators.
 
    Proofs about them require functional extensionality and can be found
@@ -19,7 +17,7 @@
 
 (** The polymorphic identity function is defined in [Datatypes]. *)
 
-Implicit Arguments id [[A]].
+Arguments id {A} x.
 
 (** Function composition. *)
 
@@ -55,5 +53,5 @@ Definition apply {A B} (f : A -> B) (x : A) := f x.
 
 (** Curryfication of [prod] is defined in [Logic.Datatypes]. *)
 
-Implicit Arguments prod_curry [[A] [B] [C]].
-Implicit Arguments prod_uncurry [[A] [B] [C]].
+Arguments prod_curry   {A B C} f p.
+Arguments prod_uncurry {A B C} f x y.
diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v
index f446b455..81316ded 100644
--- a/theories/Program/Combinators.v
+++ b/theories/Program/Combinators.v
@@ -1,13 +1,11 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Combinators.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** * Proofs about standard combinators, exports functional extensionality.
 
    Author: Matthieu Sozeau
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index f63aad43..06ff7cd1 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Equality.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Tactics related to (dependent) equality and proof irrelevance. *)
 
 Require Export ProofIrrelevance.
@@ -15,9 +13,6 @@ Require Export JMeq.
 
 Require Import Coq.Program.Tactics.
 
-Local Notation "'Π'  x .. y , P" := (forall x, .. (forall y, P) ..)
-  (at level 200, x binder, y binder, right associativity) : type_scope.
-
 Ltac is_ground_goal := 
   match goal with
     |- ?T => is_ground T
@@ -33,18 +28,12 @@ Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso.
 Definition block {A : Type} (a : A) := a.
 
 Ltac block_goal := match goal with [ |- ?T ] => change (block T) end.
-Ltac unblock_goal := unfold block at 1.
-Ltac unblock_all := unfold block in *.
+Ltac unblock_goal := cbv beta delta [block]. 
 
 (** Notation for heterogenous equality. *)
 
 Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity).
 
-(** Notation for the single element of [x = x] and [x ~= x]. *)
-
-Implicit Arguments eq_refl [[A] [x]] [A].
-Implicit Arguments JMeq_refl [[A] [x]] [A].
-
 (** Do something on an heterogeneous equality appearing in the context. *)
 
 Ltac on_JMeq tac :=
@@ -177,15 +166,15 @@ Hint Rewrite <- eq_rect_eq : refl_id.
    [coerce_* t eq_refl = t]. *)
 
 Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl.
-Proof. intros. apply proof_irrelevance. Qed.
+Proof. apply proof_irrelevance. Qed.
 
-Lemma UIP_refl_refl : Π A (x : A),
+Lemma UIP_refl_refl A (x : A) :
   Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl.
-Proof. intros. apply UIP_refl. Qed.
+Proof. apply UIP_refl. Qed.
 
-Lemma inj_pairT2_refl : Π A (x : A) (P : A -> Type) (p : P x),
+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.
+Proof. apply UIP_refl. Qed.
 
 Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id.
 
@@ -225,7 +214,7 @@ Ltac simplify_eqs :=
 
 Ltac simplify_IH_hyps := repeat
   match goal with
-    | [ hyp : context [ block _ ] |- _ ] => specialize_eqs hyp ; unfold block in hyp
+    | [ hyp : _ |- _ ] => specialize_eqs hyp
   end.
 
 (** We split substitution tactics in the two directions depending on which 
@@ -285,27 +274,31 @@ Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p.
 
 (** 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).
-Proof. intros; subst. apply X. Defined.
+Lemma solution_left A (B : A -> Type) (t : A) :
+  B t -> (forall x, x = t -> B x).
+Proof. intros; subst; assumption. Defined.
 
-Lemma solution_right : Π A (B : A -> Type) (t : A), B t -> (Π x, t = x -> B x).
-Proof. intros; subst; apply X. Defined.
+Lemma solution_right A (B : A -> Type) (t : A) :
+  B t -> (forall x, t = x -> B x).
+Proof. intros; subst; assumption. Defined.
 
-Lemma deletion : Π A B (t : A), B -> (t = t -> B).
+Lemma deletion A B (t : A) : B -> (t = t -> B).
 Proof. intros; assumption. Defined.
 
-Lemma simplification_heq : Π A B (x y : A), (x = y -> B) -> (JMeq x y -> B).
-Proof. intros; apply X; apply (JMeq_eq H). Defined.
+Lemma simplification_heq A B (x y : A) :
+  (x = y -> B) -> (JMeq x y -> B).
+Proof. intros H J; apply H; apply (JMeq_eq J). Defined.
 
-Lemma simplification_existT2 : Π A (P : A -> Type) B (p : A) (x y : P p),
+Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) :
   (x = y -> B) -> (existT P p x = existT P p y -> B).
-Proof. intros. apply X. apply inj_pair2. exact H. Defined.
+Proof. intros H E. apply H. apply inj_pair2. assumption. Defined.
 
-Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P q),
+Lemma simplification_existT1 A (P : A -> Type) B (p q : A) (x : P p) (y : P q) :
   (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 eq_refl -> (Π p : x = x, B p).
+Proof. injection 2. auto. Defined.
+
+Lemma simplification_K A (x : A) (B : x = x -> Type) :
+  B eq_refl -> (forall p : x = x, B p).
 Proof. intros. rewrite (UIP_refl A). assumption. Defined.
 
 (** This hint database and the following tactic can be used with [autounfold] to 
@@ -320,35 +313,20 @@ Hint Unfold solution_left solution_right deletion simplification_heq
    constructor forms). Compare with the lemma 16 of the paper.
    We don't have a [noCycle] procedure yet. *)
 
-Ltac block_equality id :=
-  match type of id with
-    | @eq ?A ?t ?u => change (block (@eq A t u)) in id
-    | _ => idtac
-  end.
-
-Ltac revert_blocking_until id := 
-  Tactics.on_last_hyp ltac:(fun id' =>
-    match id' with
-      | id => idtac
-      | _ => block_equality id' ; revert id' ; revert_blocking_until id
-    end).
-
 Ltac simplify_one_dep_elim_term c :=
   match c with
     | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _)
     | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _)
-    | eq (existT _ ?p _) (existT _ ?q _) -> _ =>
+    | eq (existT _ _ _) (existT _ _ _) -> _ =>
       refine (simplification_existT2 _ _ _ _ _ _ _) ||
-        match goal with
-          | H : p = q |- _ => intro
-          | _ => refine (simplification_existT1 _ _ _ _ _ _ _ _)
-        end
+        refine (simplification_existT1 _ _ _ _ _ _ _ _)
     | ?x = ?y -> _ => (* variables case *)
+      (unfold x) || (unfold y) ||
       (let hyp := fresh in intros hyp ;
-        move hyp before x ; revert_blocking_until hyp ; generalize dependent x ;
+        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 ; revert_blocking_until hyp ; generalize dependent y ;
+        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
@@ -406,18 +384,18 @@ 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 simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_all.
+Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
 
 Ltac do_intros H :=
   (try intros until H) ; (intro_block_id H || intro_block H).
 
-Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; block_goal ; tac H ; unblock_goal.
+Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H.
 
 Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim.
 
 Ltac do_depind tac H := 
-  do_intros H ; generalize_eqs_vars H ; block_goal ; tac H ; 
-  unblock_goal ; simplify_dep_elim ; simplify_IH_hyps ; unblock_all.
+  (try intros until H) ; intro_block H ;
+  generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
 
 (** To dependent elimination on some hyp. *)
 
@@ -433,26 +411,26 @@ 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_depelim' tac H :=
-  (try intros until H) ; block_goal ; generalize_eqs H ; block_goal ; tac H ; unblock_goal ;
-    simplify_dep_elim ; simplify_IH_hyps ; unblock_all.
+Ltac do_depelim' rev tac H :=
+  (try intros until H) ; block_goal ; rev H ; 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_depelim' ltac:(fun hyp => do_case hyp) H.
+  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => do_case hyp) H.
 
 Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := 
-  do_depelim' ltac:(fun hyp => destruct hyp using c) H.
+  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => destruct hyp using c) H.
 
 (** 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_depelim' ltac:(fun hyp => revert l ; do_case hyp) H.
+  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_case hyp) H.
 
 Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := 
-  do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H.
+  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => 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_depelim. We suppose the hyp has to be generalized before
@@ -467,7 +445,7 @@ Tactic Notation "dependent" "induction" ident(H) "using" constr(c) :=
 (** 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_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H.
+  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_ind hyp) H.
 
 Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := 
-  do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H.
+  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H.
diff --git a/theories/Program/Program.v b/theories/Program/Program.v
index 2b6dd864..14a7ffca 100644
--- a/theories/Program/Program.v
+++ b/theories/Program/Program.v
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Program.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Export Coq.Program.Utils.
 Require Export Coq.Program.Wf.
 Require Export Coq.Program.Equality.
 Require Export Coq.Program.Subset.
 Require Export Coq.Program.Basics.
 Require Export Coq.Program.Combinators.
-Require Export Coq.Program.Syntax.
\ No newline at end of file
+Require Export Coq.Program.Syntax.
diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v
index d0a76d3f..ca4002d7 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Subset.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Tactics related to subsets and proof irrelevance. *)
 
 Require Import Coq.Program.Utils.
diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v
index 582bc461..61d389ed 100644
--- a/theories/Program/Syntax.v
+++ b/theories/Program/Syntax.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Syntax.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Custom notations and implicits for Coq prelude definitions.
 
    Author: Matthieu Sozeau
@@ -20,48 +18,23 @@ Notation " () " := tt.
 
 (** Set maximally inserted implicit arguments for standard definitions. *)
 
-Implicit Arguments Some [[A]].
-Implicit Arguments None [[A]].
-
-Implicit Arguments inl [[A] [B]] [A].
-Implicit Arguments inr [[A] [B]] [B].
-
-Implicit Arguments left [[A] [B]] [A].
-Implicit Arguments right [[A] [B]] [B].
-
-Implicit Arguments pair [[A] [B]].
-Implicit Arguments fst [[A] [B]].
-Implicit Arguments snd [[A] [B]].
-
-Require Import Coq.Lists.List.
+Arguments Some {A} _.
+Arguments None {A}.
 
-Implicit Arguments nil [[A]].
-Implicit Arguments cons [[A]].
+Arguments pair {A B} _ _.
+Arguments fst {A B} _.
+Arguments snd {A B} _.
 
-(** Standard notations for lists. *)
+Arguments nil {A}.
+Arguments cons {A} _ _.
 
-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 List.
+Export List.ListNotations.
 
 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))))
-  (at level 200, x ident, y ident, right associativity) : type_scope.
-
-Notation " 'exists' x y z , p" := (ex (fun x => (ex (fun y => (ex (fun z => p))))))
-  (at level 200, x ident, y ident, z ident, right associativity) : type_scope.
-
-Notation " 'exists' x y z w , p" := (ex (fun x => (ex (fun y => (ex (fun z => (ex (fun w => p))))))))
-  (at level 200, x ident, y ident, z ident, w ident, right associativity) : type_scope.
-
 Tactic Notation "exists" constr(x) := exists x.
 Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y.
 Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z.
diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v
index f62ff703..9694e3fd 100644
--- a/theories/Program/Tactics.v
+++ b/theories/Program/Tactics.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Tactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This module implements various tactics used to simplify the goals produced by Program,
    which are also generally useful. *)
 
@@ -61,12 +59,20 @@ Ltac destruct_pairs := repeat (destruct_one_pair).
 
 Ltac destruct_one_ex :=
   let tac H := let ph := fresh "H" in (destruct H as [H ph]) in
+  let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in 
+    (destruct H as [H ph ph']) 
+  in
   let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in
+  let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in 
+    (destruct H as [H ph ph']) 
+  in
     match goal with
       | [H : (ex _) |- _] => tac H
       | [H : (sig ?P) |- _ ] => tac H
       | [H : (sigT ?P) |- _ ] => tacT H
-      | [H : (ex2 _) |- _] => tac H
+      | [H : (ex2 _ _) |- _] => tac2 H
+      | [H : (sig2 ?P _) |- _ ] => tac2 H
+      | [H : (sigT2 ?P _) |- _ ] => tacT2 H
     end.
 
 (** Repeateadly destruct existentials. *)
@@ -304,18 +310,22 @@ Ltac refine_hyp c :=
    possibly using [program_simplify] to use standard goal-cleaning tactics. *)
 
 Ltac program_simplify :=
-  simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *);
+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 ]).
 
-(** We only try to solve proposition goals automatically. *)
+(** Restrict automation to propositional obligations. *)
 
-Ltac program_solve :=
+Ltac program_solve_wf :=
   match goal with
     | |- well_founded _ => auto with *
     | |- ?T => match type of T with Prop => auto end
   end.
 
-Ltac program_simpl := program_simplify ; try program_solve.
+Create HintDb program discriminated.
+
+Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; try program_solve_wf.
 
 Obligation Tactic := program_simpl.
+
+Definition obligation (A : Type) {a : A} := a.
\ No newline at end of file
diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v
index 1e57a74b..1885decf 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Utils.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Various syntaxic shortands that are useful with [Program]. *)
 
 Require Export Coq.Program.Tactics.
diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v
index 3afaf5e8..a823aedd 100644
--- a/theories/Program/Wf.v
+++ b/theories/Program/Wf.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Wf.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Reformulation of the Wf module using subsets where possible, providing
    the support for [Program]'s treatment of well-founded definitions. *)
 
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
index 2255cd41..fe8d639c 100644
--- a/theories/QArith/QArith.v
+++ b/theories/QArith/QArith.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QArith.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export QArith_base.
 Require Export Qring.
 Require Export Qreduction.
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
index 18b8823d..94ea4906 100644
--- a/theories/QArith/QArith_base.v
+++ b/theories/QArith/QArith_base.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QArith_base.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export ZArith.
 Require Export ZArithRing.
 Require Export Morphisms Setoid Bool.
@@ -20,7 +18,7 @@ Record Q : Set := Qmake {Qnum : Z; Qden : positive}.
 
 Delimit Scope Q_scope with Q.
 Bind Scope Q_scope with Q.
-Arguments Scope Qmake [Z_scope positive_scope].
+Arguments Qmake _%Z _%positive.
 Open Scope Q_scope.
 Ltac simpl_mult := repeat rewrite Zpos_mult_morphism.
 
@@ -29,7 +27,7 @@ Ltac simpl_mult := repeat rewrite Zpos_mult_morphism.
 Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.
 
 Definition inject_Z (x : Z) := Qmake x 1.
-Arguments Scope inject_Z [Z_scope].
+Arguments inject_Z x%Z.
 
 Notation QDen p := (Zpos (Qden p)).
 Notation " 0 " := (0#1) : Q_scope.
@@ -48,6 +46,13 @@ Notation "x > y" := (Qlt y x)(only parsing) : Q_scope.
 Notation "x >= y" := (Qle y x)(only parsing) : Q_scope.
 Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.
 
+(** injection from Z is injective. *)
+
+Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b.
+Proof.
+ unfold Qeq. simpl. omega.
+Qed.
+
 (** Another approach : using Qcompare for defining order relations. *)
 
 Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
@@ -92,7 +97,7 @@ Proof.
  unfold "?=". intros. apply Zcompare_antisym.
 Qed.
 
-Lemma Qcompare_spec : forall x y, CompSpec Qeq Qlt x y (x ?= y).
+Lemma Qcompare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (x ?= y).
 Proof.
  intros.
  destruct (x ?= y) as [ ]_eqn:H; constructor; auto.
@@ -387,6 +392,26 @@ Proof.
   red; simpl; intro; ring.
 Qed.
 
+(** Injectivity of addition (uses theory about Qopp above): *)
+
+Lemma Qplus_inj_r (x y z: Q):
+  x + z == y + z <-> x == y.
+Proof.
+ split; intro E.
+  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y).
+  rewrite <- (Qplus_opp_r z); auto.
+  do 2 rewrite Qplus_assoc.
+  rewrite E. reflexivity.
+ rewrite E. reflexivity.
+Qed.
+
+Lemma Qplus_inj_l (x y z: Q):
+  z + x == z + y <-> x == y.
+Proof.
+ rewrite (Qplus_comm z x), (Qplus_comm z y).
+ apply Qplus_inj_r.
+Qed.
+
 
 (** * Properties of [Qmult] *)
 
@@ -462,6 +487,21 @@ Proof.
   rewrite <- H0; ring.
 Qed.
 
+
+(** * inject_Z is a ring homomorphism: *)
+
+Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y.
+Proof.
+ unfold Qplus, inject_Z. simpl. f_equal. ring.
+Qed.
+
+Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y.
+Proof. reflexivity. Qed.
+
+Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x.
+Proof. reflexivity. Qed.
+
+
 (** * Inverse and division. *)
 
 Lemma Qinv_involutive : forall q, (/ / q) == q.
@@ -500,6 +540,25 @@ Proof.
   apply Qdiv_mult_l; auto.
 Qed.
 
+(** Injectivity of Qmult (requires theory about Qinv above): *)
+
+Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y).
+Proof.
+ intro z_ne_0.
+ split; intro E.
+  rewrite <- (Qmult_1_r x), <- (Qmult_1_r y).
+  rewrite <- (Qmult_inv_r z); auto.
+  do 2 rewrite Qmult_assoc.
+  rewrite E. reflexivity.
+ rewrite E. reflexivity.
+Qed.
+
+Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y).
+Proof.
+ rewrite (Qmult_comm z x), (Qmult_comm z y).
+ apply Qmult_inj_r.
+Qed.
+
 (** * Properties of order upon Q. *)
 
 Lemma Qle_refl : forall x, x<=x.
@@ -539,6 +598,19 @@ Proof.
   unfold Qlt, Qeq; auto with zarith.
 Qed.
 
+Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y).
+Proof.
+ unfold Qle. intros. simpl.
+ do 2 rewrite Zmult_1_r. reflexivity.
+Qed.
+
+Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y).
+Proof.
+ unfold Qlt. intros. simpl.
+ do 2 rewrite Zmult_1_r. reflexivity.
+Qed.
+
+
 (** Large = strict or equal *)
 
 Lemma Qle_lteq : forall x y, x<=y <-> x<y \/ x==y.
@@ -677,6 +749,54 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
+Lemma Qplus_lt_le_compat :
+  forall x y z t, x<y -> z<=t -> x+z < y+t.
+Proof.
+  unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
+    simpl; simpl_mult.
+  Open Scope Z_scope.
+  intros.
+  match goal with |- ?a < ?b => ring_simplify a b end.
+  rewrite Zplus_comm.
+  apply Zplus_le_lt_compat.
+  match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
+  auto with zarith.
+  match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
+  assert (forall p, 0 < ' p) by reflexivity.
+  repeat (apply Zmult_lt_compat_r; auto).
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y.
+Proof.
+ split; intros.
+  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
+  do 2 rewrite Qplus_assoc.
+  apply Qplus_le_compat; auto with *.
+ apply Qplus_le_compat; auto with *.
+Qed.
+
+Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y.
+Proof.
+ rewrite (Qplus_comm z x), (Qplus_comm z y).
+ apply Qplus_le_l.
+Qed.
+
+Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y.
+Proof.
+ split; intros.
+  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
+  do 2 rewrite Qplus_assoc.
+  apply Qplus_lt_le_compat; auto with *.
+ apply Qplus_lt_le_compat; auto with *.
+Qed.
+
+Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y.
+Proof.
+ rewrite (Qplus_comm z x), (Qplus_comm z y).
+ apply Qplus_lt_l.
+Qed.
+
 Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
 Proof.
   intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
@@ -699,6 +819,19 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
+Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y).
+Proof.
+ split; intro.
+  now apply Qmult_lt_0_le_reg_r with z.
+ apply Qmult_le_compat_r; auto with qarith.
+Qed.
+
+Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y).
+Proof.
+ rewrite (Qmult_comm z x), (Qmult_comm z y).
+ apply Qmult_le_r.
+Qed.
+
 Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
 Proof.
   intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
@@ -713,6 +846,30 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
+Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y).
+Proof.
+ Open Scope Z_scope.
+ intros (a1,a2) (b1,b2) (c1,c2).
+ unfold Qle, Qlt; simpl.
+ simpl_mult.
+ replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+ replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+ assert (forall p, 0 < ' p) by reflexivity.
+ split; intros.
+  apply Zmult_lt_reg_r with (c1*'c2); auto with zarith.
+  apply Zmult_lt_0_compat; auto with zarith.
+ apply Zmult_lt_compat_r; auto with zarith.
+ apply Zmult_lt_0_compat. omega.
+ compute; auto.
+ Close Scope Z_scope.
+Qed.
+
+Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y).
+Proof.
+ rewrite (Qmult_comm z x), (Qmult_comm z y).
+ apply Qmult_lt_r.
+Qed.
+
 Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b.
 Proof.
 intros a b Ha Hb.
diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v
index be894419..238de6fa 100644
--- a/theories/QArith/QOrderedType.v
+++ b/theories/QArith/QOrderedType.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v
index 747c2c3c..557fabc8 100644
--- a/theories/QArith/Qabs.v
+++ b/theories/QArith/Qabs.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -100,6 +100,13 @@ rewrite Zabs_Zmult.
 reflexivity.
 Qed.
 
+Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x).
+Proof.
+ unfold Qminus, Qopp. simpl.
+ rewrite Pmult_comm, <- Zabs_Zopp.
+ do 2 f_equal. ring.
+Qed.
+
 Lemma Qle_Qabs : forall a, a <= Qabs a.
 Proof.
 intros a.
@@ -122,3 +129,31 @@ apply Qabs_triangle.
 apply Qabs_wd.
 ring.
 Qed.
+
+Lemma Qabs_Qle_condition x y: Qabs x <= y <-> -y <= x <= y.
+Proof.
+ split.
+  split.
+   rewrite <- (Qopp_opp x).
+   apply Qopp_le_compat.
+   apply Qle_trans with (Qabs (-x)).
+   apply Qle_Qabs.
+   now rewrite Qabs_opp.
+  apply Qle_trans with (Qabs x); auto using Qle_Qabs.
+ intros (H,H').
+ apply Qabs_case; trivial.
+ intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat.
+Qed.
+
+Lemma Qabs_diff_Qle_condition x y r: Qabs (x - y) <= r <-> x - r <= y <= x + r.
+Proof.
+ intros. unfold Qminus.
+ rewrite Qabs_Qle_condition.
+ rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)).
+ rewrite <- (Qplus_le_l (x+-y) r (y-r)).
+ setoid_replace (-r + (y + r)) with y by ring.
+ setoid_replace (r + (y - r)) with y by ring.
+ setoid_replace (x + - y + (y + r)) with (x + r) by ring.
+ setoid_replace (x + - y + (y - r)) with (x - r) by ring.
+ intuition.
+Qed.
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index 71a3b474..fea2ba39 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qcanon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Field.
 Require Import QArith.
 Require Import Znumtheory.
@@ -20,7 +18,7 @@ Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }.
 
 Delimit Scope Qc_scope with Qc.
 Bind Scope Qc_scope with Qc.
-Arguments Scope Qcmake [Q_scope].
+Arguments Qcmake this%Q _.
 Open Scope Qc_scope.
 
 Lemma Qred_identity :
@@ -71,7 +69,7 @@ Proof.
 Qed.
 
 Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q).
-Arguments Scope Q2Qc [Q_scope].
+Arguments Q2Qc q%Q.
 Notation " !! " := Q2Qc : Qc_scope.
 
 Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
@@ -468,18 +466,16 @@ Proof.
   destruct n; simpl.
   destruct 1; auto.
   intros.
-  apply Qc_is_canon.
-  simpl.
-  compute; auto.
+  now apply Qc_is_canon.
 Qed.
 
 Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n.
 Proof.
   induction n; simpl; auto with qarith.
-  intros; compute; intro; discriminate.
+  easy.
   intros.
   apply Qcle_trans with (0*(p^n)).
-  compute; intro; discriminate.
+  easy.
   apply Qcmult_le_compat_r; auto.
 Qed.
 
diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v
index 81d59714..5e27f381 100644
--- a/theories/QArith/Qfield.v
+++ b/theories/QArith/Qfield.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qfield.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Field.
 Require Export QArith_base.
 Require Import NArithRing.
diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v
index a458fc6e..2da24ee6 100644
--- a/theories/QArith/Qminmax.v
+++ b/theories/QArith/Qminmax.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -64,4 +64,4 @@ Proof.
  apply plus_min_distr_l.
 Qed.
 
-End Q.
\ No newline at end of file
+End Q.
diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v
index 9568c796..b05ee649 100644
--- a/theories/QArith/Qpower.v
+++ b/theories/QArith/Qpower.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -136,9 +136,9 @@ Proof.
 intros a [|n|n] [|m|m] H; simpl; try ring;
 try rewrite Qpower_plus_positive;
 try apply Qinv_mult_distr; try reflexivity;
-case_eq ((n ?= m)%positive Eq); intros H0; simpl;
+rewrite ?Z.pos_sub_spec;
+case Pos.compare_spec; intros H0; simpl; subst;
  try rewrite Qpower_minus_positive;
- try rewrite (Pcompare_Eq_eq _ _ H0);
  try (field; try split; apply Qpower_not_0_positive);
  try assumption;
  apply ZC2;
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index 8a0ebcff..24f6d720 100644
--- a/theories/QArith/Qreals.v
+++ b/theories/QArith/Qreals.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qreals.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Rbase.
 Require Export QArith_base.
 
@@ -210,4 +208,4 @@ intro; apply H; apply eqR_Qeq.
 rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real.
 Qed.
 
-End LegacyQField.
\ No newline at end of file
+End LegacyQField.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index eb8c1164..e39eca0c 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qreduction.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Normalisation functions for rational numbers. *)
 
 Require Export QArith_base.
@@ -43,23 +41,16 @@ Definition Qred (q:Q) :=
 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))
-    (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
+  generalize (Zggcd_gcd n ('d)) (Zgcd_nonneg n ('d))
+    (Zggcd_correct_divisors n ('d)).
   destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
   Open Scope Z_scope.
-  intuition.
-  rewrite <- H in H0,H1; clear H.
-  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.
-  rewrite Zmult_comm.
-  rewrite <- H4; compute; auto.
-  rewrite Z2P_correct; auto.
-  ring.
+  intros Hg LE (Hn,Hd). rewrite Hd, Hn.
+  rewrite <- Hg in LE; clear Hg.
+  assert (0 <> g) by (intro; subst; discriminate).
+  rewrite Z2P_correct. ring.
+  apply Zmult_gt_0_lt_0_reg_r with g; auto with zarith.
+  now rewrite Zmult_comm, <- Hd.
   Close Scope Z_scope.
 Qed.
 
@@ -69,10 +60,10 @@ Proof.
   unfold Qred, Qeq in *; simpl in *.
   Open Scope Z_scope.
   generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
-    (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
+    (Zgcd_nonneg 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))
-    (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
+    (Zgcd_nonneg c ('d)) (Zggcd_correct_divisors c ('d)).
   destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
   simpl.
   intro H; rewrite <- H; clear H.
@@ -80,10 +71,9 @@ Proof.
   intro H; rewrite <- H; clear H.
   intros Hg1 Hg2 (Hg3,Hg4).
   intros.
-  assert (g <> 0).
-  intro; subst g; discriminate.
-  assert (g' <> 0).
-  intro; subst g'; discriminate.
+  assert (g <> 0) by (intro; subst g; discriminate).
+  assert (g' <> 0) by (intro; subst g'; discriminate).
+
   elim (rel_prime_cross_prod aa bb cc dd).
   congruence.
   unfold rel_prime in |- *.
@@ -93,14 +83,13 @@ Proof.
   exists bb; auto with zarith.
   intros.
   inversion Hg1.
-  destruct (H6 (g*x)).
+  destruct (H6 (g*x)) as (x',Hx).
   rewrite Hg3.
   destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring.
   rewrite Hg4.
   destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring.
-  exists q.
-  apply Zmult_reg_l with g; auto.
-  pattern g at 1; rewrite H7; ring.
+  exists x'.
+  apply Zmult_reg_l with g; auto. rewrite Hx at 1; ring.
   (* /rel_prime *)
   unfold rel_prime in |- *.
   (* rel_prime *)
@@ -109,14 +98,13 @@ Proof.
   exists dd; auto with zarith.
   intros.
   inversion Hg'1.
-  destruct (H6 (g'*x)).
+  destruct (H6 (g'*x)) as (x',Hx).
   rewrite Hg'3.
   destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring.
   rewrite Hg'4.
   destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring.
-  exists q.
-  apply Zmult_reg_l with g'; auto.
-  pattern g' at 1; rewrite H7; ring.
+  exists x'.
+  apply Zmult_reg_l with g'; auto. rewrite Hx at 1; ring.
     (* /rel_prime *)
   assert (0<bb); [|auto with zarith].
   apply Zmult_gt_0_lt_0_reg_r with g.
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
index 173136b8..c88a8141 100644
--- a/theories/QArith/Qring.v
+++ b/theories/QArith/Qring.v
@@ -1,11 +1,9 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qring.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Qfield.
diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v
index 01a97870..ce363a33 100644
--- a/theories/QArith/Qround.v
+++ b/theories/QArith/Qround.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -136,4 +136,15 @@ intros x y H.
 apply Zle_antisym.
  auto with *.
 symmetry in H; auto with *.
-Qed.
\ No newline at end of file
+Qed.
+
+Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m).
+Proof.
+ unfold Qfloor. intros. simpl.
+ destruct m as [?|?|p]; simpl.
+  now rewrite Zdiv_0_r, Zmult_0_r.
+  now rewrite Zmult_1_r.
+ rewrite <- Zopp_eq_mult_neg_1.
+ rewrite <- (Zopp_involutive (Zpos p)).
+ now rewrite Zdiv_opp_opp.
+Qed.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index 092eafa3..18612a68 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Alembert.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
@@ -109,7 +107,7 @@ Proof.
   symmetry  in |- *; apply tech2; assumption.
   exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
   intro X; elim X; intros.
-  exists x; apply tech10;
+  exists x; apply Un_cv_crit_lub;
     [ unfold Un_growing in |- *; intro; rewrite tech5;
       pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
@@ -524,7 +522,7 @@ Proof.
   symmetry  in |- *; apply tech2; assumption.
   exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
   intro X; elim X; intros.
-  exists x; apply tech10;
+  exists x; apply Un_cv_crit_lub;
     [ unfold Un_growing in |- *; intro; rewrite tech5;
       pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index cab14704..07a26929 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-  (*i $Id: AltSeries.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index c378a2e2..620561dc 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-  (*i $Id: ArithProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rbasic_fun.
 Require Import Even.
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index 55c30aec..412f6442 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-  (*i $Id: Binomial.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import PartSum.
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 1a2e5eca..a9d5cde3 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-  (*i $Id: Cauchy_prod.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 32480b0b..ec1eeddf 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-  (*i $Id: Cos_plus.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index dec5abd3..73f3c0c6 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Cos_rel.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 2cdc121f..144de09e 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i        $Id: DiscrR.v 14641 2011-11-06 11:59:10Z herbelin $       i*)
-
 Require Import RIneq.
 Require Import Omega.
 Open Local Scope R_scope.
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index 75ea4755..dd97b865 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Exp_prop.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
@@ -648,7 +646,7 @@ Proof.
   apply H3.
   rewrite Rminus_0_r; apply Rabs_right.
   apply Rle_ge.
-  unfold Rdiv in |- *; repeat apply Rmult_le_pos.
+  unfold Rdiv in |- *; apply Rmult_le_pos. 
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index 3199a4f8..da1742ca 100644
--- a/theories/Reals/Integration.v
+++ b/theories/Reals/Integration.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Integration.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export NewtonInt.
 Require Export RiemannInt_SF.
-Require Export RiemannInt.
\ No newline at end of file
+Require Export RiemannInt.
diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v
index 32b9699d..49a94021 100644
--- a/theories/Reals/LegacyRfield.v
+++ b/theories/Reals/LegacyRfield.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: LegacyRfield.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Raxioms.
 Require Export LegacyField.
 Import LegacyRing_theory.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index 36bbb405..29ebd46d 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: MVT.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 79060771..a4233021 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NewtonInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index e7182312..aa588e38 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PSeries_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index b2a0e574..3f90f15a 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PartSum.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index f02db3d4..70f4ff0d 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RIneq.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************)
 (** * Basic lemmas for the classical real numbers        *)
 (*********************************************************)
@@ -1603,7 +1601,7 @@ Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (nat_of_P p).
 Proof.
   intro; apply lt_0_INR.
   simpl in |- *; auto with real.
-  apply lt_O_nat_of_P.
+  apply nat_of_P_pos.
 Qed.
 Hint Resolve pos_INR_nat_of_P: real.
 
@@ -1712,38 +1710,32 @@ Qed.
 Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z_of_nat n).
 Proof.
   simple induction n; auto with real.
-  intros; simpl in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
+  intros; simpl in |- *; rewrite nat_of_P_of_succ_nat;
     auto with real.
 Qed.
 
 Lemma plus_IZR_NEG_POS :
   forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
 Proof.
-  intros.
-  case (lt_eq_lt_dec (nat_of_P p) (nat_of_P q)).
-  intros [H| H]; simpl in |- *.
-  rewrite nat_of_P_lt_Lt_compare_complement_morphism; simpl in |- *; trivial.
-  rewrite (nat_of_P_minus_morphism q p).
-  rewrite minus_INR; auto with arith; ring.
-  apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
-  rewrite (nat_of_P_inj p q); trivial.
-  rewrite Pcompare_refl; simpl in |- *; auto with real.
-  intro H; simpl in |- *.
-  rewrite nat_of_P_gt_Gt_compare_complement_morphism; simpl in |- *;
-    auto with arith.
-  rewrite (nat_of_P_minus_morphism p q).
-  rewrite minus_INR; auto with arith; ring.
-  apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
+  intros p q; simpl. rewrite Z.pos_sub_spec.
+  case Pcompare_spec; intros H; simpl.
+  subst. ring.
+  rewrite Pminus_minus by trivial.
+  rewrite minus_INR by (now apply lt_le_weak, Plt_lt).
+  ring.
+  rewrite Pminus_minus by trivial.
+  rewrite minus_INR by (now apply lt_le_weak, Plt_lt).
+  ring.
 Qed.
 
 (**********)
 Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m.
 Proof.
   intro z; destruct z; intro t; destruct t; intros; auto with real.
-  simpl in |- *; intros; rewrite nat_of_P_plus_morphism; auto with real.
+  simpl; intros; rewrite Pplus_plus; auto with real.
   apply plus_IZR_NEG_POS.
   rewrite Zplus_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
-  simpl in |- *; intros; rewrite nat_of_P_plus_morphism; rewrite plus_INR;
+  simpl; intros; rewrite Pplus_plus; rewrite plus_INR;
     auto with real.
 Qed.
 
@@ -1751,14 +1743,14 @@ Qed.
 Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m.
 Proof.
   intros z t; case z; case t; simpl in |- *; auto with real.
-  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
-  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  intros t1 z1; rewrite Pmult_mult; auto with real.
+  intros t1 z1; rewrite Pmult_mult; auto with real.
   rewrite Rmult_comm.
   rewrite Ropp_mult_distr_l_reverse; auto with real.
   apply Ropp_eq_compat; rewrite mult_comm; auto with real.
-  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  intros t1 z1; rewrite Pmult_mult; auto with real.
   rewrite Ropp_mult_distr_l_reverse; auto with real.
-  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  intros t1 z1; rewrite Pmult_mult; auto with real.
   rewrite Rmult_opp_opp; auto with real.
 Qed.
 
@@ -1766,7 +1758,7 @@ Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Zpower z (Z_of_nat n)).
 Proof.
  intros z [|n];simpl;trivial.
  rewrite Zpower_pos_nat.
- rewrite nat_of_P_o_P_of_succ_nat_eq_succ. unfold Zpower_nat;simpl.
+ rewrite nat_of_P_of_succ_nat. unfold Zpower_nat;simpl.
  rewrite mult_IZR.
  induction n;simpl;trivial.
  rewrite mult_IZR;ring[IHn].
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index 4e4fb378..dbd2e52f 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RList.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Open Local Scope R_scope.
diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v
index 87dc07b8..0a8d89c7 100644
--- a/theories/Reals/ROrderedType.v
+++ b/theories/Reals/ROrderedType.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -55,7 +55,7 @@ Definition Rcompare x y :=
   | inright _ => Gt
  end.
 
-Lemma Rcompare_spec : forall x y, CompSpec eq Rlt x y (Rcompare x y).
+Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (Rcompare x y).
 Proof.
  intros. unfold Rcompare.
  destruct total_order_T as [[H|H]|H]; auto.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index 8cf36c17..9e04a7da 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_Ifp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (**********************************************************)
 (** Complements for the reals.Integer and fractional part *)
 (*                                                        *)
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index df2267d1..f23b9f17 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqr.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rbasic_fun.
 Open Local Scope R_scope.
@@ -72,7 +70,7 @@ Proof.
   rewrite Rinv_mult_distr.
   repeat rewrite Rmult_assoc.
   apply Rmult_eq_compat_l.
-  pattern x at 2 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_comm. 
   repeat rewrite Rmult_assoc.
   apply Rmult_eq_compat_l.
   reflexivity.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index 26980c95..2c5ede23 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqrt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rsqrt_def.
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index 39c2271b..01715cf3 100644
--- a/theories/Reals/Ranalysis.v
+++ b/theories/Reals/Ranalysis.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rtrigo.
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 673dc3c1..3075bee8 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis1.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Export Rlimit.
@@ -30,15 +28,15 @@ Definition inv_fct f (x:R) : R := / f x.
 
 Delimit Scope Rfun_scope with F.
 
-Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope].
-Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope].
-Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope].
-Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope].
-Arguments Scope inv_fct [Rfun_scope R_scope].
-Arguments Scope opp_fct [Rfun_scope R_scope].
-Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope].
-Arguments Scope div_real_fct [R_scope Rfun_scope R_scope].
-Arguments Scope comp [Rfun_scope Rfun_scope R_scope].
+Arguments plus_fct (f1 f2)%F x%R.
+Arguments mult_fct (f1 f2)%F x%R.
+Arguments minus_fct (f1 f2)%F x%R.
+Arguments div_fct (f1 f2)%F x%R.
+Arguments inv_fct f%F x%R.
+Arguments opp_fct f%F x%R.
+Arguments mult_real_fct a%R f%F x%R.
+Arguments div_real_fct a%R f%F x%R.
+Arguments comp (f1 f2)%F x%R.
 
 Infix "+" := plus_fct : Rfun_scope.
 Notation "- x" := (opp_fct x) : Rfun_scope.
@@ -76,8 +74,8 @@ Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop :=
 Definition continuity_pt f (x0:R) : Prop := continue_in f no_cond x0.
 Definition continuity f : Prop := forall x:R, continuity_pt f x.
 
-Arguments Scope continuity_pt [Rfun_scope R_scope].
-Arguments Scope continuity [Rfun_scope].
+Arguments continuity_pt f%F x0%R.
+Arguments continuity f%F.
 
 (**********)
 Lemma continuity_pt_plus :
@@ -276,12 +274,12 @@ Definition derivable f := forall x:R, derivable_pt f x.
 Definition derive_pt f (x:R) (pr:derivable_pt f x) := proj1_sig pr.
 Definition derive f (pr:derivable f) (x:R) := derive_pt f x (pr x).
 
-Arguments Scope derivable_pt_lim [Rfun_scope R_scope].
-Arguments Scope derivable_pt_abs [Rfun_scope R_scope R_scope].
-Arguments Scope derivable_pt [Rfun_scope R_scope].
-Arguments Scope derivable [Rfun_scope].
-Arguments Scope derive_pt [Rfun_scope R_scope _].
-Arguments Scope derive [Rfun_scope _].
+Arguments derivable_pt_lim f%F x%R l.
+Arguments derivable_pt_abs f%F (x l)%R.
+Arguments derivable_pt f%F x%R.
+Arguments derivable f%F.
+Arguments derive_pt f%F x%R pr.
+Arguments derive f%F pr x.
 
 Definition antiderivative f (g:R -> R) (a b:R) : Prop :=
   (forall x:R,
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index fcff9a01..ed80ac43 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis2.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index c7d95660..afd4a4ee 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis3.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index a7c5a387..cc658fee 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis4.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index b6286c0d..8f01d7d0 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Raxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************)
 (**    Axiomatisation of the classical reals             *)
 (*********************************************************)
@@ -107,13 +105,13 @@ Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
 (**********************************************************)
 
 (**********)
-Boxed Fixpoint INR (n:nat) : R :=
+Fixpoint INR (n:nat) : R :=
   match n with
   | O => 0
   | S O => 1
   | S n => INR n + 1
   end.
-Arguments Scope INR [nat_scope].
+Arguments INR n%nat.
 
 
 (**********************************************************)
@@ -127,7 +125,7 @@ Definition IZR (z:Z) : R :=
   | Zpos n => INR (nat_of_P n)
   | Zneg n => - INR (nat_of_P n)
   end.
-Arguments Scope IZR [Z_scope].
+Arguments IZR z%Z.
 
 (**********************************************************)
 (** *    [R] Archimedean                                  *)
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
index 23aae957..dbf9ad71 100644
--- a/theories/Reals/Rbase.v
+++ b/theories/Reals/Rbase.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Rdefinitions.
 Require Export Raxioms.
 Require Export RIneq.
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index 15b04807..4bc7fd10 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbasic_fun.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************)
 (**          Complements for the real numbers            *)
 (*                                                       *)
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index f6d40631..77cb560c 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rcomplete.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index d06e2d1b..83c6b82d 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Rdefinitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 
 (*********************************************************)
 (**          Definitions for the axiomatization          *)
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index 701914ac..105d8347 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rderiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************)
 (**     Definition of the derivative,continuity          *)
 (*                                                       *)
@@ -17,8 +15,6 @@ Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rlimit.
 Require Import Fourier.
-Require Import Classical_Prop.
-Require Import Classical_Pred_Type.
 Require Import Omega.
 Open Local Scope R_scope.
 
@@ -168,13 +164,12 @@ Proof.
       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; exfalso; auto.
+  intro ; elim (Rlt_asym 0 2 H7 r).
   fourier.
   apply Rabs_no_R0.
   discrR.
 Qed.
 
-
 (*********)
 Lemma Dconst :
   forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
@@ -344,8 +339,7 @@ Proof.
       rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
         rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
           rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
-            rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (classic (n0 = 0%nat));
-              intro cond.
+            rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (Peano_dec.eq_nat_dec n0 0) ; intros cond.
   rewrite cond in H2; rewrite cond; simpl in H2; simpl in |- *;
     cut (1 + x0 * 1 * 0 = 1 * 1);
       [ intro A; rewrite A in H2; assumption | ring ].
@@ -391,7 +385,7 @@ Proof.
   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;
-        clear H12; elim (classic (f x2 = f x0)); intro.
+        clear H12; elim (Req_dec (f x2) (f x0)); intro.
   elim H11; clear H11; intros; elim H11; clear H11; intros;
     generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
       rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 9929733f..a15e9949 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Reals.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** The library REALS is divided in 6 parts :
    - Rbase: basic lemmas on R
             equalities and inequalities
@@ -29,4 +27,4 @@ Require Export Rfunctions.
 Require Export SeqSeries.
 Require Export Rtrigo.
 Require Export Ranalysis.
-Require Export Integration.
\ No newline at end of file
+Require Export Integration.
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index a91cf8ae..c0cd7864 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rfunctions.v 14641 2011-11-06 11:59:10Z herbelin $ 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*)
 
@@ -36,7 +34,7 @@ Open Local Scope R_scope.
 (*********)
 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));
+  intro; red; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
     assumption.
 Qed.
 
@@ -51,7 +49,7 @@ Lemma simpl_fact :
   forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
 Proof.
   intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n));
-    unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *;
+    unfold fact at 1; cbv beta iota; fold fact;
       rewrite (mult_INR (S n) (fact n));
         rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))).
   rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n)));
@@ -75,20 +73,20 @@ Qed.
 
 Lemma pow_1 : forall x:R, x ^ 1 = x.
 Proof.
-  simpl in |- *; auto with real.
+  simpl; auto with real.
 Qed.
 
 Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m.
 Proof.
-  intros x n; elim n; simpl in |- *; auto with real.
+  intros x n; elim n; simpl; auto with real.
   intros n0 H' m; rewrite H'; auto with real.
 Qed.
 
 Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0.
 Proof.
-  intro; simple induction n; simpl in |- *.
-  intro; red in |- *; intro; apply R1_neq_R0; assumption.
-  intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1).
+  intro; simple induction n; simpl.
+  intro; red; intro; apply R1_neq_R0; assumption.
+  intros; red; intro; elim (Rmult_integral x (x ^ n0) H1).
   intro; auto.
   apply H; assumption.
 Qed.
@@ -98,24 +96,24 @@ Hint Resolve pow_O pow_1 pow_add pow_nonzero: real.
 Lemma pow_RN_plus :
   forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m.
 Proof.
-  intros x n; elim n; simpl in |- *; auto with real.
+  intros x n; elim n; simpl; auto with real.
   intros n0 H' m H'0.
   rewrite Rmult_assoc; rewrite <- H'; auto.
 Qed.
 
 Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n.
 Proof.
-  intros x n; elim n; simpl in |- *; auto with real.
+  intros x n; elim n; simpl; auto with real.
   intros n0 H' H'0; replace 0 with (x * 0); auto with real.
 Qed.
 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 x n; elim n; simpl; auto with real.
   intros H' H'0; exfalso; omega.
   intros n0; case n0.
-  simpl in |- *; rewrite Rmult_1_r; auto.
+  simpl; rewrite Rmult_1_r; auto.
   intros n1 H' H'0 H'1.
   replace 1 with (1 * 1); auto with real.
   apply Rlt_trans with (r2 := x * 1); auto with real.
@@ -129,7 +127,7 @@ Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m.
 Proof.
   intros x n m H' H'0; replace m with (m - n + n)%nat.
   rewrite pow_add.
-  pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n);
+  pattern (x ^ n) at 1; replace (x ^ n) with (1 * x ^ n);
     auto with real.
   apply Rminus_lt.
   repeat rewrite (fun y:R => Rmult_comm y (x ^ n));
@@ -149,14 +147,14 @@ Hint Resolve Rlt_pow: real.
 (*********)
 Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n.
 Proof.
-  simple induction n; simpl in |- *; trivial.
+  simple induction n; simpl; trivial.
 Qed.
 
 (*********)
 Lemma tech_pow_Rplus :
   forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
 Proof.
-  intros; pattern (x ^ a) at 1 in |- *;
+  intros; pattern (x ^ a) at 1;
     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));
@@ -167,29 +165,29 @@ Qed.
 Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n.
 Proof.
   intros; elim n.
-  simpl in |- *; cut (1 + 0 * x = 1).
-  intro; rewrite H0; unfold Rle in |- *; right; reflexivity.
+  simpl; cut (1 + 0 * x = 1).
+  intro; rewrite H0; unfold Rle; right; reflexivity.
   ring.
-  intros; unfold pow in |- *; fold pow in |- *;
+  intros; unfold pow; fold pow;
     apply
       (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x))
         ((1 + x) * (1 + x) ^ n0)).
   cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)).
-  intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *;
+  intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1;
     rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1);
       apply Rplus_le_compat_l; elim n0; intros.
-  simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto.
-  unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *;
-    intro; fold (Rsqr x) in |- *;
+  simpl; rewrite Rmult_0_l; unfold Rle; right; auto.
+  unfold Rle; left; generalize Rmult_gt_0_compat; unfold Rgt;
+    intro; fold (Rsqr x);
       apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1)));
         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 |- *; left; apply Rmult_lt_compat_l.
+  unfold Rle; left; apply Rmult_lt_compat_l.
   rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
   assumption.
-  rewrite H1; unfold Rle in |- *; right; trivial.
+  rewrite H1; unfold Rle; right; trivial.
 Qed.
 
 Lemma Power_monotonic :
@@ -197,12 +195,12 @@ Lemma Power_monotonic :
     Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
 Proof.
   intros x m n H; induction  n as [| n Hrecn]; intros; inversion H0.
-  unfold Rle in |- *; right; reflexivity.
-  unfold Rle in |- *; right; reflexivity.
+  unfold Rle; right; reflexivity.
+  unfold Rle; right; reflexivity.
   apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))).
   apply Hrecn; assumption.
-  simpl in |- *; rewrite Rabs_mult.
-  pattern (Rabs (x ^ n)) at 1 in |- *.
+  simpl; rewrite Rabs_mult.
+  pattern (Rabs (x ^ n)) at 1.
   rewrite <- Rmult_1_r.
   rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))).
   apply Rmult_le_compat_l.
@@ -213,7 +211,7 @@ Qed.
 
 Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
 Proof.
-  intro; simple induction n; simpl in |- *.
+  intro; simple induction n; simpl.
   apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
   intros; rewrite H; apply sym_eq; apply Rabs_mult.
 Qed.
@@ -233,16 +231,16 @@ Proof.
   rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)).
   intro; rewrite H3;
     apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b).
-  apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus;
+  apply Rle_ge; apply poly; fold (Rabs x - 1 > 0); apply Rgt_minus;
     assumption.
   apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b).
   apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1)));
-    pattern (INR x0 * (Rabs x - 1)) at 1 in |- *;
+    pattern (INR x0 * (Rabs x - 1)) at 1;
       rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1);
         apply Rplus_lt_compat_l; apply Rlt_0_1.
   cut (b = b * / (Rabs x - 1) * (Rabs x - 1)).
   intros; rewrite H4; apply Rmult_ge_compat_r.
-  apply Rge_minus; unfold Rge in |- *; left; assumption.
+  apply Rge_minus; unfold Rge; left; assumption.
   assumption.
   rewrite Rmult_assoc; rewrite Rinv_l.
   ring.
@@ -254,26 +252,26 @@ Proof.
     apply
       (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
   rewrite INR_IZR_INZ; apply IZR_ge; omega.
-  unfold Rge in |- *; left; assumption.
+  unfold Rge; left; assumption.
   exists 0%nat;
     apply
       (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
-  rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega.
-  unfold Rge in |- *; left; assumption.
+  rewrite INR_IZR_INZ; apply IZR_ge; simpl; omega.
+  unfold Rge; left; assumption.
   omega.
 Qed.
 
 Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0.
 Proof.
   simple induction n.
-  simpl in |- *; auto.
+  simpl; auto.
   intros; elim H; reflexivity.
-  intros; simpl in |- *; apply Rmult_0_l.
+  intros; simpl; apply Rmult_0_l.
 Qed.
 
 Lemma Rinv_pow : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n.
 Proof.
-  intros; elim n; simpl in |- *.
+  intros; elim n; simpl.
   apply Rinv_1.
   intro m; intro; rewrite Rinv_mult_distr.
   rewrite H0; reflexivity; assumption.
@@ -307,7 +305,7 @@ Proof.
   rewrite <- Rabs_Rinv.
   rewrite Rinv_pow.
   apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))).
-  pattern (/ y) at 1 in |- *.
+  pattern (/ y) at 1.
   rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1).
   apply Rplus_lt_compat_l.
   apply Rlt_0_1.
@@ -321,17 +319,17 @@ Proof.
   apply pow_nonzero.
   assumption.
   apply Rlt_dichotomy_converse.
-  right; unfold Rgt in |- *; assumption.
+  right; unfold Rgt; assumption.
   rewrite <- (Rinv_involutive 1).
   rewrite Rabs_Rinv.
-  unfold Rgt in |- *; apply Rinv_lt_contravar.
+  unfold Rgt; apply Rinv_lt_contravar.
   apply Rmult_lt_0_compat.
   apply Rabs_pos_lt.
   assumption.
   rewrite Rinv_1; apply Rlt_0_1.
   rewrite Rinv_1; assumption.
   assumption.
-  red in |- *; intro; apply R1_neq_R0; assumption.
+  red; intro; apply R1_neq_R0; assumption.
 Qed.
 
 Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat.
@@ -345,7 +343,7 @@ Proof.
   cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
   absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto.
   replace (Rabs (/ r) ^ S n0) with 1.
-  simpl in |- *; apply Rlt_irrefl; auto.
+  simpl; apply Rlt_irrefl; auto.
   rewrite Rabs_Rinv; auto.
   rewrite <- Rinv_pow; auto.
   rewrite RPow_abs; auto.
@@ -356,16 +354,16 @@ Proof.
   case (Rabs_pos r); auto.
   intros H'3; case Eq2; auto.
   rewrite Rmult_1_r; rewrite Rinv_r; auto with real.
-  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
-  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+  red; intro; absurd (r ^ S n0 = 1); auto.
+  simpl; rewrite H; rewrite Rmult_0_l; auto with real.
   generalize H'; case n; auto.
   intros n0 H'0.
   cut (r <> 0); [ intros Eq1 | auto with real ].
   cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
   absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith.
-  repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real.
-  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
-  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+  repeat rewrite RPow_abs; rewrite H'0; simpl; auto with real.
+  red; intro; absurd (r ^ S n0 = 1); auto.
+  simpl; rewrite H; rewrite Rmult_0_l; auto with real.
 Qed.
 
 Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n.
@@ -375,15 +373,15 @@ Proof.
   replace (2 * S n)%nat with (S (S (2 * n))).
   replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)).
   rewrite Hrecn; reflexivity.
-  simpl in |- *; ring.
+  simpl; ring.
   ring.
 Qed.
 
 Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n.
 Proof.
   intros; induction  n as [| n Hrecn].
-  simpl in |- *; left; apply Rlt_0_1.
-  simpl in |- *; apply Rmult_le_pos; assumption.
+  simpl; left; apply Rlt_0_1.
+  simpl; apply Rmult_le_pos; assumption.
 Qed.
 
 (**********)
@@ -392,36 +390,36 @@ Proof.
   intro; induction  n as [| n Hrecn].
   reflexivity.
   replace (2 * S n)%nat with (2 + 2 * n)%nat by ring.
-  rewrite pow_add; rewrite Hrecn; simpl in |- *; ring.
+  rewrite pow_add; rewrite Hrecn; simpl; ring.
 Qed.
 
 (**********)
 Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1.
 Proof.
   intro; replace (S (2 * n)) with (2 * n + 1)%nat by ring.
-  rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring.
+  rewrite pow_add; rewrite pow_1_even; simpl; ring.
 Qed.
 
 (**********)
 Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1.
 Proof.
   intro; induction  n as [| n Hrecn].
-  simpl in |- *; apply Rabs_R1.
+  simpl; apply Rabs_R1.
   replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
   rewrite Rabs_mult.
-  rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r;
+  rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r;
     rewrite Rabs_Ropp; apply Rabs_R1.
 Qed.
 
 Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
 Proof.
   intros; induction  n2 as [| n2 Hrecn2].
-  simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
+  simpl; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
   replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat.
   replace (S n2) with (n2 + 1)%nat by ring.
   do 2 rewrite pow_add.
   rewrite Hrecn2.
-  simpl in |- *.
+  simpl.
   ring.
   ring.
 Qed.
@@ -431,7 +429,7 @@ Proof.
   intros.
   induction  n as [| n Hrecn].
   right; reflexivity.
-  simpl in |- *.
+  simpl.
   elim H; intros.
   apply Rle_trans with (y * x ^ n).
   do 2 rewrite <- (Rmult_comm (x ^ n)).
@@ -448,7 +446,7 @@ Proof.
   intros.
   induction  k as [| k Hreck].
   right; reflexivity.
-  simpl in |- *.
+  simpl.
   apply Rle_trans with (x * 1).
   rewrite Rmult_1_r; assumption.
   apply Rmult_le_compat_l.
@@ -463,33 +461,33 @@ Proof.
   replace n with (n - m + m)%nat.
   rewrite pow_add.
   rewrite Rmult_comm.
-  pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r.
+  pattern (x ^ m) at 1; rewrite <- Rmult_1_r.
   apply Rmult_le_compat_l.
   apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
   apply pow_R1_Rle; assumption.
   rewrite plus_comm.
-  symmetry  in |- *; apply le_plus_minus; assumption.
+  symmetry ; apply le_plus_minus; assumption.
 Qed.
 
 Lemma pow1 : forall n:nat, 1 ^ n = 1.
 Proof.
   intro; induction  n as [| n Hrecn].
   reflexivity.
-  simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
+  simpl; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
 Qed.
 
 Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
 Proof.
   intros; induction  n as [| n Hrecn].
   right; reflexivity.
-  simpl in |- *; case (Rcase_abs x); intro.
+  simpl; case (Rcase_abs x); intro.
   apply Rle_trans with (Rabs (x * x ^ n)).
   apply RRle_abs.
   rewrite Rabs_mult.
   apply Rmult_le_compat_l.
   apply Rabs_pos.
-  right; symmetry  in |- *; apply RPow_abs.
-  pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r);
+  right; symmetry ; apply RPow_abs.
+  pattern (Rabs x) at 1; rewrite (Rabs_right x r);
     apply Rmult_le_compat_l.
   apply Rge_le; exact r.
   apply Hrecn.
@@ -502,7 +500,7 @@ Proof.
   apply pow_Rabs.
   induction  n as [| n Hrecn].
   right; reflexivity.
-  simpl in |- *; apply Rle_trans with (x * Rabs y ^ n).
+  simpl; apply Rle_trans with (x * Rabs y ^ n).
   do 2 rewrite <- (Rmult_comm (Rabs y ^ n)).
   apply Rmult_le_compat_l.
   apply pow_le; apply Rabs_pos.
@@ -519,7 +517,7 @@ Qed.
 (*i Due to L.Thery i*)
 
 Ltac case_eq name :=
-  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+  generalize (refl_equal name); pattern name at -1; case name.
 
 Definition powerRZ (x:R) (n:Z) :=
   match n with
@@ -533,7 +531,7 @@ Infix Local "^Z" := powerRZ (at level 30, right associativity) : R_scope.
 Lemma Zpower_NR0 :
   forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
 Proof.
-  induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
+  induction n; unfold Zpower_nat; simpl; auto with zarith.
 Qed.
 
 Lemma powerRZ_O : forall x:R, x ^Z 0 = 1.
@@ -543,60 +541,47 @@ Qed.
 
 Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
 Proof.
-  simpl in |- *; auto with real.
+  simpl; auto with real.
 Qed.
 
 Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0.
 Proof.
-  destruct z; simpl in |- *; auto with real.
+  destruct z; simpl; auto with real.
 Qed.
 
 Lemma powerRZ_add :
   forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
 Proof.
-  intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *;
+  intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl;
     auto with real.
 (* POS/POS *)
-  rewrite nat_of_P_plus_morphism; auto with real.
+  rewrite Pplus_plus; auto with real.
 (* POS/NEG *)
-  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
-  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
-  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
-  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
-    auto with real.
-  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-  rewrite Rinv_mult_distr; auto with real.
-  rewrite Rinv_involutive; auto with real.
-  apply lt_le_weak.
-  apply nat_of_P_lt_Lt_compare_morphism; auto.
-  apply ZC2; auto.
-  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
-  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
-    auto with real.
-  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-  apply lt_le_weak.
-  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
-  apply nat_of_P_gt_Gt_compare_morphism; auto.
+  rewrite Z.pos_sub_spec.
+  case Pcompare_spec; intros; simpl.
+  subst; auto with real.
+  rewrite Pminus_minus by trivial.
+  rewrite (pow_RN_plus x _ (nat_of_P n1)) by auto with real.
+  rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt).
+  rewrite Rinv_mult_distr, Rinv_involutive; auto with real.
+  rewrite Pminus_minus by trivial.
+  rewrite (pow_RN_plus x _ (nat_of_P m1)) by auto with real.
+  rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt).
+  reflexivity.
 (* NEG/POS *)
-  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
-  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
-  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
-  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
-    auto with real.
-  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-  apply lt_le_weak.
-  apply nat_of_P_lt_Lt_compare_morphism; auto.
-  apply ZC2; auto.
-  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
-  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
-    auto with real.
-  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-  rewrite Rinv_mult_distr; auto with real.
-  apply lt_le_weak.
-  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
-  apply nat_of_P_gt_Gt_compare_morphism; auto.
+  rewrite Z.pos_sub_spec.
+  case Pcompare_spec; intros; simpl.
+  subst; auto with real.
+  rewrite Pminus_minus by trivial.
+  rewrite (pow_RN_plus x _ (nat_of_P m1)) by auto with real.
+  rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt).
+  rewrite Rinv_mult_distr, Rinv_involutive; auto with real.
+  rewrite Pminus_minus by trivial.
+  rewrite (pow_RN_plus x _ (nat_of_P n1)) by auto with real.
+  rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt).
+  auto with real.
 (* NEG/NEG *)
-  rewrite nat_of_P_plus_morphism; auto with real.
+  rewrite Pplus_plus; auto with real.
   intros H'; rewrite pow_add; auto with real.
   apply Rinv_mult_distr; auto.
   apply pow_nonzero; auto.
@@ -607,16 +592,16 @@ Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real.
 Lemma Zpower_nat_powerRZ :
   forall n m:nat, IZR (Zpower_nat (Z_of_nat n) m) = INR n ^Z Z_of_nat m.
 Proof.
-  intros n m; elim m; simpl in |- *; auto with real.
-  intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *.
+  intros n m; elim m; simpl; auto with real.
+  intros m1 H'; rewrite nat_of_P_of_succ_nat; simpl.
   replace (Zpower_nat (Z_of_nat n) (S m1)) with
   (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
   rewrite mult_IZR; auto with real.
-  repeat rewrite <- INR_IZR_INZ; simpl in |- *.
-  rewrite H'; simpl in |- *.
-  case m1; simpl in |- *; auto with real.
-  intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto.
-  unfold Zpower_nat in |- *; auto.
+  repeat rewrite <- INR_IZR_INZ; simpl.
+  rewrite H'; simpl.
+  case m1; simpl; auto with real.
+  intros m2; rewrite nat_of_P_of_succ_nat; auto.
+  unfold Zpower_nat; auto.
 Qed.
 
 Lemma Zpower_pos_powerRZ :
@@ -633,7 +618,7 @@ 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.
+  intros x z; case z; simpl; auto with real.
 Qed.
 Hint Resolve powerRZ_lt: real.
 
@@ -646,19 +631,19 @@ Hint Resolve powerRZ_le: real.
 Lemma Zpower_nat_powerRZ_absolu :
   forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m.
 Proof.
-  intros n m; case m; simpl in |- *; auto with zarith.
-  intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith.
-  intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith.
+  intros n m; case m; simpl; auto with zarith.
+  intros p H'; elim (nat_of_P p); simpl; auto with zarith.
+  intros n0 H'0; rewrite <- H'0; simpl; auto with zarith.
   rewrite <- mult_IZR; auto.
   intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
 Qed.
 
 Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1.
 Proof.
-  intros n; case n; simpl in |- *; auto.
-  intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H';
+  intros n; case n; simpl; auto.
+  intros p; elim (nat_of_P p); simpl; auto; intros n0 H'; rewrite H';
     ring.
-  intros p; elim (nat_of_P p); simpl in |- *.
+  intros p; elim (nat_of_P p); simpl.
   exact Rinv_1.
   intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
     auto with real.
@@ -676,7 +661,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) : nat :=
+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
@@ -710,10 +695,10 @@ Lemma GP_finite :
   forall (x:R) (n:nat),
     sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1.
 Proof.
-  intros; induction  n as [| n Hrecn]; simpl in |- *.
+  intros; induction  n as [| n Hrecn]; simpl.
   ring.
   rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
-  intro H; rewrite H; simpl in |- *; ring.
+  intro H; rewrite H; simpl; ring.
   omega.
 Qed.
 
@@ -721,8 +706,8 @@ Lemma sum_f_R0_triangle :
   forall (x:nat -> R) (n:nat),
     Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n.
 Proof.
-  intro; simple induction n; simpl in |- *.
-  unfold Rle in |- *; right; reflexivity.
+  intro; simple induction n; simpl.
+  unfold Rle; right; reflexivity.
   intro m; intro;
     apply
       (Rle_trans (Rabs (sum_f_R0 x m + x (S m)))
@@ -744,16 +729,16 @@ Definition R_dist (x y:R) : R := Rabs (x - y).
 (*********)
 Lemma R_dist_pos : forall x y:R, R_dist x y >= 0.
 Proof.
-  intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y));
+  intros; unfold R_dist; unfold Rabs; case (Rcase_abs (x - y));
     intro l.
-  unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
+  unfold Rge; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
   trivial.
 Qed.
 
 (*********)
 Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
 Proof.
-  unfold R_dist in |- *; intros; split_Rabs; try ring.
+  unfold R_dist; intros; split_Rabs; try ring.
   generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
     rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
       intro; unfold Rgt in H; exfalso; auto.
@@ -765,7 +750,7 @@ Qed.
 (*********)
 Lemma R_dist_refl : forall x y:R, R_dist x y = 0 <-> x = y.
 Proof.
-  unfold R_dist in |- *; intros; split_Rabs; split; intros.
+  unfold R_dist; intros; split_Rabs; split; intros.
   rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
     apply (Rminus_diag_uniq y x H).
   rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
@@ -776,13 +761,13 @@ Qed.
 
 Lemma R_dist_eq : forall x:R, R_dist x x = 0.
 Proof.
-  unfold R_dist in |- *; intros; split_Rabs; intros; ring.
+  unfold R_dist; intros; split_Rabs; intros; ring.
 Qed.
 
 (***********)
 Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y.
 Proof.
-  intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y));
+  intros; unfold R_dist; replace (x - y) with (x - z + (z - y));
     [ apply (Rabs_triang (x - z) (z - y)) | ring ].
 Qed.
 
@@ -790,7 +775,7 @@ Qed.
 Lemma R_dist_plus :
   forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
 Proof.
-  intros; unfold R_dist in |- *;
+  intros; unfold R_dist;
     replace (a + c - (b + d)) with (a - b + (c - d)).
   exact (Rabs_triang (a - b) (c - d)).
   ring.
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
index 3ab2bc73..bda64e77 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rgeom.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index 598f5f31..8acfd75b 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RiemannInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rfunctions.
 Require Import SeqSeries.
 Require Import Ranalysis.
@@ -2242,7 +2240,7 @@ Proof.
   unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
   eapply StepFun_P17.
   apply StepFun_P1.
-  simpl in |- *; apply StepFun_P1.
+  simpl in |- *; apply StepFun_P1. 
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply StepFun_P1.
   simpl in |- *; apply StepFun_P1.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index d0d9519c..d16e7f2c 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RiemannInt_SF.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis.
@@ -149,7 +147,7 @@ Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist :=
     | existT a b => a
   end.
 
-Boxed Fixpoint Int_SF (l k:Rlist) : R :=
+Fixpoint Int_SF (l k:Rlist) : R :=
   match l with
     | nil => 0
     | cons a l' =>
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index d2d935b7..5c864de3 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rlimit.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************)
 (**          Definition of the limit                     *)
 (*                                                       *)
@@ -15,7 +13,6 @@
 
 Require Import Rbase.
 Require Import Rfunctions.
-Require Import Classical_Prop.
 Require Import Fourier.
 Open Local Scope R_scope.
 
diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v
index b7ffec2b..2237ea6e 100644
--- a/theories/Reals/Rlogic.v
+++ b/theories/Reals/Rlogic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -41,6 +41,7 @@ Variable P : nat -> Prop.
 Hypothesis HP : forall n, {P n} + {~P n}.
 
 Let ge_fun_sums_ge_lemma : (forall (m n : nat) (f : nat -> R), (lt m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
+Proof.
 intros m n f mn fpos.
 replace (sum_f_R0 f m) with (sum_f_R0 f m + 0) by ring.
 rewrite (tech2 f m n mn).
@@ -52,6 +53,7 @@ apply (Rplus_le_compat _ _ _ _ IHn0 (fpos (S (m + S n0)%nat))).
 Qed.
 
 Let ge_fun_sums_ge : (forall (m n : nat) (f : nat -> R), (le m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
+Proof.
 intros m n f mn pos.
  elim (le_lt_or_eq _ _ mn).
  intro; apply ge_fun_sums_ge_lemma; assumption.
@@ -61,6 +63,7 @@ Qed.
 Let f:=fun n => (if HP n then (1/2)^n else 0)%R.
 
 Lemma cauchy_crit_geometric_dec_fun : Cauchy_crit_series f.
+Proof.
 intros e He.
 assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R).
  apply GP_infinite.
@@ -233,10 +236,11 @@ fourier.
 Qed.
 
 Lemma sig_forall_dec :  {n | ~P n}+{forall n, P n}.
+Proof.
 destruct forall_dec.
  right; assumption.
 left.
-apply constructive_indefinite_description_nat; auto.
+apply constructive_indefinite_ground_description_nat; auto.
  clear - HP.
  firstorder.
 apply Classical_Pred_Type.not_all_ex_not.
@@ -255,6 +259,7 @@ principle also derive [up] and its [specification] *)
 
 Theorem not_not_archimedean :
   forall r : R, ~ (forall n : nat, (INR n <= r)%R).
+Proof.
 intros r H.
 set (E := fun r => exists n : nat, r = INR n).
 assert (exists x : R, E x) by
diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v
index c9faee0c..8f8207d7 100644
--- a/theories/Reals/Rminmax.v
+++ b/theories/Reals/Rminmax.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
index 4f7a8d22..026153b7 100644
--- a/theories/Reals/Rpow_def.v
+++ b/theories/Reals/Rpow_def.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Rpow_def.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import Rdefinitions.
 
 Fixpoint pow (r:R) (n:nat) : R :=
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index 36db12f9..593e54c6 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rpower.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 (*i Due to L.Thery i*)
 
 (************************************************************)
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 947dbb11..12258d6b 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rprod.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Compare.
 Require Import Rbase.
 Require Import Rfunctions.
@@ -17,7 +15,7 @@ Require Import Binomial.
 Open Local Scope R_scope.
 
 (** TT Ak; 0<=k<=N *)
-Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R :=
+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)
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index db0fddad..479d381d 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -1,16 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rseries.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
-Require Import Classical.
 Require Import Compare.
 Open Local Scope R_scope.
 
@@ -28,7 +25,7 @@ Section sequence.
   Variable Un : nat -> R.
 
 (*********)
-  Boxed Fixpoint Rmax_N (N:nat) : R :=
+  Fixpoint Rmax_N (N:nat) : R :=
     match N with
       | O => Un 0
       | S n => Rmax (Un (S n)) (Rmax_N n)
@@ -100,47 +97,173 @@ Section sequence.
             (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3).
   Qed.
 
+(*********)
+  Lemma Un_cv_crit_lub : Un_growing -> forall l, is_lub EUn l -> Un_cv l.
+  Proof.
+    intros Hug l H eps Heps.
+
+    cut (exists N, Un N > l - eps).
+    intros (N, H3).
+    exists N.
+    intros n H4.
+    unfold R_dist.
+    rewrite Rabs_left1, Ropp_minus_distr.
+    apply Rplus_lt_reg_r with (Un n - eps).
+    apply Rlt_le_trans with (Un N).
+    now replace (Un n - eps + (l - Un n)) with (l - eps) by ring.
+    replace (Un n - eps + eps) with (Un n) by ring.
+    apply Rge_le.
+    now apply growing_prop.
+    apply Rle_minus.
+    apply (proj1 H).
+    now exists n.
+
+    assert (Hi2pn: forall n, 0 < (/ 2)^n).
+    clear. intros n.
+    apply pow_lt.
+    apply Rinv_0_lt_compat.
+    now apply (IZR_lt 0 2).
+
+    pose (test := fun n => match Rle_lt_dec (Un n) (l - eps) with left _ => false | right _ => true end).
+    pose (sum := let fix aux n := match n with S n' => aux n' +
+      if test n' then (/ 2)^n else 0 | O => 0 end in aux).
+
+    assert (Hsum': forall m n, sum m <= sum (m + n)%nat <= sum m + (/2)^m - (/2)^(m + n)).
+    clearbody test.
+    clear -Hi2pn.
+    intros m.
+    induction n.
+    rewrite<- plus_n_O.
+    ring_simplify (sum m + (/ 2) ^ m - (/ 2) ^ m).
+    split ; apply Rle_refl.
+    rewrite <- plus_n_Sm.
+    simpl.
+    split.
+    apply Rle_trans with (sum (m + n)%nat + 0).
+    rewrite Rplus_0_r.
+    apply IHn.
+    apply Rplus_le_compat_l.
+    case (test (m + n)%nat).
+    apply Rlt_le.
+    exact (Hi2pn (S (m + n))).
+    apply Rle_refl.
+    apply Rle_trans with (sum (m + n)%nat + / 2 * (/ 2) ^ (m + n)).
+    apply Rplus_le_compat_l.
+    case (test (m + n)%nat).
+    apply Rle_refl.
+    apply Rlt_le.
+    exact (Hi2pn (S (m + n))).
+    apply Rplus_le_reg_r with (-(/ 2 * (/ 2) ^ (m + n))).
+    rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r.
+    apply Rle_trans with (1 := proj2 IHn).
+    apply Req_le.
+    field.
+
+    assert (Hsum: forall n, 0 <= sum n <= 1 - (/2)^n).
+    intros N.
+    generalize (Hsum' O N).
+    simpl.
+    now rewrite Rplus_0_l.
+
+    destruct (completeness (fun x : R => exists n : nat, x = sum n)) as (m, (Hm1, Hm2)).
+    exists 1.
+    intros x (n, H1).
+    rewrite H1.
+    apply Rle_trans with (1 := proj2 (Hsum n)).
+    apply Rlt_le.
+    apply Rplus_lt_reg_r with ((/2)^n - 1).
+    now ring_simplify.
+    exists 0. now exists O.
+
+    destruct (Rle_or_lt m 0) as [[Hm|Hm]|Hm].
+    elim Rlt_not_le with (1 := Hm).
+    apply Hm1.
+    now exists O.
+
+    assert (Hs0: forall n, sum n = 0).
+    intros n.
+    specialize (Hm1 (sum n) (ex_intro _ _ (refl_equal _))).
+    apply Rle_antisym with (2 := proj1 (Hsum n)).
+    now rewrite <- Hm.
+
+    assert (Hub: forall n, Un n <= l - eps).
+    intros n.
+    generalize (refl_equal (sum (S n))).
+    simpl sum at 1.
+    rewrite 2!Hs0, Rplus_0_l.
+    unfold test.
+    destruct Rle_lt_dec. easy.
+    intros H'.
+    elim Rgt_not_eq with (2 := H').
+    exact (Hi2pn (S n)).
+
+    clear -Heps H Hub.
+    destruct H as (_, H).
+    refine (False_ind _ (Rle_not_lt _ _ (H (l - eps) _) _)).
+    intros x (n, H1).
+    now rewrite H1.
+    apply Rplus_lt_reg_r with (eps - l).
+    now ring_simplify.
+
+    assert (Rabs (/2) < 1).
+    rewrite Rabs_pos_eq.
+    rewrite <- Rinv_1 at 3.
+    apply Rinv_lt_contravar.
+    rewrite Rmult_1_l.
+    now apply (IZR_lt 0 2).
+    now apply (IZR_lt 1 2).
+    apply Rlt_le.
+    apply Rinv_0_lt_compat.
+    now apply (IZR_lt 0 2).
+    destruct (pow_lt_1_zero (/2) H0 m Hm) as [N H4].
+    exists N.
+    apply Rnot_le_lt.
+    intros H5.
+    apply Rlt_not_le with (1 := H4 _ (le_refl _)).
+    rewrite Rabs_pos_eq. 2: now apply Rlt_le.
+    apply Hm2.
+    intros x (n, H6).
+    rewrite H6. clear x H6.
+
+    assert (Hs: sum N = 0).
+    clear H4.
+    induction N.
+    easy.
+    simpl.
+    assert (H6: Un N <= l - eps).
+    apply Rle_trans with (2 := H5).
+    apply Rge_le.
+    apply growing_prop ; try easy.
+    apply le_n_Sn.
+    rewrite (IHN H6), Rplus_0_l.
+    unfold test.
+    destruct Rle_lt_dec.
+    apply refl_equal.
+    now elim Rlt_not_le with (1 := r).
+
+    destruct (le_or_lt N n) as [Hn|Hn].
+    rewrite le_plus_minus with (1 := Hn).
+    apply Rle_trans with (1 := proj2 (Hsum' N (n - N)%nat)).
+    rewrite Hs, Rplus_0_l.
+    set (k := (N + (n - N))%nat).
+    apply Rlt_le.
+    apply Rplus_lt_reg_r with ((/2)^k - (/2)^N).
+    now ring_simplify.
+    apply Rle_trans with (sum N).
+    rewrite le_plus_minus with (1 := Hn).
+    rewrite plus_Snm_nSm.
+    exact (proj1 (Hsum' _ _)).
+    rewrite Hs.
+    now apply Rlt_le.
+  Qed.
 
-(** classical is needed: [not_all_not_ex] *)
 (*********)
   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;
-          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);
-                intro.
-    cut (exists N : nat, x - eps < Un N).
-    intro; elim H6; clear H6; intros; split with x1.
-    intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
-    unfold Rgt in H2;
-      apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2).
-    fold Un_growing in H; generalize (growing_prop n x1 H H7); intro;
-      generalize
-        (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8));
-        intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
-          unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
-            rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
-              rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
-                trivial.
-    cut (~ (forall N:nat, x - eps >= Un N)).
-    intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *;
-      intro; red in H6; elim H6; clear H6; intro;
-        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);
-        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 Ropp_involutive; intro; unfold Rgt in H2;
-                generalize (Rgt_not_le eps 0 H2); intro; auto.
-    intro; elim (H6 N); intro; unfold Rle in |- *.
-    left; unfold Rgt in H7; assumption.
-    right; auto.
-    apply (H1 (Un n) (Un_in_EUn n)).
+    intros Hug Heub.
+    exists (projT1 (completeness EUn Heub EUn_noempty)).
+    destruct (completeness EUn Heub EUn_noempty) as (l, H).
+    now apply Un_cv_crit_lub.
   Qed.
 
 (*********)
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index fad19ed2..0027c274 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rsigma.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index f2095982..7c3b4699 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rsqrt_def.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Sumbool.
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,7 +13,7 @@ Require Import SeqSeries.
 Require Import Ranalysis1.
 Open Local Scope R_scope.
 
-Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
+Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
   match N with
     | O => x
     | S n =>
@@ -56,7 +54,7 @@ Proof.
   assumption.
   unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
   rewrite Rmult_1_r.
   rewrite double.
@@ -95,7 +93,7 @@ Proof.
   case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
   unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
   rewrite Rmult_1_r.
   rewrite double.
@@ -120,7 +118,7 @@ Proof.
   assumption.
   unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
   rewrite double; apply Rplus_le_compat.
   assumption.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index 8e9b2bb3..f1142d24 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtopology.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index 3499ea24..e45353b5 100644
--- a/theories/Reals/Rtrigo.v
+++ b/theories/Reals/Rtrigo.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
@@ -18,7 +16,6 @@ Require Export Cos_rel.
 Require Export Cos_plus.
 Require Import ZArith_base.
 Require Import Zcomplements.
-Require Import Classical_Prop.
 Local Open Scope nat_scope.
 Local Open Scope R_scope.
 
@@ -372,7 +369,11 @@ Qed.
 
 Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0.
 Proof.
-  intro; apply not_and_or; apply cos_sin_0.
+  intros x.
+  destruct (Req_dec (cos x) 0). 2: now left.
+  right. intros H'.
+  apply (cos_sin_0 x).
+  now split.
 Qed.
 
 (*****************************************************************)
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index de984415..3ab7d598 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_alt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index e5263f9c..587c2424 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_calc.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
@@ -56,7 +54,7 @@ Proof with trivial.
   unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
   rewrite <- Rinv_l_sym...
   rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+  rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
     repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
   ring...
 Qed.
@@ -73,7 +71,7 @@ Proof with trivial.
   unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
   rewrite <- Rinv_l_sym...
   rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+  rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
     repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
   ring...
 Qed.
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index 417cf13c..c6493135 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -1,18 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_def.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import Rbase.
-Require Import Rfunctions.
-Require Import SeqSeries.
-Require Import Rtrigo_fun.
-Require Import Max.
+Require Import Rbase Rfunctions SeqSeries Rtrigo_fun Max.
 Open Local Scope R_scope.
 
 (********************************)
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index 2ed86abe..b7720141 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_fun.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index 59afec88..100e0818 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index 7a1319ea..75c57401 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SeqProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
-Require Import Classical.
 Require Import Max.
 Open Local Scope R_scope.
 
@@ -29,31 +26,10 @@ Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)).
 Lemma growing_cv :
   forall Un:nat -> R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }.
 Proof.
-  unfold Un_growing, Un_cv in |- *; intros;
-    destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
-  exists x; intros eps H1.
-  unfold is_upper_bound in H2, H3.
-  assert (H5 : forall n:nat, Un n <= x).
-  intro n; apply (H2 (Un n) (Un_in_EUn Un n)).
-  cut (exists N : nat, x - eps < Un N).
-  intro H6; destruct H6 as [N H6]; exists N.
-  intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
-  unfold Rgt in H1.
-  apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1).
-  fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8.
-  generalize
-    (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8));
-    intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
-      unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
-        rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
-          rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
-            trivial.
-  cut (~ (forall N:nat, Un N <= x - eps)).
-  intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)).
-  intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7.
-  intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8;
-    unfold is_upper_bound in H8; generalize (H3 (x - eps) H8);
-      apply Rlt_not_le; apply tech_Rgt_minus; exact H1.
+  intros Un Hug Heub.
+  exists (projT1 (completeness (EUn Un) Heub (EUn_noempty Un))).
+  destruct (completeness _ Heub (EUn_noempty Un)) as (l, H).
+  now apply Un_cv_crit_lub.
 Qed.
 
 Lemma decreasing_growing :
@@ -518,68 +494,77 @@ Lemma approx_maj :
   forall (Un:nat -> R) (pr:has_ub Un) (eps:R),
     0 < eps ->  exists k : nat, Rabs (lub Un pr - Un k) < eps.
 Proof.
-  intros.
-  set (P := fun k:nat => Rabs (lub Un pr - Un k) < eps).
-  unfold P in |- *.
-  cut
-    ((exists k : nat, P k) ->
-      exists k : nat, Rabs (lub Un pr - Un k) < eps).
-  intros.
-  apply H0.
-  apply not_all_not_ex.
-  red in |- *; intro.
-  2: unfold P in |- *; trivial.
-  unfold P in H1.
-  cut (forall n:nat, Rabs (lub Un pr - Un n) >= eps).
-  intro.
-  cut (is_lub (EUn Un) (lub Un pr)).
-  intro.
-  unfold is_lub in H3.
-  unfold is_upper_bound in H3.
-  elim H3; intros.
-  cut (forall n:nat, eps <= lub Un pr - Un n).
-  intro.
-  cut (forall n:nat, Un n <= lub Un pr - eps).
-  intro.
-  cut (forall x:R, EUn Un x -> x <= lub Un pr - eps).
-  intro.
-  assert (H9 := H5 (lub Un pr - eps) H8).
-  cut (eps <= 0).
-  intro.
-  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
-  apply Rplus_le_reg_l with (lub Un pr - eps).
-  rewrite Rplus_0_r.
-  replace (lub Un pr - eps + eps) with (lub Un pr);
-  [ assumption | ring ].
-  intros.
-  unfold EUn in H8.
-  elim H8; intros.
-  rewrite H9; apply H7.
-  intro.
-  assert (H7 := H6 n).
-  apply Rplus_le_reg_l with (eps - Un n).
-  replace (eps - Un n + Un n) with eps.
-  replace (eps - Un n + (lub Un pr - eps)) with (lub Un pr - Un n).
-  assumption.
-  ring.
-  ring.
-  intro.
-  assert (H6 := H2 n).
-  rewrite Rabs_right in H6.
-  apply Rge_le.
-  assumption.
-  apply Rle_ge.
-  apply Rplus_le_reg_l with (Un n).
-  rewrite Rplus_0_r;
-    replace (Un n + (lub Un pr - Un n)) with (lub Un pr);
-    [ apply H4 | ring ].
-  exists n; reflexivity.
-  unfold lub in |- *.
-  case (ub_to_lub Un pr).
-  trivial.
-  intro.
-  assert (H2 := H1 n).
-  apply not_Rlt; assumption.
+  intros Un pr.
+  pose (Vn := fix aux n := match n with S n' => if Rle_lt_dec (aux n') (Un n) then Un n else aux n' | O => Un O end).
+  pose (In := fix aux n := match n with S n' => if Rle_lt_dec (Vn n) (Un n) then n else aux n' | O => O end).
+
+  assert (VUI: forall n, Vn n = Un (In n)).
+  induction n.
+  easy.
+  simpl.
+  destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1].
+  destruct (Rle_lt_dec (Un (S n)) (Un (S n))) as [H2|H2].
+  easy.
+  elim (Rlt_irrefl _ H2).
+  destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H2|H2].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 H1)).
+  exact IHn.
+
+  assert (HubV : has_ub Vn).
+  destruct pr as (ub, Hub).
+  exists ub.
+  intros x (n, Hn).
+  rewrite Hn, VUI.
+  apply Hub.
+  now exists (In n).
+
+  assert (HgrV : Un_growing Vn).
+  intros n.
+  induction n.
+  simpl.
+  destruct (Rle_lt_dec (Un O) (Un 1%nat)) as [H|_].
+  exact H.
+  apply Rle_refl.
+  simpl.
+  destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1].
+  destruct (Rle_lt_dec (Un (S n)) (Un (S (S n)))) as [H2|H2].
+  exact H2.
+  apply Rle_refl.
+  destruct (Rle_lt_dec (Vn n) (Un (S (S n)))) as [H2|H2].
+  exact H2.
+  apply Rle_refl.
+
+  destruct (ub_to_lub Vn HubV) as (l, Hl).
+  unfold lub.
+  destruct (ub_to_lub Un pr) as (l', Hl').
+  replace l' with l.
+  intros eps Heps.
+  destruct (Un_cv_crit_lub Vn HgrV l Hl eps Heps) as (n, Hn).
+  exists (In n).
+  rewrite <- VUI.
+  rewrite Rabs_minus_sym.
+  apply Hn.
+  apply le_refl.
+
+  apply Rle_antisym.
+  apply Hl.
+  intros n (k, Hk).
+  rewrite Hk, VUI.
+  apply Hl'.
+  now exists (In k).
+  apply Hl'.
+  intros n (k, Hk).
+  rewrite Hk.
+  apply Rle_trans with (Vn k).
+  clear.
+  induction k.
+  apply Rle_refl.
+  simpl.
+  destruct (Rle_lt_dec (Vn k) (Un (S k))) as [H|H].
+  apply Rle_refl.
+  now apply Rlt_le.
+  apply Hl.
+  now exists k.
 Qed.
 
 (**********)
@@ -587,72 +572,23 @@ Lemma approx_min :
   forall (Un:nat -> R) (pr:has_lb Un) (eps:R),
     0 < eps ->  exists k : nat, Rabs (glb Un pr - Un k) < eps.
 Proof.
-  intros.
-  set (P := fun k:nat => Rabs (glb Un pr - Un k) < eps).
-  unfold P in |- *.
-  cut
-    ((exists k : nat, P k) ->
-      exists k : nat, Rabs (glb Un pr - Un k) < eps).
-  intros.
-  apply H0.
-  apply not_all_not_ex.
-  red in |- *; intro.
-  2: unfold P in |- *; trivial.
-  unfold P in H1.
-  cut (forall n:nat, Rabs (glb Un pr - Un n) >= eps).
-  intro.
-  cut (is_lub (EUn (opp_seq Un)) (- glb Un pr)).
-  intro.
-  unfold is_lub in H3.
-  unfold is_upper_bound in H3.
-  elim H3; intros.
-  cut (forall n:nat, eps <= Un n - glb Un pr).
-  intro.
-  cut (forall n:nat, opp_seq Un n <= - glb Un pr - eps).
-  intro.
-  cut (forall x:R, EUn (opp_seq Un) x -> x <= - glb Un pr - eps).
-  intro.
-  assert (H9 := H5 (- glb Un pr - eps) H8).
-  cut (eps <= 0).
-  intro.
-  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
-  apply Rplus_le_reg_l with (- glb Un pr - eps).
-  rewrite Rplus_0_r.
-  replace (- glb Un pr - eps + eps) with (- glb Un pr);
-  [ assumption | ring ].
-  intros.
-  unfold EUn in H8.
-  elim H8; intros.
-  rewrite H9; apply H7.
-  intro.
-  assert (H7 := H6 n).
-  unfold opp_seq in |- *.
-  apply Rplus_le_reg_l with (eps + Un n).
-  replace (eps + Un n + - Un n) with eps.
-  replace (eps + Un n + (- glb Un pr - eps)) with (Un n - glb Un pr).
-  assumption.
-  ring.
-  ring.
-  intro.
-  assert (H6 := H2 n).
-  rewrite Rabs_left1 in H6.
-  apply Rge_le.
-  replace (Un n - glb Un pr) with (- (glb Un pr - Un n));
-  [ assumption | ring ].
-  apply Rplus_le_reg_l with (- glb Un pr).
-  rewrite Rplus_0_r;
-    replace (- glb Un pr + (glb Un pr - Un n)) with (- Un n).
-  apply H4.
-  exists n; reflexivity.
-  ring.
-  unfold glb in |- *.
-  case (lb_to_glb Un pr); simpl.
-  intro.
-  rewrite Ropp_involutive.
-  trivial.
-  intro.
-  assert (H2 := H1 n).
-  apply not_Rlt; assumption.
+  intros Un pr.
+  unfold glb.
+  destruct lb_to_glb as (lb, Hlb).
+  intros eps Heps.
+  destruct (approx_maj _ pr eps Heps) as (n, Hn).
+  exists n.
+  unfold Rminus.
+  rewrite <- Ropp_plus_distr, Rabs_Ropp.
+  replace lb with (lub (opp_seq Un) pr).
+  now rewrite <- (Ropp_involutive (Un n)).
+  unfold lub.
+  destruct ub_to_lub as (ub, Hub).
+  apply Rle_antisym.
+  apply Hub.
+  apply Hlb.
+  apply Hlb.
+  apply Hub.
 Qed.
 
 (** Unicity of limit for convergent sequences *)
@@ -910,73 +846,6 @@ Proof.
   left; assumption.
 Qed.
 
-Lemma tech10 :
-  forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x.
-Proof.
-  intros; cut (bound (EUn Un)).
-  intro; assert (H2 := Un_cv_crit _ H H1).
-  elim H2; intros.
-  case (total_order_T x x0); intro.
-  elim s; intro.
-  cut (forall n:nat, Un n <= x).
-  intro; unfold Un_cv in H3; cut (0 < x0 - x).
-  intro; elim (H3 (x0 - x) H5); intros.
-  cut (x1 >= x1)%nat.
-  intro; assert (H8 := H6 x1 H7).
-  unfold R_dist in H8; rewrite Rabs_left1 in H8.
-  rewrite Ropp_minus_distr in H8; unfold Rminus in H8.
-  assert (H9 := Rplus_lt_reg_r x0 _ _ H8).
-  assert (H10 := Ropp_lt_cancel _ _ H9).
-  assert (H11 := H4 x1).
-  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)).
-  apply Rle_minus; apply Rle_trans with x.
-  apply H4.
-  left; assumption.
-  unfold ge in |- *; apply le_n.
-  apply Rgt_minus; assumption.
-  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
-  apply H4; unfold EUn in |- *; exists n; reflexivity.
-  rewrite b; assumption.
-  cut (forall n:nat, Un n <= x0).
-  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
-  cut (forall y:R, EUn Un y -> y <= x0).
-  intro; assert (H8 := H6 _ H7).
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)).
-  unfold EUn in |- *; intros; elim H7; intros.
-  rewrite H8; apply H4.
-  intro; case (Rle_dec (Un n) x0); intro.
-  assumption.
-  cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0).
-  intro; unfold Un_cv in H3; cut (0 < Un n - x0).
-  intro; elim (H3 (Un n - x0) H5); intros.
-  cut (max n x1 >= x1)%nat.
-  intro; assert (H8 := H6 (max n x1) H7).
-  unfold R_dist in H8.
-  rewrite Rabs_right in H8.
-  unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8.
-  assert (H9 := Rplus_lt_reg_r _ _ _ H8).
-  cut (Un n <= Un (max n x1)).
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)).
-  apply tech9; [ assumption | apply le_max_l ].
-  apply Rge_trans with (Un n - x0).
-  unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0));
-    apply Rplus_le_compat_l.
-  apply tech9; [ assumption | apply le_max_l ].
-  left; assumption.
-  unfold ge in |- *; apply le_max_r.
-  apply Rplus_lt_reg_r with x0.
-  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0);
-    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
-      apply H4; apply le_n.
-  intros; apply Rlt_le_trans with (Un n).
-  case (Rlt_le_dec x0 (Un n)); intro.
-  assumption.
-  elim n0; assumption.
-  apply tech9; assumption.
-  unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros;
-    assumption.
-Qed.
-
 Lemma tech13 :
   forall (An:nat -> R) (k:R),
     0 <= k < 1 ->
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index 4725fe57..0d876be5 100644
--- a/theories/Reals/SeqSeries.v
+++ b/theories/Reals/SeqSeries.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SeqSeries.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Max.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index 67af68d1..819606c4 100644
--- a/theories/Reals/SplitAbsolu.v
+++ b/theories/Reals/SplitAbsolu.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i      $Id: SplitAbsolu.v 14641 2011-11-06 11:59:10Z herbelin $       i*)
-
 Require Import Rbasic_fun.
 
 Ltac split_case_Rabs :=
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 85a2cdd0..e554913c 100644
--- a/theories/Reals/SplitRmult.v
+++ b/theories/Reals/SplitRmult.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SplitRmult.v 14641 2011-11-06 11:59:10Z herbelin $ 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 79f39892..d00ed178 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sqrt_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index 26c8ef59..f7f5512e 100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Operators_Properties.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (************************************************************************)
 (** * Some properties of the operators on relations                     *)
 (************************************************************************)
@@ -19,17 +17,17 @@ Require Import Relation_Operators.
 
 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].
+  Arguments clos_refl_trans [A] R x _.
+  Arguments clos_refl_trans_1n [A] R x _.
+  Arguments clos_refl_trans_n1 [A] R x _.
+  Arguments clos_refl_sym_trans [A] R _ _.
+  Arguments clos_refl_sym_trans_1n [A] R x _.
+  Arguments clos_refl_sym_trans_n1 [A] R x _.
+  Arguments clos_trans [A] R x _.
+  Arguments clos_trans_1n [A] R x _.
+  Arguments clos_trans_n1 [A] R x _.
+  Arguments inclusion [A] R1 R2.
+  Arguments preorder [A] R.
 
   Variable A : Type.
   Variable R : relation A.
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index 0d901445..a84c1310 100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Definitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Section Relation_Definition.
 
   Variable A : Type.
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index 6efebc46..abf23997 100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -1,25 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Operators.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (************************************************************************)
-(** *                   Bruno Barras, Cristina Cornes                   *)
+(** * Some operators on relations                                       *)
+(************************************************************************)
+(** * Initial authors: Bruno Barras, Cristina Cornes                    *)
 (** *                                                                   *)
-(** * Some of these definitions were taken from :                       *)
+(** * Some of the initial definitions were taken from :                 *)
 (** *    Constructing Recursion Operators in Type Theory                *)
 (** *    L. Paulson  JSC (1986) 2, 325-355                              *)
+(** *                                                                   *)
+(** * Further extensions by Pierre Castéran                             *)
 (************************************************************************)
 
 Require Import Relation_Definitions.
 
-(** * Some operators to build relations *)
-
 (** ** Transitive closure *)
 
 Section Transitive_Closure.
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 630b2822..f9fb2c44 100644
--- a/theories/Relations/Relations.v
+++ b/theories/Relations/Relations.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relations.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relation_Definitions.
 Require Export Relation_Operators.
 Require Export Operators_Properties.
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index 90362da0..f5677005 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Setoid.v 14641 2011-11-06 11:59:10Z herbelin $: i*)
-
 Require Export Coq.Classes.SetoidTactics.
 
 Export Morphisms.ProperNotations.
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index 701d9f8a..f93631c7 100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Classical_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Constructive_sets.
 Require Export Classical_Type.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index d3900446..e6dd8381 100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Constructive_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 
 Section Ensembles_facts.
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index c7b496cb..d612e71e 100644
--- a/theories/Sets/Cpo.v
+++ b/theories/Sets/Cpo.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Cpo.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Relations_1.
 Require Export Partial_Order.
@@ -107,4 +105,4 @@ Section Specific_orders.
     {PO_of_chain : PO U;
     Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
 
-End Specific_orders.
\ No newline at end of file
+End Specific_orders.
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index 6c80ad40..58b979dd 100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Ensembles.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Section Ensembles.
   Variable U : Type.
 
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index 09a0a94d..f0843675 100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Ensembles.
 
 Section Ensembles_finis.
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index a9fe8ffe..350cd783 100644
--- a/theories/Sets/Finite_sets_facts.v
+++ b/theories/Sets/Finite_sets_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Finite_sets.
 Require Export Constructive_sets.
 Require Export Classical_Type.
@@ -175,14 +173,14 @@ Section Finite_sets_facts.
     clear H'2 c2 Y.
     intros X0 c2 H'2 H'3 x0 H'4 H'5.
     elim (classic (In U X0 x)).
-    intro H'6; apply f_equal with nat.
+    intro H'6; apply f_equal.
     apply H'0 with (Y := Subtract U (Add U X0 x0) x).
     elimtype (pred (S c2) = c2); auto with sets.
     apply card_soustr_1; auto with sets.
     rewrite <- H'5.
     apply Sub_Add_new; auto with sets.
     elim (classic (x = x0)).
-    intros H'6 H'7; apply f_equal with nat.
+    intros H'6 H'7; apply f_equal.
     apply H'0 with (Y := X0); auto with sets.
     apply Simplify_add with (x := x); auto with sets.
     pattern x at 2 in |- *; rewrite H'6; auto with sets.
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index e5eae17e..24facb6f 100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Image.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Finite_sets.
 Require Export Constructive_sets.
 Require Export Classical_Type.
@@ -202,4 +200,4 @@ Section Image.
 
 End Image.
 
-Hint Resolve Im_def image_empty finite_image: sets v62.
\ No newline at end of file
+Hint Resolve Im_def image_empty finite_image: sets v62.
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
index afb9e0e1..a21fe880 100644
--- a/theories/Sets/Infinite_sets.v
+++ b/theories/Sets/Infinite_sets.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Infinite_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Finite_sets.
 Require Export Constructive_sets.
 Require Export Classical_Type.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 5d073a0c..2c94a2e1 100644
--- a/theories/Sets/Integers.v
+++ b/theories/Sets/Integers.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Integers.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Finite_sets.
 Require Export Constructive_sets.
 Require Export Classical_Type.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index 6187c08b..5f21335f 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Multiset.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* G. Huet 1-9-95 *)
 
 Require Import Permut Setoid.
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index e819cafa..a319b983 100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Partial_Order.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Relations_1.
 
@@ -99,4 +97,4 @@ Section Partial_order_facts.
     apply Strict_Rel_Transitive_with_Rel with (y := y);
       [ intuition | unfold Strict_Rel_of in H', H'0; intuition ].
   Qed.
-End Partial_order_facts.
\ No newline at end of file
+End Partial_order_facts.
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
index 8699eed3..e28a1264 100644
--- a/theories/Sets/Permut.v
+++ b/theories/Sets/Permut.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permut.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* G. Huet 1-9-95 *)
 
 (** We consider a Set [U], given with a commutative-associative operator [op],
@@ -86,4 +84,4 @@ Section Axiomatisation.
     apply cong_left; apply perm_left.
   Qed.
 
-End Axiomatisation.
\ No newline at end of file
+End Axiomatisation.
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index 372473d6..f8b24e74 100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Relations_1.
 Require Export Relations_1_facts.
@@ -187,4 +185,4 @@ Hint Resolve Union_increases_r: sets v62.
 Hint Resolve Intersection_decreases_l: sets v62.
 Hint Resolve Intersection_decreases_r: sets v62.
 Hint Resolve Empty_set_is_Bottom: sets v62.
-Hint Resolve Strict_inclusion_is_transitive: sets v62.
\ No newline at end of file
+Hint Resolve Strict_inclusion_is_transitive: sets v62.
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 66c0c0bb..09fc2094 100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_Classical_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Constructive_sets.
 Require Export Relations_1.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 09edd08a..f756f985 100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Ensembles.
 Require Export Constructive_sets.
 Require Export Relations_1.
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index 2818b370..a7fbb53d 100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Section Relations_1.
    Variable U : Type.
 
@@ -64,4 +62,4 @@ End Relations_1.
 Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
   same_relation: sets v62.
 Hint Resolve Definition_of_preorder Definition_of_order
-  Definition_of_equivalence Definition_of_PER: sets v62.
\ No newline at end of file
+  Definition_of_equivalence Definition_of_PER: sets v62.
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
index f002e926..0c8329dd 100644
--- a/theories/Sets/Relations_1_facts.v
+++ b/theories/Sets/Relations_1_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relations_1.
 
 Definition Complement (U:Type) (R:Relation U) : Relation U :=
@@ -109,4 +107,4 @@ intros U R R' H' H'0; red in |- *.
 elim H'.
 intros H'1 H'2 x y z H'3 H'4; apply H'2.
 apply H'0 with y; auto with sets.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index 710bff2b..e7a69c99 100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relations_1.
 
 Section Relations_2.
@@ -53,4 +51,4 @@ End Relations_2.
 Hint Resolve Rstar_0: sets v62.
 Hint Resolve Rstar1_0: sets v62.
 Hint Resolve Rstar1_1: sets v62.
-Hint Resolve Rplus_0: sets v62.
\ No newline at end of file
+Hint Resolve Rplus_0: sets v62.
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
index 5ccdcb11..89b98c1f 100644
--- a/theories/Sets/Relations_2_facts.v
+++ b/theories/Sets/Relations_2_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relations_1.
 Require Export Relations_1_facts.
 Require Export Relations_2.
@@ -150,4 +148,4 @@ elim (H'3 t); auto with sets.
 intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5.
 exists z1; split; [ idtac | assumption ].
 apply Rstar_n with t; auto with sets.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index 1f96a75a..51092f7a 100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relations_1.
 Require Export Relations_2.
 
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
index 3a69a231..8ac6e7fb 100644
--- a/theories/Sets/Relations_3_facts.v
+++ b/theories/Sets/Relations_3_facts.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -24,8 +24,6 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Relations_1.
 Require Export Relations_1_facts.
 Require Export Relations_2.
@@ -168,4 +166,4 @@ generalize (H'2 v); intro h; lapply h;
 red in |- *; (exists z1; split); auto with sets.
 apply T with y1; auto with sets.
 apply T with t; auto with sets.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index 48789f9a..bf1aaf8d 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Uniset.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Sets as characteristic functions *)
 
 (* G. Huet 1-9-95 *)
@@ -212,4 +210,4 @@ i*)
 
 End defs.
 
-Unset Implicit Arguments.
\ No newline at end of file
+Unset Implicit Arguments.
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index 76080aa9..60bb50ce 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Heap.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file is deprecated, for a tree on list, use [Mergesort.v]. *)
 
 (** A development of Treesort on Heap trees. It has an average
diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v
index cded23ea..7124cd53 100644
--- a/theories/Sorting/Mergesort.v
+++ b/theories/Sorting/Mergesort.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Mergesort.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** A modular implementation of mergesort (the complexity is O(n.log n) in
    the length of the list) *)
 
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
index 00d6e7ce..d4e5fba4 100644
--- a/theories/Sorting/PermutEq.v
+++ b/theories/Sorting/PermutEq.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PermutEq.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation.
 
 Set Implicit Arguments.
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
index 87b0b08d..fa807c15 100644
--- a/theories/Sorting/PermutSetoid.v
+++ b/theories/Sorting/PermutSetoid.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PermutSetoid.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Omega Relations Multiset SetoidList.
 
 (** This file is deprecated, use [Permutation.v] instead.
@@ -344,8 +342,7 @@ Proof.
   rewrite if_eqA_refl in H.
   clear IHl; omega.
   rewrite IHl; intros.
-  specialize (H a0); auto with *.
-  destruct (eqA_dec a a0); simpl; auto with *.
+  specialize (H a0). omega.
 Qed.
 
 (** Permutation is compatible with InA. *)
@@ -396,18 +393,14 @@ Proof.
   apply permut_length_1.
   red; red; intros.
   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.
+  rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. omega.
   right.
   inversion_clear H0; [|inversion H].
   split; auto.
   apply permut_length_1.
   red; red; intros.
   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.
+  rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. omega.
 Qed.
 
 (** Permutation is compatible with length. *)
@@ -492,7 +485,7 @@ Qed.
 
 End Permut_map.
 
-Require Import Permutation TheoryList.
+Require Import Permutation.
 
 Section Permut_permut.
 
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index 7508ccc2..797583d0 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permutation.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*********************************************************************)
-(** ** List permutations as a composition of adjacent transpositions *)
+(** * List permutations as a composition of adjacent transpositions  *)
 (*********************************************************************)
 
 (* Adapted in May 2006 by Jean-Marc Notin from initial contents by
@@ -139,32 +137,26 @@ Proof.
   intros; apply Permutation_app; auto.
 Qed.
 
+Lemma Permutation_cons_append : forall (l : list A) x,
+  Permutation (x :: l) (l ++ x :: nil).
+Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed.
+Local Hint Resolve Permutation_cons_append.
+
 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.
+  rewrite app_nil_r; trivial. rewrite IHl. 
+  rewrite app_comm_cons, Permutation_cons_append. 
+  now rewrite <- app_assoc. 
 Qed.
+Local Hint Resolve Permutation_app_comm.
 
 Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
   Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
-Proof.
-  intros l l1; 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.
+Proof. intros l l1 l2 a H. rewrite H.
+  rewrite app_comm_cons, Permutation_cons_append. 
+  now rewrite <- app_assoc. 
 Qed.
 Local Hint Resolve Permutation_cons_app.
 
@@ -173,19 +165,20 @@ Theorem Permutation_middle : forall (l1 l2:list A) a,
 Proof.
   auto.
 Qed.
+Local Hint Resolve Permutation_middle.
 
 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.
+  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. 
 Qed.
 
+Add Parametric Morphism : (@rev A)
+  with signature @Permutation A ==> @Permutation A as Permutation_rev'.
+Proof. intros. now do 2 rewrite <- Permutation_rev. Qed.
+
 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.
+  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
 Qed.
 
 Theorem Permutation_ind_bis :
@@ -211,6 +204,12 @@ Ltac break_list l x l' H :=
   destruct l as [|x l']; simpl in *;
   injection H; intros; subst; clear H.
 
+Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), ~ Permutation nil (l++x::l').
+Proof.
+  intros l l' x HF. 
+  apply Permutation_nil in HF. destruct l; discriminate.
+Qed.
+
 Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
   Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
 Proof.
@@ -224,32 +223,27 @@ Proof.
   (* 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.
+  auto. 
+  now rewrite H. 
+  now rewrite <- H. 
+  now rewrite (IH a _ _ _ _ eq_refl eq_refl).
   (* contradict *)
   intros x y l l' Hp IH; intros.
   break_list l1 b l1' H; break_list l3 c l3' H0.
   auto.
   break_list l3' b l3'' H.
-  auto.
-  apply perm_trans with (c::l3''++b::l4); auto.
+  auto. 
+  rewrite <- Permutation_middle in Hp. now rewrite Hp. 
   break_list l1' c l1'' H1.
-  auto.
-  apply perm_trans with (b::l1''++c::l2); auto.
+  auto. 
+  rewrite <- Permutation_middle in Hp. now rewrite Hp. 
   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.
+  rewrite <- Permutation_middle in Hp. rewrite perm_swap. auto. 
+  rewrite perm_swap, Permutation_middle. auto.
+  now rewrite perm_swap, (IH a _ _ _ _ eq_refl eq_refl).
   (*trans*)
-  intros.
+  intros. 
   destruct (In_split a l') as (l'1,(l'2,H6)).
   apply (Permutation_in a H).
   subst l.
@@ -375,4 +369,4 @@ End Permutation_map.
 
 (* begin hide *)
 Notation Permutation_app_swap := Permutation_app_comm (only parsing).
-(* end hide *)
+(* end hide *)
\ No newline at end of file
diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v
index 2c7c07e5..0e230b77 100644
--- a/theories/Sorting/Sorted.v
+++ b/theories/Sorting/Sorted.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sorted.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Made by Hugo Herbelin *)
 
 (** This file defines two notions of sorted list:
@@ -27,7 +25,7 @@ Require Import List Relations Relations_1.
 Set Implicit Arguments.
 Local Notation "[ ]" := nil (at level 0).
 Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0).
-Implicit Arguments Transitive [U].
+Arguments Transitive [U] R.
 
 Section defs.
 
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
index bc1fdbcf..22e56592 100644
--- a/theories/Sorting/Sorting.v
+++ b/theories/Sorting/Sorting.v
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sorting.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Sorted.
 Require Export Mergesort.
diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
index 4204456f..1ed9140a 100644
--- a/theories/Strings/Ascii.v
+++ b/theories/Strings/Ascii.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ascii.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Contributed by Laurent Théry (INRIA);
     Adapted to Coq V8 by the Coq Development Team *)
 
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index c26b8818..958ecd4f 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: String.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Contributed by Laurent Théry (INRIA);
     Adapted to Coq V8 by the Coq Development Team *)
 
@@ -252,12 +250,12 @@ case H0; simpl in |- *; auto.
 case m; simpl in |- *; auto.
 case (index 0 s1 s2'); intros; discriminate.
 intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
-intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
+intros x H H0 H1; apply H; injection H1; auto.
 intros; discriminate.
 intros n'; case m; simpl in |- *; auto.
 case (index n' s1 s2'); intros; discriminate.
 intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
-intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
+intros x H H1; apply H; injection H1; auto.
 intros; discriminate.
 Qed.
 
@@ -290,7 +288,7 @@ intros x H H0 H1 p; try case p; simpl in |- *; auto.
 intros H2 H3; red in |- *; intros H4; case H0.
 intros H5 H6; absurd (false = true); auto with bool.
 intros n0 H2 H3; apply H; auto.
-injection H1; intros H4; injection H4; auto.
+injection H1; auto.
 apply Le.le_O_n.
 apply Lt.lt_S_n; auto.
 intros; discriminate.
@@ -300,7 +298,7 @@ intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
 intros x H H0 p; case p; simpl in |- *; auto.
 intros H1; inversion H1; auto.
 intros n0 H1 H2; apply H; auto.
-injection H0; intros H3; injection H3; auto.
+injection H0; auto.
 apply Le.le_S_n; auto.
 apply Lt.lt_S_n; auto.
 intros; discriminate.
diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v
index 18153436..79e81771 100644
--- a/theories/Structures/DecidableType.v
+++ b/theories/Structures/DecidableType.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: DecidableType.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
 Require Export SetoidList.
 Require Equalities.
 
diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v
index ac1f014b..2c02f8dd 100644
--- a/theories/Structures/DecidableTypeEx.v
+++ b/theories/Structures/DecidableTypeEx.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: DecidableTypeEx.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
 Require Import DecidableType OrderedType OrderedTypeEx.
 Set Implicit Arguments.
 Unset Strict Implicit.
diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v
index 382511d9..eb537385 100644
--- a/theories/Structures/Equalities.v
+++ b/theories/Structures/Equalities.v
@@ -6,23 +6,28 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: Equalities.v 13475 2010-09-29 14:33:13Z letouzey $ *)
-
 Require Export RelationClasses.
+Require Import Bool Morphisms Setoid.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+(** Structure with nothing inside.
+    Used to force a module type T into a module via Nop <+ T. (HACK!) *)
+
+Module Type Nop.
+End Nop.
+
 (** * Structure with just a base type [t] *)
 
 Module Type Typ.
-  Parameter Inline t : Type.
+  Parameter Inline(10) t : Type.
 End Typ.
 
 (** * Structure with an equality relation [eq] *)
 
 Module Type HasEq (Import T:Typ).
-  Parameter Inline eq : t -> t -> Prop.
+  Parameter Inline(30) eq : t -> t -> Prop.
 End HasEq.
 
 Module Type Eq := Typ <+ HasEq.
@@ -61,10 +66,19 @@ End HasEqDec.
 (** Having [eq_dec] is the same as having a boolean equality plus
     a correctness proof. *)
 
-Module Type HasEqBool (Import E:Eq').
+Module Type HasEqb (Import T:Typ).
   Parameter Inline eqb : t -> t -> bool.
-  Parameter eqb_eq : forall x y, eqb x y = true <-> x==y.
-End HasEqBool.
+End HasEqb.
+
+Module Type EqbSpec (T:Typ)(X:HasEq T)(Y:HasEqb T).
+  Parameter eqb_eq : forall x y, Y.eqb x y = true <-> X.eq x y.
+End EqbSpec.
+
+Module Type EqbNotation (T:Typ)(E:HasEqb T).
+  Infix "=?" := E.eqb (at level 70, no associativity).
+End EqbNotation.
+
+Module Type HasEqBool (E:Eq) := HasEqb E <+ EqbSpec E E.
 
 (** From these basic blocks, we can build many combinations
     of static standalone module types. *)
@@ -102,8 +116,10 @@ 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 BooleanEqualityType' :=
+ BooleanEqualityType <+ EqNotation <+ EqbNotation.
+Module Type BooleanDecidableType' :=
+ BooleanDecidableType <+ EqNotation <+ EqbNotation.
 Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation.
 
 (** * Compatibility wrapper from/to the old version of
@@ -162,6 +178,49 @@ Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType
  := E <+ HasEqBool2Dec.
 
 
+(** Some properties of boolean equality *)
+
+Module BoolEqualityFacts (Import E : BooleanEqualityType').
+
+(** [eqb] is compatible with [eq] *)
+
+Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb.
+Proof.
+intros x x' Exx' y y' Eyy'.
+apply eq_true_iff_eq.
+now rewrite 2 eqb_eq, Exx', Eyy'.
+Qed.
+
+(** Alternative specification of [eqb] based on [reflect]. *)
+
+Lemma eqb_spec x y : reflect (x==y) (x =? y).
+Proof.
+apply iff_reflect. symmetry. apply eqb_eq.
+Defined.
+
+(** Negated form of [eqb_eq] *)
+
+Lemma eqb_neq x y : (x =? y) = false <-> x ~= y.
+Proof.
+now rewrite <- not_true_iff_false, eqb_eq.
+Qed.
+
+(** Basic equality laws for [eqb] *)
+
+Lemma eqb_refl x : (x =? x) = true.
+Proof.
+now apply eqb_eq.
+Qed.
+
+Lemma eqb_sym x y : (x =? y) = (y =? x).
+Proof.
+apply eq_true_iff_eq. now rewrite 2 eqb_eq.
+Qed.
+
+(** Transitivity is a particular case of [eqb_compat] *)
+
+End BoolEqualityFacts.
+
 
 (** * UsualDecidableType
 
diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v
index d9b1d76f..c69885b4 100644
--- a/theories/Structures/EqualitiesFacts.v
+++ b/theories/Structures/EqualitiesFacts.v
@@ -8,21 +8,8 @@
 
 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.
@@ -42,9 +29,9 @@ Module KeyDecidableType(Import D:DecidableType).
 
   (* eqk, eqke are equalities, ltk is a strict order *)
 
-  Global Instance eqk_equiv : Equivalence eqk.
+  Global Instance eqk_equiv : Equivalence eqk := _.
 
-  Global Instance eqke_equiv : Equivalence eqke.
+  Global Instance eqke_equiv : Equivalence eqke := _.
 
   (* Additionnal facts *)
 
@@ -156,7 +143,7 @@ Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.
 
  Definition eq := (D1.eq * D2.eq)%signature.
 
- Instance eq_equiv : Equivalence eq.
+ Instance eq_equiv : Equivalence eq := _.
 
  Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
  Proof.
@@ -172,7 +159,7 @@ End PairDecidableType.
 Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
  Definition t := (D1.t * D2.t)%type.
  Definition eq := @eq t.
- Program Instance eq_equiv : Equivalence eq.
+ Instance eq_equiv : Equivalence eq := _.
  Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
  Proof.
  intros (x1,x2) (y1,y2);
diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v
index 68f20189..5583142f 100644
--- a/theories/Structures/GenericMinMax.v
+++ b/theories/Structures/GenericMinMax.v
@@ -79,7 +79,7 @@ End GenericMinMax.
 (** ** Consequences of the minimalist interface: facts about [max]. *)
 
 Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O).
- Module Import T := !MakeOrderTac O.
+ Module Import Private_Tac := !MakeOrderTac O.
 
 (** An alternative caracterisation of [max], equivalent to
     [max_l /\ max_r] *)
@@ -277,8 +277,9 @@ End MaxLogicalProperties.
 
 Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
  Include MaxLogicalProperties O M.
- Import T.
+ Import Private_Tac.
 
+ Module Import Private_Rev.
  Module ORev := TotalOrderRev O.
  Module MRev <: HasMax ORev.
   Definition max x y := M.min y x.
@@ -286,6 +287,7 @@ Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
   Definition max_r x y := M.min_l y x.
  End MRev.
  Module MPRev := MaxLogicalProperties ORev MRev.
+ End Private_Rev.
 
 Instance min_compat : Proper (eq==>eq==>eq) min.
 Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed.
@@ -578,29 +580,29 @@ End UsualMinMaxLogicalProperties.
 Module UsualMinMaxDecProperties
  (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O).
 
- Module P := MinMaxDecProperties O M.
+ Module Import Private_Dec := 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.
+ Proof. intros; apply 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.
+ Proof. exact 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.
+ Proof. intros; apply 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.
+ Proof. exact min_dec. Defined.
 
 End UsualMinMaxDecProperties.
 
diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v
index 57f491d2..f84cdf32 100644
--- a/theories/Structures/OrderedType.v
+++ b/theories/Structures/OrderedType.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: OrderedType.v 12732 2010-02-10 22:46:59Z letouzey $ *)
-
 Require Export SetoidList Morphisms OrdersTac.
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -22,6 +20,10 @@ Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type :=
   | EQ : eq x y -> Compare lt eq x y
   | GT : lt y x -> Compare lt eq x y.
 
+Arguments LT [X lt eq x y] _.
+Arguments EQ [X lt eq x y] _.
+Arguments GT [X lt eq x y] _.
+
 Module Type MiniOrderedType.
 
   Parameter Inline t : Type.
@@ -143,7 +145,7 @@ Module OrderedTypeFacts (Import O: OrderedType).
 
   Lemma elim_compare_eq :
    forall x y : t,
-   eq x y -> exists H : eq x y, compare x y = EQ _ H.
+   eq x y -> exists H : eq x y, compare x y = EQ H.
   Proof.
    intros; case (compare x y); intros H'; try (exfalso; order).
    exists H'; auto.
@@ -151,7 +153,7 @@ Module OrderedTypeFacts (Import O: OrderedType).
 
   Lemma elim_compare_lt :
    forall x y : t,
-   lt x y -> exists H : lt x y, compare x y = LT _ H.
+   lt x y -> exists H : lt x y, compare x y = LT H.
   Proof.
    intros; case (compare x y); intros H'; try (exfalso; order).
    exists H'; auto.
@@ -159,7 +161,7 @@ Module OrderedTypeFacts (Import O: OrderedType).
 
   Lemma elim_compare_gt :
    forall x y : t,
-   lt y x -> exists H : lt y x, compare x y = GT _ H.
+   lt y x -> exists H : lt y x, compare x y = GT H.
   Proof.
    intros; case (compare x y); intros H'; try (exfalso; order).
    exists H'; auto.
@@ -318,16 +320,13 @@ Module KeyOrderedType(O:OrderedType).
   Hint Immediate eqk_sym eqke_sym.
 
   Global Instance eqk_equiv : Equivalence eqk.
-  Proof. split; eauto. Qed.
+  Proof. constructor; 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.
+  Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed.
 
   Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
   Proof.
diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v
index f6c1532b..b054496e 100644
--- a/theories/Structures/OrderedTypeAlt.v
+++ b/theories/Structures/OrderedTypeAlt.v
@@ -5,8 +5,6 @@
 (*    //   *      This file is distributed under the terms of the      *)
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
-(* $Id: OrderedTypeAlt.v 12384 2009-10-13 14:39:51Z letouzey $ *)
-
 Require Import OrderedType.
 
 (** * An alternative (but equivalent) presentation for an Ordered Type
diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v
index 128cd576..adeba9e4 100644
--- a/theories/Structures/OrderedTypeEx.v
+++ b/theories/Structures/OrderedTypeEx.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: OrderedTypeEx.v 13297 2010-07-19 23:32:42Z letouzey $ *)
-
 Require Import OrderedType.
 Require Import ZArith.
 Require Import Omega.
@@ -111,26 +109,18 @@ Module Positive_as_OT <: UsualOrderedType.
   Definition eq_sym := @sym_eq t.
   Definition eq_trans := @trans_eq t.
 
-  Definition lt p q:= (p ?= q) Eq = Lt.
+  Definition lt := Plt.
 
-  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
-  Proof.
-  unfold lt; intros x y z.
-  change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z).
-  omega.
-  Qed.
+  Definition lt_trans := Plt_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 Pcompare_refl in H; discriminate.
+  intros x y H. contradict H. rewrite H. apply Plt_irrefl.
   Qed.
 
   Definition compare : forall x y : t, Compare lt eq x y.
   Proof.
-  intros x y. destruct ((x ?= y) Eq) as [ | | ]_eqn.
+  intros x y. destruct (x ?= y) as [ | | ]_eqn.
   apply EQ; apply Pcompare_Eq_eq; assumption.
   apply LT; assumption.
   apply GT; apply ZC1; assumption.
@@ -324,10 +314,10 @@ Module PositiveOrderedTypeBits <: UsualOrderedType.
 
   Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
   Proof.
-  intros. case_eq ((x ?= y) Eq); intros.
+  intros. case_eq (x ?= y); 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.
+  right. red. intro. subst y. rewrite (Pos.compare_refl x) in H. discriminate.
+  right. red. intro. subst y. rewrite (Pos.compare_refl x) in H. discriminate.
   Qed.
 
 End PositiveOrderedTypeBits.
diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v
index 5567b743..1d025439 100644
--- a/theories/Structures/Orders.v
+++ b/theories/Structures/Orders.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: Orders.v 13276 2010-07-10 14:34:44Z letouzey $ *)
-
 Require Export Relations Morphisms Setoid Equalities.
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -67,20 +65,34 @@ 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).
+Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder.
+Module Type StrOrder' := StrOrder <+ EqLtNotation.
+
+(** Versions with a decidable ternary comparison *)
+
+Module Type HasCmp (Import T:Typ).
   Parameter Inline compare : t -> t -> comparison.
-  Axiom compare_spec : forall x y, CompSpec eq lt x y (compare x y).
-End HasCompare.
+End HasCmp.
+
+Module Type CmpNotation (T:Typ)(C:HasCmp T).
+  Infix "?=" := C.compare (at level 70, no associativity).
+End CmpNotation.
+
+Module Type CmpSpec (Import E:EqLt')(Import C:HasCmp E).
+  Axiom compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y).
+End CmpSpec.
+
+Module Type HasCompare (E:EqLt) := HasCmp E <+ CmpSpec E.
 
-Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder.
 Module Type DecStrOrder := StrOrder <+ HasCompare.
+Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation <+ CmpNotation.
+
 Module Type OrderedType <: DecidableType := DecStrOrder <+ HasEqDec.
-Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq.
+Module Type OrderedType' := OrderedType <+ EqLtNotation <+ CmpNotation.
 
-Module Type StrOrder' := StrOrder <+ EqLtNotation.
-Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation.
-Module Type OrderedType' := OrderedType <+ EqLtNotation.
-Module Type OrderedTypeFull' := OrderedTypeFull <+ EqLtLeNotation.
+Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq.
+Module Type OrderedTypeFull' :=
+ OrderedTypeFull <+ EqLtLeNotation <+ CmpNotation.
 
 (** NB: in [OrderedType], an [eq_dec] could be deduced from [compare].
   But adding this redundant field allows to see an [OrderedType] as a
@@ -169,50 +181,63 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder
 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 HasLeb (Import T:Typ).
+ Parameter Inline leb : t -> t -> bool.
+End HasLeb.
 
-Module Type LeBool := Typ <+ HasLeBool.
-Module Type LtBool := Typ <+ HasLtBool.
+Module Type HasLtb (Import T:Typ).
+ Parameter Inline ltb : t -> t -> bool.
+End HasLtb.
 
-Module Type LeBoolNotation (E:LeBool).
-  Infix "<=?" := E.leb (at level 35).
-End LeBoolNotation.
+Module Type LebNotation (T:Typ)(E:HasLeb T).
+ Infix "<=?" := E.leb (at level 35).
+End LebNotation.
 
-Module Type LtBoolNotation (E:LtBool).
-  Infix "<?" := E.ltb (at level 35).
-End LtBoolNotation.
+Module Type LtbNotation (T:Typ)(E:HasLtb T).
+ Infix "<?" := E.ltb (at level 35).
+End LtbNotation.
 
-Module Type LeBool' := LeBool <+ LeBoolNotation.
-Module Type LtBool' := LtBool <+ LtBoolNotation.
+Module Type LebSpec (T:Typ)(X:HasLe T)(Y:HasLeb T).
+ Parameter leb_le : forall x y, Y.leb x y = true <-> X.le x y.
+End LebSpec.
 
-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 LtbSpec (T:Typ)(X:HasLt T)(Y:HasLtb T).
+ Parameter ltb_lt : forall x y, Y.ltb x y = true <-> X.lt x y.
+End LtbSpec.
 
-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 LeBool := Typ <+ HasLeb.
+Module Type LtBool := Typ <+ HasLtb.
+Module Type LeBool' := LeBool <+ LebNotation.
+Module Type LtBool' := LtBool <+ LtbNotation.
 
-Module Type LeBoolIsTotal (Import X:LeBool').
+Module Type LebIsTotal (Import X:LeBool').
  Axiom leb_total : forall x y, (x <=? y) = true \/ (y <=? x) = true.
-End LeBoolIsTotal.
+End LebIsTotal.
 
-Module Type TotalLeBool := LeBool <+ LeBoolIsTotal.
-Module Type TotalLeBool' := LeBool' <+ LeBoolIsTotal.
+Module Type TotalLeBool := LeBool <+ LebIsTotal.
+Module Type TotalLeBool' := LeBool' <+ LebIsTotal.
 
-Module Type LeBoolIsTransitive (Import X:LeBool').
+Module Type LebIsTransitive (Import X:LeBool').
  Axiom leb_trans : Transitive X.leb.
-End LeBoolIsTransitive.
+End LebIsTransitive.
+
+Module Type TotalTransitiveLeBool := TotalLeBool <+ LebIsTransitive.
+Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LebIsTransitive.
+
+(** Grouping all boolean comparison functions *)
+
+Module Type HasBoolOrdFuns (T:Typ) := HasEqb T <+ HasLtb T <+ HasLeb T.
+
+Module Type HasBoolOrdFuns' (T:Typ) :=
+ HasBoolOrdFuns T <+ EqbNotation T <+ LtbNotation T <+ LebNotation T.
 
-Module Type TotalTransitiveLeBool := TotalLeBool <+ LeBoolIsTransitive.
-Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LeBoolIsTransitive.
+Module Type BoolOrdSpecs (O:EqLtLe)(F:HasBoolOrdFuns O) :=
+ EqbSpec O O F <+ LtbSpec O O F <+ LebSpec O O F.
 
+Module Type OrderFunctions (E:EqLtLe) :=
+  HasCompare E <+ HasBoolOrdFuns E <+ BoolOrdSpecs E.
+Module Type OrderFunctions' (E:EqLtLe) :=
+  HasCompare E <+ CmpNotation E <+ HasBoolOrdFuns' E <+ BoolOrdSpecs E.
 
 (** * From [OrderedTypeFull] to [TotalTransitiveLeBool] *)
 
diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v
index 21ef8eb8..85e7fb17 100644
--- a/theories/Structures/OrdersAlt.v
+++ b/theories/Structures/OrdersAlt.v
@@ -11,8 +11,6 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: OrdersAlt.v 12754 2010-02-12 16:21:48Z letouzey $ *)
-
 Require Import OrderedType Orders.
 Set Implicit Arguments.
 
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
index 9f83d82b..e071d053 100644
--- a/theories/Structures/OrdersEx.v
+++ b/theories/Structures/OrdersEx.v
@@ -11,20 +11,18 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: OrdersEx.v 12641 2010-01-07 15:32:52Z letouzey $ *)
-
-Require Import Orders NatOrderedType POrderedType NOrderedType
- ZOrderedType RelationPairs EqualitiesFacts.
+Require Import Orders NPeano POrderedType NArith
+ ZArith 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 Nat_as_OT := NPeano.Nat.
 Module Positive_as_OT := POrderedType.Positive_as_OT.
-Module N_as_OT := NOrderedType.N_as_OT.
-Module Z_as_OT := ZOrderedType.Z_as_OT.
+Module N_as_OT := BinNat.N.
+Module Z_as_OT := BinInt.Z.
 
 (** An OrderedType can now directly be seen as a DecidableType *)
 
diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v
index a28b7977..2e9c0cf5 100644
--- a/theories/Structures/OrdersFacts.v
+++ b/theories/Structures/OrdersFacts.v
@@ -6,15 +6,76 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-Require Import Basics OrdersTac.
+Require Import Bool Basics OrdersTac.
 Require Export Orders.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** * Properties of [OrderedTypeFull] *)
+(** * Properties of [compare] *)
 
-Module OrderedTypeFullFacts (Import O:OrderedTypeFull').
+Module Type CompareFacts (Import O:DecStrOrder').
+
+ Local Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_eq_iff x y : (x ?= y) = Eq <-> x==y.
+ Proof.
+ case compare_spec; intro H; split; try easy; intro EQ;
+  contradict H; rewrite EQ; apply irreflexivity.
+ Qed.
+
+ Lemma compare_eq x y : (x ?= y) = Eq -> x==y.
+ Proof.
+ apply compare_eq_iff.
+ Qed.
+
+ Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x<y.
+ Proof.
+ case compare_spec; intro H; split; try easy; intro LT;
+  contradict LT; rewrite H; apply irreflexivity.
+ Qed.
+
+ Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y<x.
+ Proof.
+ case compare_spec; intro H; split; try easy; intro LT;
+  contradict LT; rewrite H; apply irreflexivity.
+ Qed.
+
+ Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y).
+ Proof.
+ rewrite compare_lt_iff; intuition.
+ Qed.
+
+ Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y<x).
+ Proof.
+ 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'.
+ case (compare_spec x' y'); autorewrite with order; now rewrite Hxx', Hyy'.
+ Qed.
+
+ Lemma compare_refl x : (x ?= x) = Eq.
+ Proof.
+ case compare_spec; intros; trivial; now elim irreflexivity with x.
+ Qed.
+
+ Lemma compare_antisym x y : (y ?= x) = CompOpp (x ?= y).
+ Proof.
+ case (compare_spec x y); simpl; autorewrite with order;
+  trivial; now symmetry.
+ Qed.
+
+End CompareFacts.
+
+
+ (** * Properties of [OrderedTypeFull] *)
+
+Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull').
 
  Module OrderTac := OTF_to_OrderTac O.
  Ltac order := OrderTac.order.
@@ -47,6 +108,18 @@ Module OrderedTypeFullFacts (Import O:OrderedTypeFull').
  Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x.
  Proof. iorder. Qed.
 
+ Include CompareFacts O.
+
+ Lemma compare_le_iff x y : compare x y <> Gt <-> x<=y.
+ Proof.
+ rewrite le_not_gt_iff. apply compare_ngt_iff.
+ Qed.
+
+ Lemma compare_ge_iff x y : compare x y <> Lt <-> y<=x.
+ Proof.
+ rewrite le_not_gt_iff. apply compare_nlt_iff.
+ Qed.
+
 End OrderedTypeFullFacts.
 
 
@@ -84,50 +157,9 @@ Module OrderedTypeFacts (Import O: OrderedType').
 
   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.
+  Include CompareFacts O.
+  Notation compare_le_iff := compare_ngt_iff (only parsing).
+  Notation compare_ge_iff := compare_nlt_iff (only parsing).
 
   (** For compatibility reasons *)
   Definition eq_dec := eq_dec.
@@ -162,10 +194,6 @@ Module OrderedTypeFacts (Import O: OrderedType').
 End OrderedTypeFacts.
 
 
-
-
-
-
 (** * Tests of the order tactic
 
     Is it at least capable of proving some basic properties ? *)
@@ -208,7 +236,7 @@ Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull.
 
 Definition t := O.t.
 Definition eq := O.eq.
-Instance eq_equiv : Equivalence eq.
+Program Instance eq_equiv : Equivalence eq.
 Definition eq_dec := O.eq_dec.
 
 Definition lt := flip O.lt.
@@ -232,3 +260,195 @@ Qed.
 
 End OrderedTypeRev.
 
+Unset Implicit Arguments.
+
+(** * Order relations derived from a [compare] function.
+
+  We factorize here some common properties for ZArith, NArith
+  and co, where [lt] and [le] are defined in terms of [compare].
+  Note that we do not require anything here concerning compatibility
+  of [compare] w.r.t [eq], nor anything concerning transitivity.
+*)
+
+Module Type CompareBasedOrder (Import E:EqLtLe')(Import C:HasCmp E).
+ Include CmpNotation E C.
+ Include IsEq E.
+ Axiom compare_eq_iff : forall x y, (x ?= y) = Eq <-> x == y.
+ Axiom compare_lt_iff : forall x y, (x ?= y) = Lt <-> x < y.
+ Axiom compare_le_iff : forall x y, (x ?= y) <> Gt <-> x <= y.
+ Axiom compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y).
+End CompareBasedOrder.
+
+Module Type CompareBasedOrderFacts
+ (Import E:EqLtLe')
+ (Import C:HasCmp E)
+ (Import O:CompareBasedOrder E C).
+
+ Lemma compare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x?=y).
+ Proof.
+  case_eq (compare x y); intros H; constructor.
+  now apply compare_eq_iff.
+  now apply compare_lt_iff.
+  rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff.
+ Qed.
+
+ Lemma compare_eq x y : (x ?= y) = Eq -> x==y.
+ Proof.
+ apply compare_eq_iff.
+ Qed.
+
+ Lemma compare_refl x : (x ?= x) = Eq.
+ Proof.
+ now apply compare_eq_iff.
+ Qed.
+
+ Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y<x.
+ Proof.
+ now rewrite <- compare_lt_iff, compare_antisym, CompOpp_iff.
+ Qed.
+
+ Lemma compare_ge_iff x y : (x ?= y) <> Lt <-> y<=x.
+ Proof.
+ now rewrite <- compare_le_iff, compare_antisym, CompOpp_iff.
+ Qed.
+
+ Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y<x).
+ Proof.
+ rewrite compare_gt_iff; intuition.
+ Qed.
+
+ Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y).
+ Proof.
+ rewrite compare_lt_iff; intuition.
+ Qed.
+
+ Lemma compare_nle_iff x y : (x ?= y) = Gt <-> ~(x<=y).
+ Proof.
+ rewrite <- compare_le_iff.
+ destruct compare; split; easy || now destruct 1.
+ Qed.
+
+ Lemma compare_nge_iff x y : (x ?= y) = Lt <-> ~(y<=x).
+ Proof.
+ now rewrite <- compare_nle_iff, compare_antisym, CompOpp_iff.
+ Qed.
+
+ Lemma lt_irrefl x : ~ (x<x).
+ Proof.
+ now rewrite <- compare_lt_iff, compare_refl.
+ Qed.
+
+ Lemma lt_eq_cases n m : n <= m <-> n < m \/ n==m.
+ Proof.
+ rewrite <- compare_lt_iff, <- compare_le_iff, <- compare_eq_iff.
+ destruct (n ?= m); now intuition.
+ Qed.
+
+End CompareBasedOrderFacts.
+
+(** Basic facts about boolean comparisons *)
+
+Module Type BoolOrderFacts
+ (Import E:EqLtLe')
+ (Import C:HasCmp E)
+ (Import F:HasBoolOrdFuns' E)
+ (Import O:CompareBasedOrder E C)
+ (Import S:BoolOrdSpecs E F).
+
+Include CompareBasedOrderFacts E C O.
+
+(** Nota : apart from [eqb_compare] below, facts about [eqb]
+  are in BoolEqualityFacts *)
+
+(** Alternate specifications based on [BoolSpec] and [reflect] *)
+
+Lemma leb_spec0 x y : reflect (x<=y) (x<=?y).
+Proof.
+ apply iff_reflect. symmetry. apply leb_le.
+Defined.
+
+Lemma leb_spec x y : BoolSpec (x<=y) (y<x) (x<=?y).
+Proof.
+ case leb_spec0; constructor; trivial.
+ now rewrite <- compare_lt_iff, compare_nge_iff.
+Qed.
+
+Lemma ltb_spec0 x y : reflect (x<y) (x<?y).
+Proof.
+ apply iff_reflect. symmetry. apply ltb_lt.
+Defined.
+
+Lemma ltb_spec x y : BoolSpec (x<y) (y<=x) (x<?y).
+Proof.
+ case ltb_spec0; constructor; trivial.
+ now rewrite <- compare_le_iff, compare_ngt_iff.
+Qed.
+
+(** Negated variants of the specifications *)
+
+Lemma leb_nle x y : x <=? y = false <-> ~ (x <= y).
+Proof.
+now rewrite <- not_true_iff_false, leb_le.
+Qed.
+
+Lemma leb_gt x y : x <=? y = false <-> y < x.
+Proof.
+now rewrite leb_nle, <- compare_lt_iff, compare_nge_iff.
+Qed.
+
+Lemma ltb_nlt x y : x <? y = false <-> ~ (x < y).
+Proof.
+now rewrite <- not_true_iff_false, ltb_lt.
+Qed.
+
+Lemma ltb_ge x y : x <? y = false <-> y <= x.
+Proof.
+now rewrite ltb_nlt, <- compare_le_iff, compare_ngt_iff.
+Qed.
+
+(** Basic equality laws for boolean tests *)
+
+Lemma leb_refl x : x <=? x = true.
+Proof.
+apply leb_le. apply lt_eq_cases. now right.
+Qed.
+
+Lemma leb_antisym x y : y <=? x = negb (x <? y).
+Proof.
+apply eq_true_iff_eq. now rewrite negb_true_iff, leb_le, ltb_ge.
+Qed.
+
+Lemma ltb_irrefl x : x <? x = false.
+Proof.
+apply ltb_ge. apply lt_eq_cases. now right.
+Qed.
+
+Lemma ltb_antisym x y : y <? x = negb (x <=? y).
+Proof.
+apply eq_true_iff_eq. now rewrite negb_true_iff, ltb_lt, leb_gt.
+Qed.
+
+(** Relation bewteen [compare] and the boolean comparisons *)
+
+Lemma eqb_compare x y :
+ (x =? y) = match compare x y with Eq => true | _ => false end.
+Proof.
+apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff.
+destruct compare; now split.
+Qed.
+
+Lemma ltb_compare x y :
+ (x <? y) = match compare x y with Lt => true | _ => false end.
+Proof.
+apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff.
+destruct compare; now split.
+Qed.
+
+Lemma leb_compare x y :
+ (x <=? y) = match compare x y with Gt => false | _ => true end.
+Proof.
+apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff.
+destruct compare; split; try easy. now destruct 1.
+Qed.
+
+End BoolOrderFacts.
diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v
index 2ed07026..f83b6377 100644
--- a/theories/Structures/OrdersLists.v
+++ b/theories/Structures/OrdersLists.v
@@ -86,11 +86,11 @@ Module KeyOrderedType(Import O:OrderedType).
 
   (* eqk, eqke are equalities, ltk is a strict order *)
 
-  Global Instance eqk_equiv : Equivalence eqk.
+  Global Instance eqk_equiv : Equivalence eqk := _.
 
-  Global Instance eqke_equiv : Equivalence eqke.
+  Global Instance eqke_equiv : Equivalence eqke := _.
 
-  Global Instance ltk_strorder : StrictOrder ltk.
+  Global Instance ltk_strorder : StrictOrder ltk := _.
 
   Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
   Proof. unfold eqk, ltk; auto with *. Qed.
diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v
index 41a98ef2..86ab4776 100644
--- a/theories/Unicode/Utf8.v
+++ b/theories/Unicode/Utf8.v
@@ -1,49 +1,13 @@
 (* -*- coding:utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Logic *)
-Notation "∀ x , P" := (forall x , P)
-  (at level 200, x ident, right associativity) : type_scope.
-Notation "∀ x y , P" := (forall x y , P)
-  (at level 200, x ident, y ident, right associativity) : type_scope.
-Notation "∀ x y z , P" := (forall x y z , P)
-  (at level 200, x ident, y ident, z ident, right associativity) : type_scope.
-Notation "∀ x y z u , P" := (forall x y z u , P)
-  (at level 200, x ident, y ident, z ident, u ident, right associativity)
-  : 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)
-  (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)
-  (at level 200, x ident, y ident, z ident, u ident, right associativity)
-  : type_scope.
-
-Notation "∃ x , P" := (exists x , P)
-  (at level 200, x ident, right associativity) : type_scope.
-Notation "∃ x : t , P" := (exists x : t, P)
-  (at level 200, x ident, right associativity) : type_scope.
-
-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 ≠ y" := (x <> y) (at level 70) : type_scope.
-
-(* Abstraction *)
-(* Not nice
-Notation  "'λ' x : T , y" := ([x:T] y) (at level 1, x,T,y at level 10).
-Notation  "'λ' x := T , y" := ([x:=T] y) (at level 1, x,T,y at level 10).
-*)
+Require Export Utf8_core.
 
 (* Arithmetic *)
 Notation "x ≤ y" := (le x y) (at level 70, no associativity).
@@ -51,10 +15,10 @@ Notation "x ≥ y" := (ge x y) (at level 70, no associativity).
 
 (* test *)
 (*
-Goal ∀ x, True -> (∃ y , x ≥ y + 1) ∨ x ≤ 0.
+Check ∀ x z, True -> (∃ y v, x + v ≥ y + z) ∨ x ≤ 0.
 *)
 
 (* Integer Arithmetic *)
 (* TODO: this should come after ZArith
-Notation "x ≤ y" := (Zle x y) (at level 1, y at level 10).
+Notation "x ≤ y" := (Zle x y) (at level 70, no associativity).
 *)
diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v
index ce637413..31724b3c 100644
--- a/theories/Unicode/Utf8_core.v
+++ b/theories/Unicode/Utf8_core.v
@@ -1,12 +1,14 @@
 (* -*- coding:utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+
+
 (* Logic *)
 Notation "∀  x .. y , P" := (forall x, .. (forall y, P) ..)
   (at level 200, x binder, y binder, right associativity) : type_scope.
diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v
new file mode 100644
index 00000000..28e355fb
--- /dev/null
+++ b/theories/Vectors/Fin.v
@@ -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        *)
+(************************************************************************)
+
+Require Arith_base.
+
+(** [fin n] is a convinient way to represent \[1 .. n\]
+
+[fin n] can be seen as a n-uplet of unit where [F1] is the first element of
+the n-uplet and [FS] set (n-1)-uplet of all the element but the first.
+
+   Author: Pierre Boutillier
+   Institution: PPS, INRIA 12/2010
+*)
+
+Inductive t : nat -> Set :=
+|F1 : forall {n}, t (S n)
+|FS : forall {n}, t n -> t (S n).
+
+Section SCHEMES.
+Definition case0 P (p: t 0): P p :=
+  match p as p' in t n return
+    match n as n' return t n' -> Type
+  with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p'
+  with |F1 _ => @id |FS _ _ => @id end.
+
+Definition caseS (P: forall {n}, t (S n) -> Type)
+  (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p))
+  {n} (p: t (S n)): P p :=
+  match p with
+  |F1 k => P1 k
+  |FS k pp => PS pp
+  end.
+
+Definition rectS (P: forall {n}, t (S n) -> Type)
+  (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)):
+  forall {n} (p: t (S n)), P p :=
+fix rectS_fix {n} (p: t (S n)): P p:=
+  match p with
+  |F1 k => P1 k
+  |FS 0 pp => case0 (fun f => P (FS f)) pp
+  |FS (S k) pp => PS pp (rectS_fix pp)
+  end.
+
+Definition rect2 (P: forall {n} (a b: t n), Type)
+  (H0: forall n, @P (S n) F1 F1)
+  (H1: forall {n} (f: t n), P F1 (FS f))
+  (H2: forall {n} (f: t n), P (FS f) F1)
+  (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)):
+    forall {n} (a b: t n), P a b :=
+fix rect2_fix {n} (a: t n): forall (b: t n), P a b :=
+match a with
+  |F1 m => fun (b: t (S m)) => match b as b' in t n'
+                   return match n',b' with
+                            |0,_ => @ID
+                            |S n0,b0 => P F1 b0
+                          end with
+                     |F1 m' => H0 m'
+                     |FS m' b' => H1 b'
+                   end
+  |FS m a' => fun (b: t (S m)) => match b with
+                         |F1 m' => fun aa: t m' => H2 aa
+                         |FS m' b' => fun aa: t m' => HS aa b' (rect2_fix aa b')
+                       end a'
+end.
+End SCHEMES.
+
+(** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *)
+Fixpoint to_nat {m} (n : t m) : {i | i < m} :=
+  match n in t k return {i | i< k} with
+    |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j)
+    |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end
+  end.
+
+(** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of
+p >= n else *)
+Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } :=
+  match n with
+   |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p))
+   |S n' => match p with
+      |0 => inleft _ (F1)
+      |S p' => match of_nat p' n' with
+        |inleft f => inleft _ (FS f)
+        |inright arg => inright _ (match arg with |ex_intro m e =>
+          ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end)
+      end
+    end
+  end.
+
+(** [of_nat_lt p n H] answers the p{^ th} element of [fin n]
+it behaves much better than [of_nat p n] on open term *)
+Fixpoint of_nat_lt {p n : nat} : p < n -> t n :=
+  match n with
+    |0 => fun H : p < 0 => False_rect _ (Lt.lt_n_O p H)
+    |S n' => match p with
+      |0 => fun _ => @F1 n'
+      |S p' => fun H => FS (of_nat_lt (Lt.lt_S_n _ _ H))
+    end
+  end.
+
+Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p.
+Proof.
+induction p.
+ reflexivity.
+ simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique.
+Qed.
+
+(** [weak p f] answers a function witch is the identity for the p{^  th} first
+element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))]
+with p FSs *)
+Fixpoint weak {m}{n} p (f : t m -> t n) :
+  t (p + m) -> t (p + n) :=
+match p as p' return t (p' + m) -> t (p' + n) with
+  |0 => f
+  |S p' => fun x => match x with
+     |F1 n' => fun eq : n' = p' + m => F1
+     |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq))
+  end (eq_refl _)
+end.
+
+(** The p{^ th} element of [fin m] viewed as the p{^ th} element of
+[fin (m + n)] *)
+Fixpoint L {m} n (p : t m) : t (m + n) :=
+  match p with |F1 _ => F1 |FS _ p' => FS (L n p') end.
+
+Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p).
+Proof.
+induction p.
+  reflexivity.
+  simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p).
+Qed.
+
+(** The p{^ th} element of [fin m] viewed as the p{^ th} element of
+[fin (n + m)]
+Really really ineficient !!! *)
+Definition L_R {m} n (p : t m) : t (n + m).
+induction n.
+  exact p.
+  exact ((fix LS k (p: t k) :=
+    match p with
+      |F1 k' => @F1 (S k')
+      |FS _ p' => FS (LS _ p')
+    end) _ IHn).
+Defined.
+
+(** The p{^ th} element of [fin m] viewed as the (n + p){^ th} element of
+[fin (n + m)] *)
+Fixpoint R {m} n (p : t m) : t (n + m) :=
+  match n with |0 => p |S n' => FS (R n' p) end.
+
+Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p).
+Proof.
+induction n.
+  reflexivity.
+  simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p).
+Qed.
+
+Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) :=
+match o with
+  |F1 m' => L (m' * n) p
+  |FS m' o' => R n (depair o' p)
+end.
+
+Lemma depair_sanity {m n} (o : t m) (p : t n) :
+  proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)).
+induction o ; simpl.
+  rewrite L_sanity. now rewrite Mult.mult_0_r.
+
+  rewrite R_sanity. rewrite IHo.
+  rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r.
+    now rewrite (Plus.plus_comm n).
+Qed.
diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v
new file mode 100644
index 00000000..f3e5e338
--- /dev/null
+++ b/theories/Vectors/Vector.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Vectors.
+
+   Author: Pierre Boutillier
+   Institution: PPS, INRIA 12/2010
+
+Originally from the contribution bit vector by Jean Duprat (ENS Lyon).
+
+Based on contents from Util/VecUtil of the CoLoR contribution *)
+
+Require Fin.
+Require VectorDef.
+Require VectorSpec.
+Include VectorDef.
+Include VectorSpec.
diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v
new file mode 100644
index 00000000..0fee50ff
--- /dev/null
+++ b/theories/Vectors/VectorDef.v
@@ -0,0 +1,317 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Definitions of Vectors and functions to use them
+
+   Author: Pierre Boutillier
+   Institution: PPS, INRIA 12/2010
+*)
+
+(**
+Names should be "caml name in list.ml" if exists and order of arguments
+have to be the same. complain if you see mistakes ... *)
+
+Require Import Arith_base.
+Require Vectors.Fin.
+Import EqNotations.
+Open Local Scope nat_scope.
+
+(**
+A vector is a list of size n whose elements belong to a set A. *)
+
+Inductive t A : nat -> Type :=
+  |nil : t A 0
+  |cons : forall (h:A) (n:nat), t A n -> t A (S n).
+
+Local Notation "[]" := (nil _).
+Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity).
+
+Section SCHEMES.
+
+(** An induction scheme for non-empty vectors *)
+
+Definition rectS {A} (P:forall {n}, t A (S n) -> Type)
+ (bas: forall a: A, P (a :: []))
+ (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) :=
+ fix rectS_fix {n} (v: t A (S n)) : P v :=
+ match v with
+ |nil => @id
+ |cons a 0 v =>
+   match v as vnn in t _ nn
+       return
+         match nn,vnn with
+         |0,vm =>  P (a :: vm)
+         |S _,_ => ID
+         end
+     with
+     |nil => bas a
+     |_ :: _ => @id
+     end
+ |cons a (S nn') v => rect a v (rectS_fix v)
+ end.
+
+(** An induction scheme for 2 vectors of same length *)
+Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
+  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
+    forall a b, P (a :: v1) (b :: v2)) :=
+fix rect2_fix {n} (v1:t A n):
+  forall v2 : t B n, P v1 v2 :=
+match v1 as v1' in t _ n1
+  return forall v2 : t B n1, P v1' v2 with
+  |[] => fun v2 =>
+     match v2 with
+       |[] => bas
+       |_ :: _ => @id
+     end
+  |h1 :: t1 => fun v2 =>
+    match v2 with
+      |[] => @id
+      |h2 :: t2 => fun t1' =>
+        rect (rect2_fix t1' t2) h1 h2
+    end t1
+end.
+
+(** A vector of length [0] is [nil] *)
+Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v :=
+match v with
+  |[] => H
+end.
+
+(** A vector of length [S _] is [cons] *)
+Definition caseS {A} (P : forall n, t A (S n) -> Type)
+  (H : forall h {n} t, @P n (h :: t)) {n} v : P n v :=
+match v with
+  |[] => @id (* Why needed ? *)
+  |h :: t => H h t
+end.
+End SCHEMES.
+
+Section BASES.
+(** The first element of a non empty vector *)
+Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in
+(caseS (fun n v => A) (fun h n t => h) v).
+
+(** The last element of an non empty vector *)
+Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in
+(rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v).
+
+(** Build a vector of n{^ th} [a] *)
+Fixpoint const {A} (a:A) (n:nat) :=
+  match n return t A n with
+  | O => nil A
+  | S n => a :: (const a n)
+  end.
+
+(** The [p]{^ th} element of a vector of length [m].
+
+Computational behavior of this function should be the same as
+ocaml function. *)
+Fixpoint nth {A} {m} (v' : t A m) (p : Fin.t m) {struct p} : A :=
+match p in Fin.t m' return t A m' -> A with
+ |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v
+ |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A)
+   (fun h n t p0 => nth t p0) v) p'
+end v'.
+
+(** An equivalent definition of [nth]. *)
+Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) :=
+(nth v (Fin.of_nat_lt H)).
+
+(** Put [a] at the p{^ th} place of [v] *)
+Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n :=
+  match p with
+  |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v'
+  |Fin.FS k p' => fun v' =>
+    (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p'
+  end v.
+
+(** Version of replace with [lt] *)
+Definition replace_order {A n} (v: t A n) {p} (H: p < n) :=
+replace v (Fin.of_nat_lt H).
+
+(** Remove the first element of a non empty vector *)
+Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in
+(caseS (fun n v => t A n) (fun h n t => t) v).
+
+(** Remove last element of a non-empty vector *)
+Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n :=
+Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => [])
+  (fun h _ _ H => h :: H) v).
+
+(** Add an element at the end of a vector *)
+Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) :=
+match v with
+  |[] => a :: []
+  |h :: t => h :: (shiftin a t)
+end.
+
+(** Copy last element of a vector *)
+Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) :=
+Eval cbv delta beta in (rectS (fun n _ => t A (S (S n)))
+  (fun h =>  h :: h :: []) (fun h _ _ H => h :: H) v).
+
+(** Remove [p] last elements of a vector *)
+Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n
+  -> t A (n - p).
+Proof.
+  induction p as [| p f]; intros H v.
+  rewrite <- minus_n_O.
+  exact v.
+
+  apply shiftout.
+
+  rewrite minus_Sn_m.
+  apply f.
+  auto with *.
+  exact v.
+  auto with *.
+Defined.
+
+(** Concatenation of two vectors *)
+Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n+p) :=
+  match v with
+  | [] => w
+  | a :: v' => a :: (append v' w)
+  end.
+
+Infix "++" := append.
+
+(** Two definitions of the tail recursive function that appends two lists but
+reverses the first one *)
+
+(** This one has the exact expected computational behavior *)
+Fixpoint rev_append_tail {A n p} (v : t A n) (w: t A p)
+  : t A (tail_plus n p) :=
+  match v with
+  | [] => w
+  | a :: v' => rev_append_tail v' (a :: w)
+  end.
+
+Import EqdepFacts.
+
+(** This one has a better type *)
+Definition rev_append {A n p} (v: t A n) (w: t A p)
+  :t A (n + p) :=
+  rew <- (plus_tail_plus n p) in (rev_append_tail v w).
+
+(** rev [a� ; a₂ ; .. ; an] is [an ; a{n-1} ; .. ; a�]
+
+Caution : There is a lot of rewrite garbage in this definition *)
+Definition rev {A n} (v : t A n) : t A n :=
+ rew <- (plus_n_O _) in (rev_append v []).
+
+End BASES.
+Local Notation "v [@ p ]" := (nth v p) (at level 1).
+
+Section ITERATORS.
+(** * Here are special non dependent useful instantiation of induction
+schemes *)
+
+(** Uniform application on the arguments of the vector *)
+Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n :=
+  fix map_fix {n} (v : t A n) : t B n := match v with
+  | [] => []
+  | a :: v' => (f a) :: (map_fix v')
+  end.
+
+(** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *)
+Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n)
+  : t C n :=
+Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C)
+  (fun _ _ _ H a b => (g a b) :: H) v1 v2.
+
+(** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *)
+Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B :=
+  fix fold_left_fix (b:B) {n} (v : t A n) : B := match v with
+    | [] => b
+    | a :: w => (fold_left_fix (f b a) w)
+  end.
+
+(** fold_right f [x1 .. xn] b = f x1 (f x2 .. (f xn b) .. ) *)
+Definition fold_right {A B : Type} (f : A->B->B) :=
+  fix fold_right_fix {n} (v : t A n) (b:B)
+  {struct v} : B :=
+  match v with
+    | [] => b
+    | a :: w => f a (fold_right_fix w b)
+  end.
+
+(** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *)
+Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n)
+  (w : t B n) (c:C) : C :=
+Eval cbv delta beta in rect2 (fun _ _ _ => C) c
+  (fun _ _ _ H a b => g a b H) v w.
+
+(** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *)
+Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) :=
+fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A :=
+match v in t _ n0 return t C n0 -> A with
+  |[] => fun w => match w in t _ n1
+    return match n1 with |0 => A |S _ => @ID end with
+    |[] => a
+    |_ :: _ => @id end
+  |cons vh vn vt => fun w => match w in t _ n1
+    return match n1 with |0 => @ID |S n => t B n -> A end with
+    |[] => @id
+    |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt
+end.
+
+End ITERATORS.
+
+Section SCANNING.
+Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop :=
+ |Forall_nil: Forall P []
+ |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v).
+Hint Constructors Forall.
+
+Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop :=
+ |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v)
+ |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v).
+Hint Constructors Exists.
+
+Inductive In {A} (a:A): forall {n}, t A n -> Prop :=
+ |In_cons_hd {m} (v: t A m): In a (a::v)
+ |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v).
+Hint Constructors In.
+
+Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop :=
+ |Forall2_nil: Forall2 P [] []
+ |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 ->
+    Forall2 P (x1::v1) (x2::v2).
+Hint Constructors Forall2.
+
+Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop :=
+ |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2)
+ |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2).
+Hint Constructors Exists2.
+
+End SCANNING.
+
+Section VECTORLIST.
+(** * vector <=> list functions *)
+
+Fixpoint of_list {A} (l : list A) : t A (length l) :=
+match l as l' return t A (length l') with
+  |Datatypes.nil => []
+  |(h :: tail)%list => (h :: (of_list tail))
+end.
+
+Definition to_list {A}{n} (v : t A n) : list A :=
+Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.nil.
+End VECTORLIST.
+
+Module VectorNotations.
+Notation "[]" := [] : vector_scope.
+Notation "h :: t" := (h :: t) (at level 60, right associativity)
+  : vector_scope.
+Notation " [ x ] " := (x :: []) : vector_scope.
+Notation " [ x ; .. ; y ] " := (cons _ x _ .. (cons _ y _ (nil _)) ..) : vector_scope
+.
+Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope.
+Open Scope vector_scope.
+End VectorNotations.
diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v
new file mode 100644
index 00000000..a576315e
--- /dev/null
+++ b/theories/Vectors/VectorSpec.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        *)
+(************************************************************************)
+
+(** Proofs of specification for functions defined over Vector
+
+   Author: Pierre Boutillier
+   Institution: PPS, INRIA 12/2010
+*)
+
+Require Fin.
+Require Import VectorDef.
+Import VectorNotations.
+
+(** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all
+is true for the one that use [lt] *)
+
+Lemma eq_nth_iff A n (v1 v2: t A n):
+  (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2.
+Proof.
+split.
+  revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros.
+    reflexivity.
+    f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl).
+    apply H. intros p1 p2 H1;
+    apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)).
+  intros; now f_equal.
+Qed.
+
+Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n),
+ nth_order v H = last v.
+Proof.
+unfold nth_order; refine (@rectS _ _ _ _); now simpl.
+Qed.
+
+Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2):
+  nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2.
+Proof.
+subst k2; induction k1.
+  generalize dependent n. apply caseS ; intros. now simpl.
+  generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl.
+Qed.
+
+Lemma shiftin_last A a n (v: t A n): last (shiftin a v) = a.
+Proof.
+induction v ;now simpl.
+Qed.
+
+Lemma shiftrepeat_nth A: forall n k (v: t A (S n)),
+  nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k.
+Proof.
+refine (@Fin.rectS _ _ _); intros.
+  revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t.
+  revert p H.
+  refine (match v as v' in t _ m return match m as m' return t A m' -> Type with
+    |S (S n) => fun v => forall p : Fin.t (S n),
+      (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) ->
+      (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p]
+    |_ => fun _ => @ID end v' with
+  |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl.
+Qed.
+
+Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v.
+Proof.
+refine (@rectS _ _ _ _); now simpl.
+Qed.
+
+Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a.
+Proof.
+now induction p.
+Qed.
+
+Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2):
+  (map f v) [@ p1] = f (v [@ p2]).
+Proof.
+subst p2; induction p1.
+  revert n v; refine (@caseS _ _ _); now simpl.
+  revert n v p1 IHp1; refine (@caseS _  _ _); now simpl.
+Qed.
+
+Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n):
+  p1 = p2 -> p2 = p3 -> (map2 f v w) [@p1] = f (v[@p2]) (w[@p3]).
+Proof.
+intros; subst p2; subst p3; revert n v w p1.
+refine (@rect2 _ _ _ _ _); simpl.
+  exact (Fin.case0 _).
+  intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _);
+    now simpl.
+Qed.
+
+Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A}
+  (assoc: forall a b c, f (f a b) c = f (f a c) b)
+  {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a.
+Proof.
+assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h).
+  induction v0.
+    now simpl.
+    intros; simpl. rewrite<- IHv0. now f_equal.
+  induction v.
+    reflexivity.
+    simpl. intros; now rewrite<- (IHv).
+Qed.
+
+Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l.
+Proof.
+induction l.
+  reflexivity.
+  unfold to_list; simpl. now f_equal.
+Qed.
diff --git a/theories/Vectors/vo.itarget b/theories/Vectors/vo.itarget
new file mode 100644
index 00000000..7f00d016
--- /dev/null
+++ b/theories/Vectors/vo.itarget
@@ -0,0 +1,4 @@
+Fin.vo
+VectorDef.vo
+VectorSpec.vo
+Vector.vo
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
index ccfef1e6..f5daa301 100644
--- a/theories/Wellfounded/Disjoint_Union.v
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Disjoint_Union.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Cristina Cornes
     From : Constructing Recursion Operators in Type Theory
            L. Paulson  JSC (1986) 2, 325-355 *)
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index fad1978e..1c83c481 100644
--- a/theories/Wellfounded/Inclusion.v
+++ b/theories/Wellfounded/Inclusion.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inclusion.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Bruno Barras *)
 
 Require Import Relation_Definitions.
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index 204cff19..27a1c381 100644
--- a/theories/Wellfounded/Inverse_Image.v
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inverse_Image.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Bruno Barras *)
 
 Section Inverse_Image.
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index bc8803ad..6d5b663b 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Exponentiation.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Cristina Cornes
 
     From : Constructing Recursion Operators in Type Theory
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index e0f0cc8f..ce0fee71 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Product.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Authors: Bruno Barras, Cristina Cornes *)
 
 Require Import Eqdep.
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index 59832b1b..e9bc7ccf 100644
--- a/theories/Wellfounded/Transitive_Closure.v
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Transitive_Closure.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Bruno Barras *)
 
 Require Import Relation_Definitions.
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index 84d75754..e3fdc4c5 100644
--- a/theories/Wellfounded/Union.v
+++ b/theories/Wellfounded/Union.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Union.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Bruno Barras *)
 
 Require Import Relation_Operators.
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index cec21555..fc4e2ebc 100644
--- a/theories/Wellfounded/Well_Ordering.v
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Well_Ordering.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Author: Cristina Cornes.
     From: Constructing Recursion Operators in Type Theory
     L. Paulson  JSC (1986) 2, 325-355 *)
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index 03b7b210..4dc4d59d 100644
--- a/theories/Wellfounded/Wellfounded.v
+++ b/theories/Wellfounded/Wellfounded.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wellfounded.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Export Disjoint_Union.
 Require Export Inclusion.
 Require Export Inverse_Image.
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index e2b89d84..3a5eb885 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -1,1158 +1,1585 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+Require Export BinNums BinPos Pnat.
+Require Import BinNat Bool Plus Mult Equalities GenericMinMax
+ OrdersFacts ZAxioms ZProperties.
+Require BinIntDef.
 
 (***********************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(** * Binary Integers *)
 (***********************************************************)
 
-Require Export BinPos.
-Require Export Pnat.
-Require Import BinNat.
-Require Import Plus.
-Require Import Mult.
+(** Initial author: Pierre Crégut, CNET, Lannion, France *)
 
-Unset Boxed Definitions.
+(** The type [Z] and its constructors [Z0] and [Zpos] and [Zneg]
+    are now defined in [BinNums.v] *)
 
-(*****************************)
-(** * Binary integer numbers *)
+Local Open Scope Z_scope.
 
-Inductive Z : Set :=
-  | Z0 : Z
-  | Zpos : positive -> Z
-  | Zneg : positive -> Z.
+(** Every definitions and early properties about binary integers
+    are placed in a module [Z] for qualification purpose. *)
 
+Module Z
+ <: ZAxiomsSig
+ <: UsualOrderedTypeFull
+ <: UsualDecidableTypeFull
+ <: TotalOrder.
 
-(** Automatically open scope positive_scope for the constructors of Z *)
-Delimit Scope Z_scope with Z.
-Bind Scope Z_scope with Z.
-Arguments Scope Zpos [positive_scope].
-Arguments Scope Zneg [positive_scope].
-
-(** ** Subtraction of positive into Z *)
-
-Definition Zdouble_plus_one (x:Z) :=
-  match x with
-    | Z0 => Zpos 1
-    | Zpos p => Zpos p~1
-    | Zneg p => Zneg (Pdouble_minus_one p)
-  end.
-
-Definition Zdouble_minus_one (x:Z) :=
-  match x with
-    | Z0 => Zneg 1
-    | Zneg p => Zneg p~1
-    | Zpos p => Zpos (Pdouble_minus_one p)
-  end.
-
-Definition Zdouble (x:Z) :=
-  match x with
-    | Z0 => Z0
-    | Zpos p => Zpos p~0
-    | Zneg p => Zneg p~0
-  end.
-
-Open Local Scope positive_scope.
-
-Fixpoint ZPminus (x y:positive) {struct y} : Z :=
-  match x, y with
-    | p~1, q~1 => Zdouble (ZPminus p q)
-    | p~1, q~0 => Zdouble_plus_one (ZPminus p q)
-    | p~1, 1 => Zpos p~0
-    | p~0, q~1 => Zdouble_minus_one (ZPminus p q)
-    | p~0, q~0 => Zdouble (ZPminus p q)
-    | p~0, 1 => Zpos (Pdouble_minus_one p)
-    | 1, q~1 => Zneg q~0
-    | 1, q~0 => Zneg (Pdouble_minus_one q)
-    | 1, 1 => Z0
-  end.
-
-Close Local Scope positive_scope.
-
-(** ** Addition on integers *)
-
-Definition Zplus (x y:Z) :=
-  match x, y with
-    | Z0, y => y
-    | Zpos x', Z0 => Zpos x'
-    | Zneg x', Z0 => Zneg x'
-    | Zpos x', Zpos y' => Zpos (x' + y')
-    | Zpos x', Zneg y' =>
-      match (x' ?= y')%positive Eq with
-	| Eq => Z0
-	| Lt => Zneg (y' - x')
-	| Gt => Zpos (x' - y')
-      end
-    | Zneg x', Zpos y' =>
-      match (x' ?= y')%positive Eq with
-	| Eq => Z0
-	| Lt => Zpos (y' - x')
-	| Gt => Zneg (x' - y')
-      end
-    | Zneg x', Zneg y' => Zneg (x' + y')
-  end.
-
-Infix "+" := Zplus : Z_scope.
-
-(** ** Opposite *)
-
-Definition Zopp (x:Z) :=
-  match x with
-    | Z0 => Z0
-    | Zpos x => Zneg x
-    | Zneg x => Zpos x
-  end.
-
-Notation "- x" := (Zopp x) : Z_scope.
-
-(** ** Successor on integers *)
-
-Definition Zsucc (x:Z) := (x + Zpos 1)%Z.
-
-(** ** Predecessor on integers *)
-
-Definition Zpred (x:Z) := (x + Zneg 1)%Z.
-
-(** ** Subtraction on integers *)
-
-Definition Zminus (m n:Z) := (m + - n)%Z.
-
-Infix "-" := Zminus : Z_scope.
-
-(** ** Multiplication on integers *)
-
-Definition Zmult (x y:Z) :=
-  match x, y with
-    | Z0, _ => Z0
-    | _, Z0 => Z0
-    | Zpos x', Zpos y' => Zpos (x' * y')
-    | Zpos x', Zneg y' => Zneg (x' * y')
-    | Zneg x', Zpos y' => Zneg (x' * y')
-    | Zneg x', Zneg y' => Zpos (x' * y')
-  end.
-
-Infix "*" := Zmult : Z_scope.
-
-(** ** Comparison of integers *)
-
-Definition Zcompare (x y:Z) :=
-  match x, y with
-    | Z0, Z0 => Eq
-    | Z0, Zpos y' => Lt
-    | Z0, Zneg y' => Gt
-    | Zpos x', Z0 => Gt
-    | Zpos x', Zpos y' => (x' ?= y')%positive Eq
-    | Zpos x', Zneg y' => Gt
-    | Zneg x', Z0 => Lt
-    | Zneg x', Zpos y' => Lt
-    | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq)
-  end.
-
-Infix "?=" := Zcompare (at level 70, no associativity) : Z_scope.
+(** * Definitions of operations, now in a separate file *)
 
-Ltac elim_compare com1 com2 :=
-  case (Dcompare (com1 ?= com2)%Z);
-    [ idtac | let x := fresh "H" in
-      (intro x; case x; clear x) ].
+Include BinIntDef.Z.
+
+(** When including property functors, only inline t eq zero one two *)
 
-(** ** Sign function *)
+Set Inline Level 30.
 
-Definition Zsgn (z:Z) : Z :=
-  match z with
-    | Z0 => Z0
-    | Zpos p => Zpos 1
-    | Zneg p => Zneg 1
-  end.
+(** * Logic Predicates *)
+
+Definition eq := @Logic.eq Z.
+Definition eq_equiv := @eq_equivalence Z.
+
+Definition lt x y := (x ?= y) = Lt.
+Definition gt x y := (x ?= y) = Gt.
+Definition le x y := (x ?= y) <> Gt.
+Definition ge x y := (x ?= y) <> Lt.
+
+Infix "<=" := le : Z_scope.
+Infix "<" := lt : Z_scope.
+Infix ">=" := ge : Z_scope.
+Infix ">" := gt : Z_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope.
+Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.
 
-(** ** Direct, easier to handle variants of successor and addition *)
+Definition divide x y := exists z, y = z*x.
+Notation "( x | y )" := (divide x y) (at level 0).
 
-Definition Zsucc' (x:Z) :=
-  match x with
-    | Z0 => Zpos 1
-    | Zpos x' => Zpos (Psucc x')
-    | Zneg x' => ZPminus 1 x'
-  end.
+Definition Even a := exists b, a = 2*b.
+Definition Odd a := exists b, a = 2*b+1.
 
-Definition Zpred' (x:Z) :=
-  match x with
-    | Z0 => Zneg 1
-    | Zpos x' => ZPminus x' 1
-    | Zneg x' => Zneg (Psucc x')
-  end.
+(** * Decidability of equality. *)
 
-Definition Zplus' (x y:Z) :=
-  match x, y with
-    | Z0, y => y
-    | x, Z0 => x
-    | Zpos x', Zpos y' => Zpos (x' + y')
-    | Zpos x', Zneg y' => ZPminus x' y'
-    | Zneg x', Zpos y' => ZPminus y' x'
-    | Zneg x', Zneg y' => Zneg (x' + y')
-  end.
+Definition eq_dec (x y : Z) : {x = y} + {x <> y}.
+Proof.
+ decide equality; apply Pos.eq_dec.
+Defined.
 
-Open Local Scope Z_scope.
+(** * Properties of [pos_sub] *)
 
-(**********************************************************************)
-(** ** Inductive specification of Z *)
+(** [pos_sub] can be written in term of positive comparison
+    and subtraction (cf. earlier definition of addition of Z) *)
 
-Theorem Zind :
-  forall P:Z -> Prop,
-    P Z0 ->
-    (forall x:Z, P x -> P (Zsucc' x)) ->
-    (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n.
+Lemma pos_sub_spec p q :
+ pos_sub p q =
+ match (p ?= q)%positive with
+   | Eq => 0
+   | Lt => Zneg (q - p)
+   | Gt => Zpos (p - q)
+ end.
 Proof.
-  intros P H0 Hs Hp z; destruct z.
-  assumption.
-  apply Pind with (P := fun p => P (Zpos p)).
-    change (P (Zsucc' Z0)) in |- *; apply Hs; apply H0.
-    intro n; exact (Hs (Zpos n)).
-  apply Pind with (P := fun p => P (Zneg p)).
-    change (P (Zpred' Z0)) in |- *; apply Hp; apply H0.
-    intro n; exact (Hp (Zneg n)).
+ revert q. induction p; destruct q; simpl; trivial;
+ rewrite ?Pos.compare_xI_xI, ?Pos.compare_xO_xI,
+  ?Pos.compare_xI_xO, ?Pos.compare_xO_xO, IHp; simpl;
+ case Pos.compare_spec; intros; simpl; trivial;
+  (now rewrite Pos.sub_xI_xI) || (now rewrite Pos.sub_xO_xO) ||
+  (now rewrite Pos.sub_xO_xI) || (now rewrite Pos.sub_xI_xO) ||
+  subst; unfold Pos.sub; simpl; now rewrite Pos.sub_mask_diag.
 Qed.
 
-(**********************************************************************)
-(** * Misc properties about binary integer operations *)
+(** Particular cases of the previous result *)
 
+Lemma pos_sub_diag p : pos_sub p p = 0.
+Proof.
+ now rewrite pos_sub_spec, Pos.compare_refl.
+Qed.
 
-(**********************************************************************)
-(** ** Properties of opposite on binary integer numbers *)
+Lemma pos_sub_lt p q : (p < q)%positive -> pos_sub p q = Zneg (q - p).
+Proof.
+ intros H. now rewrite pos_sub_spec, H.
+Qed.
 
-Theorem Zopp_0 : Zopp Z0 = Z0.
+Lemma pos_sub_gt p q : (q < p)%positive -> pos_sub p q = Zpos (p - q).
 Proof.
-  reflexivity.
+ intros H. now rewrite pos_sub_spec, Pos.compare_antisym, H.
 Qed.
 
-Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
+(** The opposite of [pos_sub] is [pos_sub] with reversed arguments *)
+
+Lemma pos_sub_opp p q : - pos_sub p q = pos_sub q p.
 Proof.
-  reflexivity.
+ revert q; induction p; destruct q; simpl; trivial;
+ rewrite <- IHp; now destruct pos_sub.
 Qed.
 
-(** [opp] is involutive *)
+(** * Results concerning [Zpos] and [Zneg] and the operators *)
 
-Theorem Zopp_involutive : forall n:Z, - - n = n.
+Lemma opp_Zneg p : - Zneg p = Zpos p.
 Proof.
-  intro x; destruct x; reflexivity.
+ reflexivity.
 Qed.
 
-(** Injectivity of the opposite *)
+Lemma opp_Zpos p : - Zpos p = Zneg p.
+Proof.
+ reflexivity.
+Qed.
 
-Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m.
+Lemma succ_Zpos p : succ (Zpos p) = Zpos (Pos.succ p).
 Proof.
-  intros x y; case x; case y; simpl in |- *; intros;
-    [ trivial
-      | discriminate H
-      | discriminate H
-      | discriminate H
-      | simplify_eq H; intro E; rewrite E; trivial
-      | discriminate H
-      | discriminate H
-      | discriminate H
-      | simplify_eq H; intro E; rewrite E; trivial ].
+ simpl. f_equal. apply Pos.add_1_r.
 Qed.
 
-(**********************************************************************)
-(** ** Other properties of binary integer numbers *)
+Lemma add_Zpos p q : Zpos p + Zpos q = Zpos (p+q).
+Proof.
+ reflexivity.
+Qed.
 
-Lemma ZL0 : 2%nat = (1 + 1)%nat.
+Lemma add_Zneg p q : Zneg p + Zneg q = Zneg (p+q).
 Proof.
-  reflexivity.
+ reflexivity.
 Qed.
 
-(**********************************************************************)
-(** * Properties of the addition on integers *)
+Lemma add_Zpos_Zneg p q : Zpos p + Zneg q = pos_sub p q.
+Proof.
+ reflexivity.
+Qed.
 
-(** ** Zero is left neutral for addition *)
+Lemma add_Zneg_Zpos p q : Zneg p + Zpos q = pos_sub q p.
+Proof.
+ reflexivity.
+Qed.
 
-Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
+Lemma sub_Zpos n m : (n < m)%positive -> Zpos m - Zpos n = Zpos (m-n).
 Proof.
-  intro x; destruct x; reflexivity.
+ intros H. simpl. now apply pos_sub_gt.
 Qed.
 
-(** ** Zero is right neutral for addition *)
+Lemma mul_Zpos (p q : positive) : Zpos p * Zpos q = Zpos (p*q).
+Proof.
+ reflexivity.
+Qed.
 
-Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
+Lemma pow_Zpos p q : (Zpos p)^(Zpos q) = Zpos (p^q).
 Proof.
-  intro x; destruct x; reflexivity.
+ unfold Pos.pow, pow, pow_pos.
+ symmetry. now apply Pos.iter_swap_gen.
 Qed.
 
-(** ** Addition is commutative *)
+Lemma inj_Zpos p q : Zpos p = Zpos q <-> p = q.
+Proof.
+ split; intros H. now injection H. now f_equal.
+Qed.
 
-Theorem Zplus_comm : forall n m:Z, n + m = m + n.
+Lemma inj_Zneg p q : Zneg p = Zneg q <-> p = q.
 Proof.
-  intro x; induction x as [| p| p]; intro y; destruct y as [| q| q];
-    simpl in |- *; try reflexivity.
-  rewrite Pplus_comm; reflexivity.
-  rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
-  rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
-  rewrite Pplus_comm; reflexivity.
+ split; intros H. now injection H. now f_equal.
 Qed.
 
-(** ** Opposite distributes over addition *)
+Lemma pos_xI p : Zpos p~1 = 2 * Zpos p + 1.
+Proof.
+ reflexivity.
+Qed.
 
-Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m.
+Lemma pos_xO p : Zpos p~0 = 2 * Zpos p.
 Proof.
-  intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
-    simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq);
-      reflexivity.
+ reflexivity.
 Qed.
 
-Theorem Zopp_succ : forall n:Z, Zopp (Zsucc n) = Zpred (Zopp n).
+Lemma neg_xI p : Zneg p~1 = 2 * Zneg p - 1.
 Proof.
-intro; unfold Zsucc; now rewrite Zopp_plus_distr.
+ reflexivity.
 Qed.
 
-(** ** Opposite is inverse for addition *)
+Lemma neg_xO p : Zneg p~0 = 2 * Zneg p.
+Proof.
+ reflexivity.
+Qed.
+
+(** In the following module, we group results that are needed now
+  to prove specifications of operations, but will also be provided
+  later by the generic functor of properties. *)
+
+Module Import Private_BootStrap.
+
+(** * Properties of addition *)
+
+(** ** Zero is neutral for addition *)
 
-Theorem Zplus_opp_r : forall n:Z, n + - n = Z0.
+Lemma add_0_r n : n + 0 = n.
 Proof.
-  intro x; destruct x as [| p| p]; simpl in |- *;
-    [ reflexivity
-      | rewrite (Pcompare_refl p); reflexivity
-      | rewrite (Pcompare_refl p); reflexivity ].
+ now destruct n.
 Qed.
 
-Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
+(** ** Addition is commutative *)
+
+Lemma add_comm n m : n + m = m + n.
+Proof.
+ destruct n, m; simpl; trivial; now rewrite Pos.add_comm.
+Qed.
+
+(** ** Opposite distributes over addition *)
+
+Lemma opp_add_distr n m : - (n + m) = - n + - m.
 Proof.
-  intro; rewrite Zplus_comm; apply Zplus_opp_r.
+ destruct n, m; simpl; trivial using pos_sub_opp.
 Qed.
 
-Hint Local Resolve Zplus_0_l Zplus_0_r.
+(** ** Opposite is injective *)
+
+Lemma opp_inj n m : -n = -m -> n = m.
+Proof.
+ destruct n, m; simpl; intros H; destr_eq H; now f_equal.
+Qed.
 
 (** ** Addition is associative *)
 
-Lemma weak_assoc :
-  forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n.
-Proof.
-  intros x y z'; case z';
-    [ auto with arith
-      | intros z; simpl in |- *; rewrite Pplus_assoc; auto with arith
-      | intros z; simpl in |- *; ElimPcompare y z; intros E0; rewrite E0;
-	ElimPcompare (x + y)%positive z; intros E1; rewrite E1;
-	  [ absurd ((x + y ?= z)%positive Eq = Eq);
-	    [  (* Case 1 *)
-              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 |- *;
-			apply le_n_S; apply le_plus_r ]
-	      | assumption ]
-	    | absurd ((x + y ?= z)%positive Eq = Lt);
-	      [  (* Case 2 *)
-		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 |- *;
-			  apply le_n_S; apply le_plus_r ]
-		| assumption ]
-	    | rewrite (Pcompare_Eq_eq y z E0);
-          (* Case 3 *)
-	      elim (Pminus_mask_Gt (x + z) z);
-		[ intros t H; elim H; intros H1 H2; elim H2; intros H3 H4;
-		  unfold Pminus in |- *; rewrite H1; cut (x = t);
-		    [ intros E; rewrite E; auto with arith
-		      | apply Pplus_reg_r with (r := z); rewrite <- H3;
-			rewrite Pplus_comm; trivial with arith ]
-		  | pattern z at 1 in |- *; rewrite <- (Pcompare_Eq_eq y z E0);
-		    assumption ]
-	    | elim (Pminus_mask_Gt z y);
-	      [  (* Case 4 *)
-		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-		  unfold Pminus at 1 in |- *; rewrite H1; cut (x = k);
-		    [ intros E; rewrite E; rewrite (Pcompare_refl k);
-		      trivial with arith
-		      | apply Pplus_reg_r with (r := y); rewrite (Pplus_comm k y);
-			rewrite H3; apply Pcompare_Eq_eq; assumption ]
-		| apply ZC2; assumption ]
-	    | elim (Pminus_mask_Gt z y);
-	      [  (* Case 5 *)
-		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-		  unfold Pminus at 1 3 5 in |- *; rewrite H1;
-		    cut ((x ?= k)%positive Eq = Lt);
-		      [ intros E2; rewrite E2; elim (Pminus_mask_Gt k x);
-			[ 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 |- *;
-				rewrite H6; rewrite H11; cut (i = j);
-				  [ intros E; rewrite E; auto with arith
-				    | apply (Pplus_reg_l (x + y)); rewrite H13;
-				      rewrite (Pplus_comm x y); rewrite <- Pplus_assoc;
-					rewrite H8; assumption ]
-			      | apply ZC2; assumption ]
-			  | apply ZC2; assumption ]
-			| 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;
-				rewrite H3; rewrite Pplus_comm; assumption ]
-		| apply ZC2; assumption ]
-	    | elim (Pminus_mask_Gt z y);
-	      [  (* Case 6 *)
-		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-		  elim (Pminus_mask_Gt (x + y) z);
-		    [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
-		      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;
-				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;
-					      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;
-					assumption ]
-		      | assumption ]
-		| apply ZC2; assumption ]
-	    | absurd ((x + y ?= z)%positive Eq = Eq);
-	      [  (* Case 7 *)
-		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-		  [ discriminate
-		    | rewrite nat_of_P_plus_morphism; unfold gt in |- *;
-		      apply lt_le_trans with (m := nat_of_P y);
-			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-			  | apply le_plus_r ] ]
-		| assumption ]
-	    | absurd ((x + y ?= z)%positive Eq = Lt);
-	      [  (* Case 8 *)
-		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-		  [ discriminate
-		    | unfold gt in |- *; apply lt_le_trans with (m := nat_of_P y);
-		      [ exact (nat_of_P_gt_Gt_compare_morphism y z E0)
-			| rewrite nat_of_P_plus_morphism; apply le_plus_r ] ]
-		| 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;
-		    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;
-			      trivial with arith ] ] ].
-Qed.
-
-Hint Local Resolve weak_assoc.
-
-Theorem Zplus_assoc : forall n m p:Z, n + (m + p) = n + m + p.
-Proof.
-  intros x y z; case x; case y; case z; auto with arith; intros;
-    [ rewrite (Zplus_comm (Zneg p0)); rewrite weak_assoc;
-      rewrite (Zplus_comm (Zpos p1 + Zneg p0)); rewrite weak_assoc;
-	rewrite (Zplus_comm (Zpos p1)); trivial with arith
-      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-	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));
-		trivial with arith
-      | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p));
-	rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0));
-	  trivial with arith
-      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-	rewrite (Zplus_comm (- Zpos p0)); rewrite weak_assoc;
-	  rewrite (Zplus_comm (Zpos p1 + - Zpos p0)); rewrite weak_assoc;
-	    rewrite (Zplus_comm (Zpos p)); trivial with arith
-      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-	apply weak_assoc
-      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-	apply weak_assoc ].
-Qed.
-
-
-Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p).
-Proof.
-  intros; symmetry  in |- *; apply Zplus_assoc.
-Qed.
-
-(** ** Associativity mixed with commutativity *)
-
-Theorem Zplus_permute : forall n m p:Z, n + (m + p) = m + (n + p).
-Proof.
-  intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc;
-    rewrite (Zplus_comm p n); trivial with arith.
-Qed.
-
-(** ** Addition simplifies *)
-
-Theorem Zplus_reg_l : forall n m p:Z, n + m = n + p -> m = p.
-  intros n m p H; cut (- n + (n + m) = - n + (n + p));
-    [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n);
-      rewrite Zplus_opp_r; simpl in |- *; trivial with arith
-      | rewrite H; trivial with arith ].
-Qed.
-
-(** ** Addition and successor permutes *)
-
-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));
-      trivial with arith.
-Qed.
-
-Lemma Zplus_succ_r_reverse : forall n m:Z, Zsucc (n + m) = n + Zsucc m.
-Proof.
-  intros n m; unfold Zsucc in |- *; rewrite Zplus_assoc; trivial with arith.
+Lemma pos_sub_add p q r :
+  pos_sub (p + q) r = Zpos p + pos_sub q r.
+Proof.
+ simpl. rewrite !pos_sub_spec.
+ case (Pos.compare_spec q r); intros E0.
+ - (* q = r *)
+   subst.
+   assert (H := Pos.lt_add_r r p).
+   rewrite Pos.add_comm in H. apply Pos.lt_gt in H.
+   now rewrite H, Pos.add_sub.
+ - (* q < r *)
+   rewrite pos_sub_spec.
+   assert (Hr : (r = (r-q)+q)%positive) by (now rewrite Pos.sub_add).
+   rewrite Hr at 1. rewrite Pos.add_compare_mono_r.
+   case Pos.compare_spec; intros E1; trivial; f_equal.
+   rewrite Pos.add_comm. apply Pos.sub_add_distr.
+   rewrite Hr, Pos.add_comm. now apply Pos.add_lt_mono_r.
+   symmetry. apply Pos.sub_sub_distr; trivial.
+ - (* r < q *)
+   assert (LT : (r < p + q)%positive).
+   { apply Pos.lt_trans with q; trivial.
+     rewrite Pos.add_comm. apply Pos.lt_add_r. }
+   apply Pos.lt_gt in LT. rewrite LT. f_equal.
+   symmetry. now apply Pos.add_sub_assoc.
+Qed.
+
+Lemma add_assoc n m p : n + (m + p) = n + m + p.
+Proof.
+ assert (AUX : forall x y z, Zpos x + (y + z) = Zpos x + y + z).
+ { intros x [|y|y] [|z|z]; rewrite ?add_0_r; trivial.
+   - simpl. now rewrite Pos.add_assoc.
+   - simpl (_ + Zneg _). symmetry. apply pos_sub_add.
+   - simpl (Zneg _ + _); simpl (_ + Zneg _).
+     now rewrite (add_comm _ (Zpos _)), <- 2 pos_sub_add, Pos.add_comm.
+   - apply opp_inj. rewrite !opp_add_distr, opp_Zpos, !opp_Zneg.
+     simpl (Zneg _ + _); simpl (_ + Zneg _).
+     rewrite add_comm, Pos.add_comm. apply pos_sub_add. }
+ destruct n.
+ - trivial.
+ - apply AUX.
+ - apply opp_inj. rewrite !opp_add_distr, opp_Zneg. apply AUX.
+Qed.
+
+(** ** Subtraction and successor *)
+
+Lemma sub_succ_l n m : succ n - m = succ (n - m).
+Proof.
+ unfold sub, succ. now rewrite <- 2 add_assoc, (add_comm 1).
 Qed.
 
-Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing).
+(** ** Opposite is inverse for addition *)
 
-Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m.
+Lemma add_opp_diag_r n : n + - n = 0.
 Proof.
-  unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc;
-    rewrite (Zplus_comm (Zpos 1)); trivial with arith.
+ destruct n; simpl; trivial; now rewrite pos_sub_diag.
 Qed.
 
-(** ** Misc properties, usually redundant or non natural *)
-
-Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0.
+Lemma add_opp_diag_l n : - n + n = 0.
 Proof.
-  symmetry  in |- *; apply Zplus_0_r.
+ rewrite add_comm. apply add_opp_diag_r.
 Qed.
 
-Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m.
+(** ** Commutativity of multiplication *)
+
+Lemma mul_comm n m : n * m = m * n.
 Proof.
-  intros n m; rewrite Zplus_0_r; intro; assumption.
+ destruct n, m; simpl; trivial; f_equal; apply Pos.mul_comm.
 Qed.
 
-Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m.
+(** ** Associativity of multiplication *)
+
+Lemma mul_assoc n m p : n * (m * p) = n * m * p.
 Proof.
-  intros n m; rewrite Zplus_0_r; intro; assumption.
+ destruct n, m, p; simpl; trivial; f_equal; apply Pos.mul_assoc.
 Qed.
 
-Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q.
+(** Multiplication and constants *)
+
+Lemma mul_1_l n : 1 * n = n.
 Proof.
-  intros; rewrite H; rewrite H0; reflexivity.
+ now destruct n.
 Qed.
 
-Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m).
+Lemma mul_1_r n : n * 1 = n.
 Proof.
-  intros x y z.
-  rewrite <- (Zplus_assoc x).
-  rewrite (Zplus_assoc (- z)).
-  rewrite Zplus_opp_l.
-  reflexivity.
+ destruct n; simpl; now rewrite ?Pos.mul_1_r.
 Qed.
 
-(************************************************************************)
-(** * Properties of successor and predecessor on binary integer numbers *)
+(** ** Multiplication and Opposite *)
 
-Theorem Zsucc_discr : forall n:Z, n <> Zsucc n.
+Lemma mul_opp_l n m : - n * m = - (n * m).
 Proof.
-  intros n; cut (Z0 <> Zpos 1);
-    [ unfold not in |- *; intros H1 H2; apply H1; apply (Zplus_reg_l n);
-      rewrite Zplus_0_r; exact H2
-      | discriminate ].
+ now destruct n, m.
 Qed.
 
-Theorem Zpos_succ_morphism :
-  forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
+Lemma mul_opp_r n m : n * - m = - (n * m).
 Proof.
-  intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *;
-    trivial with arith.
+ now destruct n, m.
 Qed.
 
-(** ** Successor and predecessor are inverse functions *)
+Lemma mul_opp_opp n m : - n * - m = n * m.
+Proof.
+ now destruct n, m.
+Qed.
 
-Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n).
+Lemma mul_opp_comm n m : - n * m = n * - m.
 Proof.
-  intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *;
-    rewrite Zplus_0_r; trivial with arith.
+ now destruct n, m.
 Qed.
 
-Hint Immediate Zsucc_pred: zarith.
+(** ** Distributivity of multiplication over addition *)
+
+Lemma mul_add_distr_pos (p:positive) n m :
+ Zpos p * (n + m) = Zpos p * n + Zpos p * m.
+Proof.
+ destruct n as [|n|n], m as [|m|m]; simpl; trivial;
+ rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_l; try case Pos.compare_spec;
+ intros; now rewrite ?Pos.mul_add_distr_l, ?Pos.mul_sub_distr_l.
+Qed.
 
-Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n).
+Lemma mul_add_distr_l n m p : n * (m + p) = n * m + n * p.
 Proof.
-  intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *;
-    rewrite Zplus_comm; auto with arith.
+ destruct n as [|n|n]. trivial.
+ apply mul_add_distr_pos.
+ rewrite <- opp_Zpos, !mul_opp_l, <- opp_add_distr. f_equal.
+ apply mul_add_distr_pos.
 Qed.
 
-Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m.
+Lemma mul_add_distr_r n m p : (n + m) * p = n * p + m * p.
 Proof.
-  intros n m H.
-  change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m) in |- *;
-    do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1));
-      unfold Zsucc in H; rewrite H; trivial with arith.
+ rewrite !(mul_comm _ p). apply mul_add_distr_l.
 Qed.
 
-(*************************************************************************)
-(** ** Properties of the direct definition of successor and predecessor  *)
+End Private_BootStrap.
+
+(** * Proofs of specifications *)
+
+(** ** Specification of constants *)
 
-Theorem Zsucc_succ' : forall n:Z, Zsucc n = Zsucc' n.
+Lemma one_succ : 1 = succ 0.
 Proof.
-destruct n as [| p | p]; simpl.
 reflexivity.
-now rewrite Pplus_one_succ_r.
-now destruct p as [q | q |].
 Qed.
 
-Theorem Zpred_pred' : forall n:Z, Zpred n = Zpred' n.
+Lemma two_succ : 2 = succ 1.
 Proof.
-destruct n as [| p | p]; simpl.
 reflexivity.
-now destruct p as [q | q |].
-now rewrite Pplus_one_succ_r.
 Qed.
 
-Theorem Zsucc'_inj : forall n m:Z, Zsucc' n = Zsucc' m -> n = m.
+(** ** Specification of addition *)
+
+Lemma add_0_l n : 0 + n = n.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma add_succ_l n m : succ n + m = succ (n + m).
 Proof.
-intros n m; do 2 rewrite <- Zsucc_succ'; now apply Zsucc_inj.
+ unfold succ. now rewrite 2 (add_comm _ 1), add_assoc.
 Qed.
 
-Theorem Zsucc'_pred' : forall n:Z, Zsucc' (Zpred' n) = n.
+(** ** Specification of opposite *)
+
+Lemma opp_0 : -0 = 0.
 Proof.
-intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred';
-symmetry; apply Zsucc_pred.
+ reflexivity.
 Qed.
 
-Theorem Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n.
+Lemma opp_succ n : -(succ n) = pred (-n).
 Proof.
-intro; apply Zsucc'_inj; now rewrite Zsucc'_pred'.
+ unfold succ, pred. apply opp_add_distr.
 Qed.
 
-Theorem Zpred'_inj : forall n m:Z, Zpred' n = Zpred' m -> n = m.
+(** ** Specification of successor and predecessor *)
+
+Lemma succ_pred n : succ (pred n) = n.
 Proof.
-intros n m H.
-rewrite <- (Zsucc'_pred' n); rewrite <- (Zsucc'_pred' m); now rewrite H.
+ unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
 Qed.
 
-Theorem Zsucc'_discr : forall n:Z, n <> Zsucc' n.
+Lemma pred_succ n : pred (succ n) = n.
 Proof.
-  intro x; destruct x; simpl in |- *.
-  discriminate.
-  injection; apply Psucc_discr.
-  destruct p; simpl in |- *.
-    discriminate.
-    intro H; symmetry  in H; injection H; apply double_moins_un_xO_discr.
-    discriminate.
+ unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
 Qed.
 
-(** Misc properties, usually redundant or non natural *)
+(** ** Specification of subtraction *)
 
-Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m.
+Lemma sub_0_r n : n - 0 = n.
 Proof.
-  intros n m H; rewrite H; reflexivity.
+ apply add_0_r.
 Qed.
 
-Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m.
+Lemma sub_succ_r n m : n - succ m = pred (n - m).
 Proof.
-  unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
+ unfold sub, succ, pred. now rewrite opp_add_distr, add_assoc.
 Qed.
 
-(**********************************************************************)
-(** * Properties of subtraction on binary integer numbers *)
+(** ** Specification of multiplication *)
 
-(** ** [minus] and [Z0] *)
+Lemma mul_0_l n : 0 * n = 0.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma mul_succ_l n m : succ n * m = n * m + m.
+Proof.
+ unfold succ. now rewrite mul_add_distr_r, mul_1_l.
+Qed.
+
+(** ** Specification of comparisons and order *)
+
+Lemma eqb_eq n m : (n =? m) = true <-> n = m.
+Proof.
+ destruct n, m; simpl; try (now split).
+ rewrite inj_Zpos. apply Pos.eqb_eq.
+ rewrite inj_Zneg. apply Pos.eqb_eq.
+Qed.
+
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
+Proof.
+ unfold ltb, lt. destruct compare; easy'.
+Qed.
 
-Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
 Proof.
-  intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r;
-    trivial with arith.
+ unfold leb, le. destruct compare; easy'.
 Qed.
 
-Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0.
+Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
 Proof.
-  intro; symmetry  in |- *; apply Zminus_0_r.
+destruct n, m; simpl; rewrite ?CompOpp_iff, ?Pos.compare_eq_iff;
+ split; congruence.
 Qed.
 
-Lemma Zminus_diag : forall n:Z, n - n = Z0.
+Lemma compare_sub n m : (n ?= m) = (n - m ?= 0).
 Proof.
-  intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith.
+ destruct n as [|n|n], m as [|m|m]; simpl; trivial;
+ rewrite <- ? Pos.compare_antisym, ?pos_sub_spec;
+ case Pos.compare_spec; trivial.
 Qed.
 
-Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n.
+Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
 Proof.
-  intro; symmetry  in |- *; apply Zminus_diag.
+destruct n, m; simpl; trivial; now rewrite <- ?Pos.compare_antisym.
 Qed.
 
+Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
+Proof. reflexivity. Qed.
+
+Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
+Proof. reflexivity. Qed.
+
+(** Some more advanced properties of comparison and orders,
+    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)
 
-(** ** Relating [minus] with [plus] and [Zsucc] *)
+Include BoolOrderFacts.
 
-Lemma Zminus_plus_distr : forall n m p:Z, n - (m + p) = n - m - p.
+(** Remaining specification of [lt] and [le] *)
+
+Lemma lt_succ_r n m : n < succ m <-> n<=m.
 Proof.
-intros; unfold Zminus; rewrite Zopp_plus_distr; apply Zplus_assoc.
+ unfold lt, le. rewrite compare_sub, sub_succ_r.
+ rewrite (compare_sub n m).
+ destruct (n-m) as [|[ | | ]|]; easy'.
 Qed.
 
-Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m.
+(** ** Specification of minimum and maximum *)
+
+Lemma max_l n m : m<=n -> max n m = n.
 Proof.
-  intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m));
-    rewrite <- Zplus_assoc; apply Zplus_comm.
+ unfold le, max. rewrite (compare_antisym n m).
+ case compare; intuition.
 Qed.
 
-Lemma Zminus_succ_r : forall n m:Z, n - (Zsucc m) = Zpred (n - m).
+Lemma max_r n m :  n<=m -> max n m = m.
 Proof.
-intros; unfold Zsucc; now rewrite Zminus_plus_distr.
+ unfold le, max. case compare_spec; intuition.
 Qed.
 
-Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
+Lemma min_l n m : n<=m -> min n m = n.
 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;
-	trivial with arith.
+ unfold le, min. case compare_spec; intuition.
 Qed.
 
-Lemma Zminus_plus : forall n m:Z, n + m - n = m.
+Lemma min_r n m : m<=n -> min n m = m.
 Proof.
-  intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m);
-    rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
+ unfold le, min.
+ rewrite (compare_antisym n m). case compare_spec; intuition.
 Qed.
 
-Lemma Zplus_minus : forall n m:Z, n + (m - n) = m.
+(** ** Specification of absolute value *)
+
+Lemma abs_eq n : 0 <= n -> abs n = n.
 Proof.
-  unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
-    apply Zplus_0_r.
+ destruct n; trivial. now destruct 1.
 Qed.
 
-Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m.
+Lemma abs_neq n : n <= 0 -> abs n = - n.
 Proof.
-  intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr;
-    rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p);
-      rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith.
+ destruct n; trivial. now destruct 1.
 Qed.
 
-Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m).
+(** ** Specification of sign *)
+
+Lemma sgn_null n : n = 0 -> sgn n = 0.
 Proof.
-  intros; symmetry  in |- *; apply Zminus_plus_simpl_l.
+ intros. now subst.
 Qed.
 
-Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m.
+Lemma sgn_pos n : 0 < n -> sgn n = 1.
 Proof.
-  intros x y n.
-  unfold Zminus in |- *.
-  rewrite Zopp_plus_distr.
-  rewrite (Zplus_comm (- y) (- n)).
-  rewrite Zplus_assoc.
-  rewrite <- (Zplus_assoc x n (- n)).
-  rewrite (Zplus_opp_r n).
-  rewrite <- Zplus_0_r_reverse.
-  reflexivity.
+ now destruct n.
 Qed.
 
-Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt ->
-  Zpos (b-a) = Zpos b - Zpos a.
+Lemma sgn_neg n : n < 0 -> sgn n = -1.
 Proof.
-  intros.
-  simpl.
-  change Eq with (CompOpp Eq).
-  rewrite <- Pcompare_antisym.
-  rewrite H; simpl; auto.
+ now destruct n.
 Qed.
 
-(** ** Misc redundant properties *)
+(** ** Specification of power *)
 
-Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0.
+Lemma pow_0_r n : n^0 = 1.
 Proof.
-  intros x y H; rewrite H; symmetry  in |- *; apply Zminus_diag_reverse.
+ reflexivity.
 Qed.
 
-Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m.
+Lemma pow_succ_r n m : 0<=m -> n^(succ m) = n * n^m.
 Proof.
-  intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
+ destruct m as [|m|m]; (now destruct 1) || (intros _); simpl; trivial.
+ unfold pow_pos. now rewrite Pos.add_comm, Pos.iter_add.
 Qed.
 
+Lemma pow_neg_r n m : m<0 -> n^m = 0.
+Proof.
+ now destruct m.
+Qed.
 
-(**********************************************************************)
-(** * Properties of multiplication on binary integer numbers *)
+(** For folding back a [pow_pos] into a [pow] *)
 
-Theorem Zpos_mult_morphism :
-  forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
+Lemma pow_pos_fold n p : pow_pos n p = n ^ (Zpos p).
 Proof.
-  auto.
+ reflexivity.
 Qed.
 
-(** ** One is neutral for multiplication *)
+(** ** Specification of square *)
 
-Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
+Lemma square_spec n : square n = n * n.
 Proof.
-  intro x; destruct x; reflexivity.
+ destruct n; trivial; simpl; f_equal; apply Pos.square_spec.
 Qed.
 
-Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n.
+(** ** Specification of square root *)
+
+Lemma sqrtrem_spec n : 0<=n ->
+ let (s,r) := sqrtrem n in n = s*s + r /\ 0 <= r <= 2*s.
 Proof.
-  intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity.
+ destruct n. now repeat split.
+ generalize (Pos.sqrtrem_spec p). simpl.
+ destruct 1; simpl; subst; now repeat split.
+ now destruct 1.
 Qed.
 
-(** ** Zero property of multiplication *)
+Lemma sqrt_spec n : 0<=n ->
+ let s := sqrt n in s*s <= n < (succ s)*(succ s).
+Proof.
+ destruct n. now repeat split. unfold sqrt.
+ rewrite succ_Zpos. intros _. apply (Pos.sqrt_spec p).
+ now destruct 1.
+Qed.
 
-Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
+Lemma sqrt_neg n : n<0 -> sqrt n = 0.
 Proof.
-  intro x; destruct x; reflexivity.
+ now destruct n.
 Qed.
 
-Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
+Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n.
 Proof.
-  intro x; destruct x; reflexivity.
+ destruct n; try reflexivity.
+ unfold sqrtrem, sqrt, Pos.sqrt.
+ destruct (Pos.sqrtrem p) as (s,r). now destruct r.
 Qed.
 
-Hint Local Resolve Zmult_0_l Zmult_0_r.
+(** ** Specification of logarithm *)
 
-Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0.
+Lemma log2_spec n : 0 < n -> 2^(log2 n) <= n < 2^(succ (log2 n)).
 Proof.
-  intro x; destruct x; reflexivity.
+ destruct n as [|[p|p|]|]; intros Hn; split; try easy; unfold log2;
+  rewrite ?succ_Zpos, pow_Zpos.
+ change (2^Pos.size p <= Pos.succ (p~0))%positive.
+ apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le.
+ apply Pos.size_gt.
+ apply Pos.size_le.
+ apply Pos.size_gt.
 Qed.
 
-(** ** Commutativity of multiplication *)
+Lemma log2_nonpos n : n<=0 -> log2 n = 0.
+Proof.
+ destruct n as [|p|p]; trivial; now destruct 1.
+Qed.
+
+(** Specification of parity functions *)
 
-Theorem Zmult_comm : forall n m:Z, n * m = m * n.
+Lemma even_spec n : even n = true <-> Even n.
 Proof.
-  intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *;
-    try rewrite (Pmult_comm p q); reflexivity.
+ split.
+ exists (div2 n). now destruct n as [|[ | | ]|[ | | ]].
+ intros (m,->). now destruct m.
 Qed.
 
-(** ** Associativity of multiplication *)
+Lemma odd_spec n : odd n = true <-> Odd n.
+Proof.
+ split.
+ exists (div2 n). destruct n as [|[ | | ]|[ | | ]]; simpl; try easy.
+ now rewrite Pos.pred_double_succ.
+ intros (m,->). now destruct m as [|[ | | ]|[ | | ]].
+Qed.
+
+(** ** Multiplication and Doubling *)
+
+Lemma double_spec n : double n = 2*n.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma succ_double_spec n : succ_double n = 2*n + 1.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma pred_double_spec n : pred_double n = 2*n - 1.
+Proof.
+ now destruct n.
+Qed.
+
+(** ** Correctness proofs for Trunc division *)
+
+Lemma pos_div_eucl_eq a b : 0 < b ->
+  let (q, r) := pos_div_eucl a b in Zpos a = q * b + r.
+Proof.
+ intros Hb.
+ induction a; unfold pos_div_eucl; fold pos_div_eucl.
+ - (* ~1 *)
+   destruct pos_div_eucl as (q,r).
+   rewrite pos_xI, IHa, mul_add_distr_l, mul_assoc.
+   destruct ltb.
+   now rewrite add_assoc.
+   rewrite mul_add_distr_r, mul_1_l, <- !add_assoc. f_equal.
+   unfold sub. now rewrite (add_comm _ (-b)), add_assoc, add_opp_diag_r.
+ - (* ~0 *)
+   destruct pos_div_eucl as (q,r).
+   rewrite (pos_xO a), IHa, mul_add_distr_l, mul_assoc.
+   destruct ltb.
+   trivial.
+   rewrite mul_add_distr_r, mul_1_l, <- !add_assoc. f_equal.
+   unfold sub. now rewrite (add_comm _ (-b)), add_assoc, add_opp_diag_r.
+ - (* 1 *)
+   case leb_spec; trivial.
+   intros Hb'.
+   destruct b as [|b|b]; try easy; clear Hb.
+   replace b with 1%positive; trivial.
+   apply Pos.le_antisym. apply Pos.le_1_l. now apply Pos.lt_succ_r.
+Qed.
+
+Lemma div_eucl_eq a b : b<>0 ->
+ let (q, r) := div_eucl a b in a = b * q + r.
+Proof.
+ destruct a as [ |a|a], b as [ |b|b]; unfold div_eucl; trivial;
+  (now destruct 1) || intros _;
+  generalize (pos_div_eucl_eq a (Zpos b) (eq_refl _));
+  destruct pos_div_eucl as (q,r); rewrite <- ?opp_Zpos, mul_comm;
+  intros ->.
+ - (* Zpos Zpos *)
+   trivial.
+ - (* Zpos Zneg *)
+   destruct r as [ |r|r]; rewrite !mul_opp_opp; trivial;
+    rewrite mul_add_distr_l, mul_1_r, <- add_assoc; f_equal;
+   now rewrite add_assoc, add_opp_diag_r.
+ - (* Zneg Zpos *)
+   rewrite (opp_add_distr _ r), <- mul_opp_r.
+   destruct r as [ |r|r]; trivial;
+    rewrite opp_add_distr, mul_add_distr_l, <- add_assoc; f_equal;
+    unfold sub; now rewrite add_assoc, mul_opp_r, mul_1_r, add_opp_diag_l.
+ - (* Zneg Zneg *)
+   now rewrite opp_add_distr, <- mul_opp_l.
+Qed.
+
+Lemma div_mod a b : b<>0 -> a = b*(a/b) + (a mod b).
+Proof.
+ intros Hb. generalize (div_eucl_eq a b Hb).
+ unfold div, modulo. now destruct div_eucl.
+Qed.
+
+Lemma pos_div_eucl_bound a b : 0<b -> 0 <= snd (pos_div_eucl a b) < b.
+Proof.
+ assert (AUX : forall m p, m < Zpos (p~0) -> m - Zpos p < Zpos p).
+  intros m p. unfold lt.
+  rewrite (compare_sub m), (compare_sub _ (Zpos _)). unfold sub.
+  rewrite <- add_assoc. simpl opp; simpl (Zneg _ + _).
+  now rewrite Pos.add_diag.
+ intros Hb.
+ destruct b as [|b|b]; discriminate Hb || clear Hb.
+ induction a; unfold pos_div_eucl; fold pos_div_eucl.
+ (* ~1 *)
+ destruct pos_div_eucl as (q,r).
+ simpl in IHa; destruct IHa as (Hr,Hr').
+ case ltb_spec; intros H; unfold snd. split; trivial. now destruct r.
+ split. unfold le.
+  now rewrite compare_antisym, <- compare_sub, <- compare_antisym.
+ apply AUX. rewrite <- succ_double_spec.
+ destruct r; try easy. unfold lt in *; simpl in *.
+  now rewrite Pos.compare_xI_xO, Hr'.
+ (* ~0 *)
+ destruct pos_div_eucl as (q,r).
+ simpl in IHa; destruct IHa as (Hr,Hr').
+ case ltb_spec; intros H; unfold snd. split; trivial. now destruct r.
+ split. unfold le.
+  now rewrite compare_antisym, <- compare_sub, <- compare_antisym.
+ apply AUX. destruct r; try easy.
+ (* 1 *)
+ case leb_spec; intros H; simpl; split; try easy.
+ red; simpl. now apply Pos.le_succ_l.
+Qed.
 
-Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p.
+Lemma mod_pos_bound a b : 0 < b -> 0 <= a mod b < b.
 Proof.
-  intros x y z; destruct x; destruct y; destruct z; simpl in |- *;
-    try rewrite Pmult_assoc; reflexivity.
+ destruct b as [|b|b]; try easy; intros _.
+ destruct a as [|a|a]; unfold modulo, div_eucl.
+ now split.
+ now apply pos_div_eucl_bound.
+ generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)).
+ destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
+ destruct r as [|r|r]; (now destruct Hr) || clear Hr.
+ now split.
+ split. unfold le.
+  now rewrite compare_antisym, <- compare_sub, <- compare_antisym, Hr'.
+ unfold lt in *; simpl in *. rewrite pos_sub_gt by trivial.
+ simpl. now apply Pos.sub_decr.
 Qed.
 
-Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p).
+Definition mod_bound_pos a b (_:0<=a) := mod_pos_bound a b.
+
+Lemma mod_neg_bound a b : b < 0 -> b < a mod b <= 0.
 Proof.
-  intros n m p; rewrite Zmult_assoc; trivial with arith.
+ destruct b as [|b|b]; try easy; intros _.
+ destruct a as [|a|a]; unfold modulo, div_eucl.
+ now split.
+ generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)).
+ destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
+ destruct r as [|r|r]; (now destruct Hr) || clear Hr.
+ now split.
+ split.
+ unfold lt in *; simpl in *. rewrite pos_sub_lt by trivial.
+ rewrite <- Pos.compare_antisym. now apply Pos.sub_decr.
+ change (Zneg b - Zneg r <= 0). unfold le, lt in *.
+  rewrite <- compare_sub. simpl in *.
+  now rewrite <- Pos.compare_antisym, Hr'.
+ generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)).
+ destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
+ split; destruct r; try easy.
+  red; simpl; now rewrite <- Pos.compare_antisym.
 Qed.
 
-(** ** Associativity mixed with commutativity *)
+(** ** Correctness proofs for Floor division *)
+
+Theorem quotrem_eq a b : let (q,r) := quotrem a b in a = q * b + r.
+Proof.
+ destruct a as [|a|a], b as [|b|b]; simpl; trivial;
+ generalize (N.pos_div_eucl_spec a (Npos b)); case N.pos_div_eucl; trivial;
+  intros q r; rewrite <- ?opp_Zpos;
+  change (Zpos a) with (of_N (Npos a)); intros ->; now destruct q, r.
+Qed.
 
-Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p).
+Lemma quot_rem' a b : a = b*(a÷b) + rem a b.
 Proof.
-  intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
-  apply Zmult_assoc.
+ rewrite mul_comm. generalize (quotrem_eq a b).
+ unfold quot, rem. now destruct quotrem.
 Qed.
 
-(** ** Z is integral *)
+Lemma quot_rem a b : b<>0 -> a = b*(a÷b) + rem a b.
+Proof. intros _. apply quot_rem'. Qed.
 
-Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0.
+Lemma rem_bound_pos a b : 0<=a -> 0<b -> 0 <= rem a b < b.
 Proof.
-  intros x y; destruct x as [| p| p].
-  intro H; absurd (Z0 = Z0); trivial.
-  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
-  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
+ intros Ha Hb.
+ destruct b as [|b|b]; (now discriminate Hb) || clear Hb;
+ destruct a as [|a|a]; (now destruct Ha) || clear Ha.
+ compute. now split.
+ unfold rem, quotrem.
+ assert (H := N.pos_div_eucl_remainder a (Npos b)).
+ destruct N.pos_div_eucl as (q,[|r]); simpl; split; try easy.
+ now apply H.
 Qed.
 
+Lemma rem_opp_l' a b : rem (-a) b = - (rem a b).
+Proof.
+ destruct a, b; trivial; unfold rem; simpl;
+  now destruct N.pos_div_eucl as (q,[|r]).
+Qed.
 
-Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0.
+Lemma rem_opp_r' a b : rem a (-b) = rem a b.
 Proof.
-  intros x y; destruct x; destruct y; auto; simpl in |- *; intro H;
-    discriminate H.
+ destruct a, b; trivial; unfold rem; simpl;
+  now destruct N.pos_div_eucl as (q,[|r]).
 Qed.
 
+Lemma rem_opp_l a b : b<>0 -> rem (-a) b = - (rem a b).
+Proof. intros _. apply rem_opp_l'. Qed.
 
-Lemma Zmult_1_inversion_l :
-  forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
+Lemma rem_opp_r a b : b<>0 -> rem a (-b) = rem a b.
+Proof. intros _. apply rem_opp_r'. Qed.
+
+(** ** Basic properties of divisibility *)
+
+Lemma divide_Zpos p q : (Zpos p|Zpos q) <-> (p|q)%positive.
 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);
-	reflexivity).
+ split.
+ intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto.
+ intros (r,H). exists (Zpos r); simpl; now f_equal.
 Qed.
 
-(** ** Multiplication and Doubling *)
+Lemma divide_Zpos_Zneg_r n p : (n|Zpos p) <-> (n|Zneg p).
+Proof.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H.
+Qed.
 
-Lemma Zdouble_mult : forall z, Zdouble z = (Zpos 2) * z.
+Lemma divide_Zpos_Zneg_l n p : (Zpos p|n) <-> (Zneg p|n).
 Proof.
-  reflexivity.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r.
 Qed.
 
-Lemma Zdouble_plus_one_mult : forall z,
-  Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1).
+(** ** Correctness proofs for gcd *)
+
+Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b.
 Proof.
-  destruct z; simpl; auto with zarith.
+ destruct a as [ |p|p], b as [ |q|q]; simpl; auto;
+  generalize (Pos.ggcd_gcd p q); destruct Pos.ggcd as (g,(aa,bb));
+  simpl; congruence.
 Qed.
 
-(** ** Multiplication and Opposite *)
+Lemma ggcd_correct_divisors a b :
+  let '(g,(aa,bb)) := ggcd a b in
+  a = g*aa /\ b = g*bb.
+Proof.
+ destruct a as [ |p|p], b as [ |q|q]; simpl; rewrite ?Pos.mul_1_r; auto;
+  generalize (Pos.ggcd_correct_divisors p q);
+  destruct Pos.ggcd as (g,(aa,bb)); simpl; destruct 1; now subst.
+Qed.
 
-Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m.
+Lemma gcd_divide_l a b : (gcd a b | a).
 Proof.
-  intros x y; destruct x; destruct y; reflexivity.
+ rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa.
+  now rewrite mul_comm.
 Qed.
 
-Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m.
+Lemma gcd_divide_r a b : (gcd a b | b).
 Proof.
-  intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
-    apply Zmult_comm.
+ rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
+ destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb.
+  now rewrite mul_comm.
 Qed.
 
-Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m).
+Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c | gcd a b).
 Proof.
-  intros x y; symmetry  in |- *; apply Zopp_mult_distr_l.
+ assert (H : forall p q r, (r|Zpos p) -> (r|Zpos q) -> (r|Zpos (Pos.gcd p q))).
+ { intros p q [|r|r] H H'.
+   destruct H; now rewrite mul_comm in *.
+   apply divide_Zpos, Pos.gcd_greatest; now apply divide_Zpos.
+   apply divide_Zpos_Zneg_l, divide_Zpos, Pos.gcd_greatest;
+    now apply divide_Zpos, divide_Zpos_Zneg_l.
+ }
+ destruct a, b; simpl; auto; intros; try apply H; trivial;
+  now apply divide_Zpos_Zneg_r.
 Qed.
 
-Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m.
+Lemma gcd_nonneg a b : 0 <= gcd a b.
 Proof.
-  intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
-    trivial with arith.
+ now destruct a, b.
 Qed.
 
-Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
+(** ggcd and opp : an auxiliary result used in QArith *)
+
+Theorem ggcd_opp a b :
+  ggcd (-a) b = (let '(g,(aa,bb)) := ggcd a b in (g,(-aa,bb))).
 Proof.
-  intros x y; destruct x; destruct y; reflexivity.
+ destruct a as [|a|a], b as [|b|b]; unfold ggcd, opp; auto;
+  destruct (Pos.ggcd a b) as (g,(aa,bb)); auto.
 Qed.
 
-Theorem Zopp_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1.
+(** ** Conversions between [Z.testbit] and [N.testbit] *)
+
+Lemma testbit_of_N a n :
+ testbit (of_N a) (of_N n) = N.testbit a n.
 Proof.
-  intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
+ destruct a as [|a], n; simpl; trivial. now destruct a.
 Qed.
 
-(** ** Distributivity of multiplication over addition *)
+Lemma testbit_of_N' a n : 0<=n ->
+ testbit (of_N a) n = N.testbit a (to_N n).
+Proof.
+ intro Hn. rewrite <- testbit_of_N. f_equal.
+ destruct n; trivial; now destruct Hn.
+Qed.
 
-Lemma weak_Zmult_plus_distr_r :
-  forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
+Lemma testbit_Zpos a n : 0<=n ->
+ testbit (Zpos a) n = N.testbit (Npos a) (to_N n).
 Proof.
-  intros x y' z'; case y'; case z'; auto with arith; intros y z;
-    (simpl in |- *; rewrite Pmult_plus_distr_l; trivial with arith) ||
-      (simpl in |- *; ElimPcompare z y; intros E0; rewrite E0;
-	[ rewrite (Pcompare_Eq_eq z y E0); rewrite (Pcompare_refl (x * y));
-          trivial with arith
-	  | cut ((x * z ?= x * y)%positive Eq = Lt);
-            [ 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);
-		  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);
-		  intros h H1; rewrite H1; apply mult_S_lt_compat_l;
-		    exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]).
+ intro Hn. now rewrite <- testbit_of_N'.
 Qed.
 
-Theorem Zmult_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p.
+Lemma testbit_Zneg a n : 0<=n ->
+ testbit (Zneg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)).
 Proof.
-  intros x y z; case x;
-    [ auto with arith
-      | intros x'; apply weak_Zmult_plus_distr_r
-      | intros p; apply Zopp_inj; rewrite Zopp_plus_distr;
-	do 3 rewrite <- Zopp_mult_distr_l_reverse; rewrite Zopp_neg;
-	  apply weak_Zmult_plus_distr_r ].
+ intro Hn.
+ rewrite <- testbit_of_N' by trivial.
+ destruct n as [ |n|n];
+  [ | simpl; now destruct (Ppred_N a) | now destruct Hn].
+ unfold testbit.
+ now destruct a as [|[ | | ]| ].
 Qed.
 
-Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p.
+(** ** Proofs of specifications for bitwise operations *)
+
+Lemma div2_spec a : div2 a = shiftr a 1.
 Proof.
-  intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
-    do 2 rewrite (Zmult_comm p); trivial with arith.
+ reflexivity.
 Qed.
 
-(** ** Distributivity of multiplication over subtraction *)
+Lemma testbit_0_l n : testbit 0 n = false.
+Proof.
+ now destruct n.
+Qed.
 
-Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p.
+Lemma testbit_neg_r a n : n<0 -> testbit a n = false.
 Proof.
-  intros x y z; unfold Zminus in |- *.
-  rewrite <- Zopp_mult_distr_l_reverse.
-  apply Zmult_plus_distr_l.
+ now destruct n.
 Qed.
 
+Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
+Proof.
+ now destruct a as [|a|[a|a|]].
+Qed.
 
-Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
+Lemma testbit_even_0 a : testbit (2*a) 0 = false.
 Proof.
-  intros x y z; rewrite (Zmult_comm z (x - y)).
-  rewrite (Zmult_comm z x).
-  rewrite (Zmult_comm z y).
-  apply Zmult_minus_distr_r.
+ now destruct a.
 Qed.
 
-(** ** Simplification of multiplication for non-zero integers *)
+Lemma testbit_odd_succ a n : 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a n.
+Proof.
+ destruct n as [|n|n]; (now destruct 1) || intros _.
+ destruct a as [|[a|a|]|[a|a|]]; simpl; trivial. now destruct a.
+ unfold testbit. rewrite succ_Zpos.
+ destruct a as [|a|[a|a|]]; simpl; trivial;
+  rewrite ?Pos.pred_N_succ; now destruct n.
+Qed.
 
-Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m.
+Lemma testbit_even_succ a n : 0<=n ->
+ testbit (2*a) (succ n) = testbit a n.
 Proof.
-  intros x y z H H0.
-  generalize (Zeq_minus _ _ H0).
-  intro.
-  apply Zminus_eq.
-  rewrite <- Zmult_minus_distr_l in H1.
-  clear H0; destruct (Zmult_integral _ _ H1).
-  contradiction.
-  trivial.
+ destruct n as [|n|n]; (now destruct 1) || intros _.
+ destruct a as [|[a|a|]|[a|a|]]; simpl; trivial. now destruct a.
+ unfold testbit. rewrite succ_Zpos.
+ destruct a as [|a|[a|a|]]; simpl; trivial;
+  rewrite ?Pos.pred_N_succ; now destruct n.
 Qed.
 
-Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m.
+(** Correctness proofs about [Z.shiftr] and [Z.shiftl] *)
+
+Lemma shiftr_spec_aux a n m : 0<=n -> 0<=m ->
+ testbit (shiftr a n) m = testbit a (m+n).
 Proof.
-  intros x y z Hz.
-  rewrite (Zmult_comm x z).
-  rewrite (Zmult_comm y z).
-  intro; apply Zmult_reg_l with z; assumption.
+ intros Hn Hm. unfold shiftr.
+ destruct n as [ |n|n]; (now destruct Hn) || clear Hn; simpl.
+ now rewrite add_0_r.
+ assert (forall p, to_N (m + Zpos p) = (to_N m + Npos p)%N).
+  destruct m; trivial; now destruct Hm.
+ assert (forall p, 0 <= m + Zpos p).
+  destruct m; easy || now destruct Hm.
+ destruct a as [ |a|a].
+ (* a = 0 *)
+ replace (Pos.iter n div2 0) with 0
+  by (apply Pos.iter_invariant; intros; subst; trivial).
+ now rewrite 2 testbit_0_l.
+ (* a > 0 *)
+ change (Zpos a) with (of_N (Npos a)) at 1.
+ rewrite <- (Pos.iter_swap_gen _ _ _ Ndiv2) by now intros [|[ | | ]].
+ rewrite testbit_Zpos, testbit_of_N', H; trivial.
+ exact (N.shiftr_spec' (Npos a) (Npos n) (to_N m)).
+ (* a < 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ Pdiv2_up) by trivial.
+ rewrite 2 testbit_Zneg, H; trivial. f_equal.
+ rewrite (Pos.iter_swap_gen _ _ _ _ Ndiv2) by exact N.pred_div2_up.
+ exact (N.shiftr_spec' (Ppred_N a) (Npos n) (to_N m)).
 Qed.
 
-(** ** Addition and multiplication by 2 *)
+Lemma shiftl_spec_low a n m : m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ intros H. destruct n as [|n|n], m as [|m|m]; try easy; simpl shiftl.
+ destruct (Pos.succ_pred_or n) as [-> | <-];
+  rewrite ?Pos.iter_succ; apply testbit_even_0.
+ destruct a as [ |a|a].
+ (* a = 0 *)
+ replace (Pos.iter n (mul 2) 0) with 0
+  by (apply Pos.iter_invariant; intros; subst; trivial).
+ apply testbit_0_l.
+ (* a > 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial.
+ rewrite testbit_Zpos by easy.
+ exact (N.shiftl_spec_low (Npos a) (Npos n) (Npos m) H).
+ (* a < 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial.
+ rewrite testbit_Zneg by easy.
+ now rewrite (N.pos_pred_shiftl_low a (Npos n)).
+Qed.
+
+Lemma shiftl_spec_high a n m : 0<=m -> n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ intros Hm H.
+ destruct n as [ |n|n]. simpl. now rewrite sub_0_r.
+ (* n > 0 *)
+ destruct m as [ |m|m]; try (now destruct H).
+ assert (0 <= Zpos m - Zpos n).
+  red. now rewrite compare_antisym, <- compare_sub, <- compare_antisym.
+ assert (EQ : to_N (Zpos m - Zpos n) = (Npos m - Npos n)%N).
+  red in H. simpl in H. simpl to_N.
+  rewrite pos_sub_spec, Pos.compare_antisym.
+  destruct (Pos.compare_spec n m) as [H'|H'|H']; try (now destruct H).
+  subst. now rewrite N.sub_diag.
+  simpl. destruct (Pos.sub_mask_pos' m n H') as (p & -> & <-).
+  f_equal. now rewrite Pos.add_comm, Pos.add_sub.
+ destruct a; unfold shiftl.
+ (* ... a = 0 *)
+ replace (Pos.iter n (mul 2) 0) with 0
+  by (apply Pos.iter_invariant; intros; subst; trivial).
+ now rewrite 2 testbit_0_l.
+ (* ... a > 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial.
+ rewrite 2 testbit_Zpos, EQ by easy.
+ exact (N.shiftl_spec_high' (Npos p) (Npos n) (Npos m) H).
+ (* ... a < 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial.
+ rewrite 2 testbit_Zneg, EQ by easy. f_equal.
+ simpl to_N.
+ rewrite <- N.shiftl_spec_high by easy.
+ now apply (N.pos_pred_shiftl_high p (Npos n)).
+ (* n < 0 *)
+ unfold sub. simpl.
+ now apply (shiftr_spec_aux a (Zpos n) m).
+Qed.
+
+Lemma shiftr_spec a n m : 0<=m ->
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ intros Hm.
+ destruct (leb_spec 0 n).
+ now apply shiftr_spec_aux.
+ destruct (leb_spec (-n) m) as [LE|GT].
+ unfold shiftr.
+ rewrite (shiftl_spec_high a (-n) m); trivial. now destruct n.
+ unfold shiftr.
+ rewrite (shiftl_spec_low a (-n) m); trivial.
+ rewrite testbit_neg_r; trivial.
+ red in GT. rewrite compare_sub in GT. now destruct n.
+Qed.
+
+(** Correctness proofs for bitwise operations *)
+
+Lemma lor_spec a b n :
+ testbit (lor a b) n = testbit a n || testbit b n.
+Proof.
+ destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r].
+ destruct a as [ |a|a], b as [ |b|b];
+  rewrite ?testbit_0_l, ?orb_false_r; trivial; unfold lor;
+  rewrite ?testbit_Zpos, ?testbit_Zneg, ?N.pos_pred_succ by trivial.
+ now rewrite <- N.lor_spec.
+ now rewrite N.ldiff_spec, negb_andb, negb_involutive, orb_comm.
+ now rewrite N.ldiff_spec, negb_andb, negb_involutive.
+ now rewrite N.land_spec, negb_andb.
+Qed.
+
+Lemma land_spec a b n :
+ testbit (land a b) n = testbit a n && testbit b n.
+Proof.
+ destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r].
+ destruct a as [ |a|a], b as [ |b|b];
+  rewrite ?testbit_0_l, ?andb_false_r; trivial; unfold land;
+  rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ
+   by trivial.
+ now rewrite <- N.land_spec.
+ now rewrite N.ldiff_spec.
+ now rewrite N.ldiff_spec, andb_comm.
+ now rewrite N.lor_spec, negb_orb.
+Qed.
+
+Lemma ldiff_spec a b n :
+ testbit (ldiff a b) n = testbit a n && negb (testbit b n).
+Proof.
+ destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r].
+ destruct a as [ |a|a], b as [ |b|b];
+  rewrite ?testbit_0_l, ?andb_true_r; trivial; unfold ldiff;
+  rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ
+   by trivial.
+ now rewrite <- N.ldiff_spec.
+ now rewrite N.land_spec, negb_involutive.
+ now rewrite N.lor_spec, negb_orb.
+ now rewrite N.ldiff_spec, negb_involutive, andb_comm.
+Qed.
+
+Lemma lxor_spec a b n :
+ testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
+Proof.
+ destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r].
+ destruct a as [ |a|a], b as [ |b|b];
+  rewrite ?testbit_0_l, ?xorb_false_l, ?xorb_false_r; trivial; unfold lxor;
+  rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ
+   by trivial.
+ now rewrite <- N.lxor_spec.
+ now rewrite N.lxor_spec, negb_xorb_r.
+ now rewrite N.lxor_spec, negb_xorb_l.
+ now rewrite N.lxor_spec, xorb_negb_negb.
+Qed.
+
+(** ** Induction principles based on successor / predecessor *)
+
+Lemma peano_ind (P : Z -> Prop) :
+  P 0 ->
+  (forall x, P x -> P (succ x)) ->
+  (forall x, P x -> P (pred x)) ->
+  forall z, P z.
+Proof.
+ intros H0 Hs Hp z; destruct z.
+ assumption.
+ induction p using Pos.peano_ind.
+  now apply (Hs 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hs (Zpos p)).
+ induction p using Pos.peano_ind.
+  now apply (Hp 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hp (Zneg p)).
+Qed.
+
+Lemma bi_induction (P : Z -> Prop) :
+  Proper (eq ==> iff) P ->
+  P 0 ->
+  (forall x, P x <-> P (succ x)) ->
+  forall z, P z.
+Proof.
+ intros _ H0 Hs. induction z using peano_ind.
+ assumption.
+ now apply -> Hs.
+ apply Hs. now rewrite succ_pred.
+Qed.
+
+
+(** * Proofs of morphisms, obvious since eq is Leibniz *)
+
+Local Obligation Tactic := simpl_relation.
+Program Definition succ_wd : Proper (eq==>eq) succ := _.
+Program Definition pred_wd : Proper (eq==>eq) pred := _.
+Program Definition opp_wd : Proper (eq==>eq) opp := _.
+Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
+Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
+Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
+Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
+Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
+Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
+Program Definition quot_wd : Proper (eq==>eq==>eq) quot := _.
+Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _.
+Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
+Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
+
+Include ZProp
+ <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+(** Otherwise Z stays associated with abstract_scope : (TODO FIX) *)
+Bind Scope Z_scope with Z.
+
+(** In generic statements, the predicates [lt] and [le] have been
+  favored, whereas [gt] and [ge] don't even exist in the abstract
+  layers. The use of [gt] and [ge] is hence not recommended. We provide
+  here the bare minimal results to related them with [lt] and [le]. *)
 
-Lemma Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2.
+Lemma gt_lt_iff n m : n > m <-> m < n.
 Proof.
-  intros x; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; reflexivity.
+ unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
 Qed.
 
-(** ** Multiplication and successor *)
+Lemma gt_lt n m : n > m -> m < n.
+Proof.
+ apply gt_lt_iff.
+Qed.
 
-Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
+Lemma lt_gt n m : n < m -> m > n.
 Proof.
-  intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
-    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l;
-      trivial with arith.
+ apply gt_lt_iff.
 Qed.
 
-Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
+Lemma ge_le_iff n m : n >= m <-> m <= n.
 Proof.
-  intros; symmetry  in |- *; apply Zmult_succ_r.
+ unfold le, ge. now rewrite compare_antisym, CompOpp_iff.
 Qed.
 
-Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m.
+Lemma ge_le n m : n >= m -> m <= n.
 Proof.
-  intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
-    rewrite Zmult_1_l; trivial with arith.
+ apply ge_le_iff.
 Qed.
 
-Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
+Lemma le_ge n m : n <= m -> m >= n.
 Proof.
-  intros; symmetry  in |- *; apply Zmult_succ_l.
+ apply ge_le_iff.
 Qed.
 
+(** We provide a tactic converting from one style to the other. *)
 
+Ltac swap_greater := rewrite ?gt_lt_iff in *; rewrite ?ge_le_iff in *.
 
-(** ** Misc redundant properties *)
+(** Similarly, the boolean comparisons [ltb] and [leb] are favored
+  over their dual [gtb] and [geb]. We prove here the equivalence
+  and a few minimal results. *)
 
-Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0.
+Lemma gtb_ltb n m : (n >? m) = (m <? n).
 Proof.
-  intros x y H; rewrite H; auto with arith.
+ unfold gtb, ltb. rewrite compare_antisym. now case compare.
 Qed.
 
+Lemma geb_leb n m : (n >=? m) = (m <=? n).
+Proof.
+ unfold geb, leb. rewrite compare_antisym. now case compare.
+Qed.
 
+Lemma gtb_lt n m : (n >? m) = true <-> m < n.
+Proof.
+ rewrite gtb_ltb. apply ltb_lt.
+Qed.
 
-(**********************************************************************)
-(** * Relating binary positive numbers and binary integers *)
+Lemma geb_le n m : (n >=? m) = true <-> m <= n.
+Proof.
+ rewrite geb_leb. apply leb_le.
+Qed.
 
-Lemma Zpos_eq : forall p q:positive, p = q -> Zpos p = Zpos q.
+Lemma gtb_spec n m : BoolSpec (m<n) (n<=m) (n >? m).
 Proof.
-  intros; f_equal; auto.
+ rewrite gtb_ltb. apply ltb_spec.
 Qed.
 
-Lemma Zpos_eq_rev : forall p q:positive, Zpos p = Zpos q -> p = q.
+Lemma geb_spec n m : BoolSpec (m<=n) (n<m) (n >=? m).
 Proof.
-  inversion 1; auto.
+ rewrite geb_leb. apply leb_spec.
 Qed.
 
-Lemma Zpos_eq_iff : forall p q:positive, p = q <-> Zpos p = Zpos q.
+(** TODO : to add in Numbers ? *)
+
+Lemma add_reg_l n m p : n + m = n + p -> m = p.
 Proof.
-  split; [apply Zpos_eq|apply Zpos_eq_rev].
+ exact (proj1 (add_cancel_l m p n)).
 Qed.
 
-Lemma Zpos_xI : forall p:positive, Zpos p~1 = Zpos 2 * Zpos p + Zpos 1.
+Lemma mul_reg_l n m p : p <> 0 -> p * n = p * m -> n = m.
 Proof.
-  intro; apply refl_equal.
+ exact (fun Hp => proj1 (mul_cancel_l n m p Hp)).
 Qed.
 
-Lemma Zpos_xO : forall p:positive, Zpos p~0 = Zpos 2 * Zpos p.
+Lemma mul_reg_r n m p : p <> 0 -> n * p = m * p -> n = m.
 Proof.
-  intro; apply refl_equal.
+ exact (fun Hp => proj1 (mul_cancel_r n m p Hp)).
 Qed.
 
-Lemma Zneg_xI : forall p:positive, Zneg p~1 = Zpos 2 * Zneg p - Zpos 1.
+Lemma opp_eq_mul_m1 n : - n = n * -1.
 Proof.
-  intro; apply refl_equal.
+ rewrite mul_comm. now destruct n.
 Qed.
 
-Lemma Zneg_xO : forall p:positive, Zneg p~0 = Zpos 2 * Zneg p.
+Lemma add_diag n : n + n = 2 * n.
 Proof.
-  reflexivity.
+ change 2 with (1+1). now rewrite mul_add_distr_r, !mul_1_l.
 Qed.
 
-Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q.
+(** * Comparison and opposite *)
+
+Lemma compare_opp n m : (- n ?= - m) = (m ?= n).
 Proof.
-  intros p p'; destruct p;
-    [ destruct p' as [p0| p0| ]
-      | destruct p' as [p0| p0| ]
-      | destruct p' as [p| p| ] ]; reflexivity.
+ destruct n, m; simpl; trivial; intros; now rewrite <- Pos.compare_antisym.
 Qed.
 
-Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q.
+(** * Comparison and addition *)
+
+Lemma add_compare_mono_l n m p : (n + m ?= n + p) = (m ?= p).
 Proof.
-  intros p p'; destruct p;
-    [ destruct p' as [p0| p0| ]
-      | destruct p' as [p0| p0| ]
-      | destruct p' as [p| p| ] ]; reflexivity.
+ rewrite (compare_sub m p), compare_sub. f_equal.
+ unfold sub. rewrite opp_add_distr, (add_comm n m), add_assoc.
+ f_equal. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
 Qed.
 
-(**********************************************************************)
-(** * Order relations *)
+End Z.
+
+(** Export Notations *)
+
+Infix "+" := Z.add : Z_scope.
+Notation "- x" := (Z.opp x) : Z_scope.
+Infix "-" := Z.sub : Z_scope.
+Infix "*" := Z.mul : Z_scope.
+Infix "^" := Z.pow : Z_scope.
+Infix "/" := Z.div : Z_scope.
+Infix "mod" := Z.modulo (at level 40, no associativity) : Z_scope.
+Infix "÷" := Z.quot (at level 40, left associativity) : Z_scope.
+
+(* TODO : transition from Zdivide *)
+Notation "( x | y )" := (Z.divide x y) (at level 0).
 
-Definition Zlt (x y:Z) := (x ?= y) = Lt.
-Definition Zgt (x y:Z) := (x ?= y) = Gt.
-Definition Zle (x y:Z) := (x ?= y) <> Gt.
-Definition Zge (x y:Z) := (x ?= y) <> Lt.
-Definition Zne (x y:Z) := x <> y.
+Infix "?=" := Z.compare (at level 70, no associativity) : Z_scope.
 
-Infix "<=" := Zle : Z_scope.
-Infix "<" := Zlt : Z_scope.
-Infix ">=" := Zge : Z_scope.
-Infix ">" := Zgt : Z_scope.
+Infix "<=" := Z.le : Z_scope.
+Infix "<" := Z.lt : Z_scope.
+Infix ">=" := Z.ge : Z_scope.
+Infix ">" := Z.gt : Z_scope.
 
 Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope.
 Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope.
 Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
 Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.
 
-(**********************************************************************)
-(** * Absolute value on integers *)
-
-Definition Zabs_nat (x:Z) : nat :=
-  match x with
-    | Z0 => 0%nat
-    | Zpos p => nat_of_P p
-    | Zneg p => nat_of_P p
-  end.
-
-Definition Zabs (z:Z) : Z :=
-  match z with
-    | Z0 => Z0
-    | Zpos p => Zpos p
-    | Zneg p => Zpos p
-  end.
-
-(**********************************************************************)
-(** * From [nat] to [Z] *)
-
-Definition Z_of_nat (x:nat) :=
-  match x with
-    | O => Z0
-    | S y => Zpos (P_of_succ_nat y)
-  end.
-
-Require Import BinNat.
-
-Definition Zabs_N (z:Z) :=
-  match z with
-    | Z0 => 0%N
-    | Zpos p => Npos p
-    | Zneg p => Npos p
-  end.
-
-Definition Z_of_N (x:N) :=
-  match x with
-    | N0 => Z0
-    | Npos p => Zpos p
-  end.
+Infix "=?" := Z.eqb (at level 70, no associativity) : Z_scope.
+Infix "<=?" := Z.leb (at level 70, no associativity) : Z_scope.
+Infix "<?" := Z.ltb (at level 70, no associativity) : Z_scope.
+Infix ">=?" := Z.geb (at level 70, no associativity) : Z_scope.
+Infix ">?" := Z.gtb (at level 70, no associativity) : Z_scope.
+
+(** Compatibility Notations *)
+
+Notation Zdouble_plus_one := Z.succ_double (only parsing).
+Notation Zdouble_minus_one := Z.pred_double (only parsing).
+Notation Zdouble := Z.double (only parsing).
+Notation ZPminus := Z.pos_sub (only parsing).
+Notation Zsucc' := Z.succ (only parsing).
+Notation Zpred' := Z.pred (only parsing).
+Notation Zplus' := Z.add (only parsing).
+Notation Zplus := Z.add (only parsing). (* Slightly incompatible *)
+Notation Zopp := Z.opp (only parsing).
+Notation Zsucc := Z.succ (only parsing).
+Notation Zpred := Z.pred (only parsing).
+Notation Zminus := Z.sub (only parsing).
+Notation Zmult := Z.mul (only parsing).
+Notation Zcompare := Z.compare (only parsing).
+Notation Zsgn := Z.sgn (only parsing).
+Notation Zle := Z.le (only parsing).
+Notation Zge := Z.ge (only parsing).
+Notation Zlt := Z.lt (only parsing).
+Notation Zgt := Z.gt (only parsing).
+Notation Zmax := Z.max (only parsing).
+Notation Zmin := Z.min (only parsing).
+Notation Zabs := Z.abs (only parsing).
+Notation Zabs_nat := Z.abs_nat (only parsing).
+Notation Zabs_N := Z.abs_N (only parsing).
+Notation Z_of_nat := Z.of_nat (only parsing).
+Notation Z_of_N := Z.of_N (only parsing).
+
+Notation Zind := Z.peano_ind (only parsing).
+Notation Zopp_0 := Z.opp_0 (only parsing).
+Notation Zopp_neg := Z.opp_Zneg (only parsing).
+Notation Zopp_involutive := Z.opp_involutive (only parsing).
+Notation Zopp_inj := Z.opp_inj (only parsing).
+Notation Zplus_0_l := Z.add_0_l (only parsing).
+Notation Zplus_0_r := Z.add_0_r (only parsing).
+Notation Zplus_comm := Z.add_comm (only parsing).
+Notation Zopp_plus_distr := Z.opp_add_distr (only parsing).
+Notation Zopp_succ := Z.opp_succ (only parsing).
+Notation Zplus_opp_r := Z.add_opp_diag_r (only parsing).
+Notation Zplus_opp_l := Z.add_opp_diag_l (only parsing).
+Notation Zplus_assoc := Z.add_assoc (only parsing).
+Notation Zplus_permute := Z.add_shuffle3 (only parsing).
+Notation Zplus_reg_l := Z.add_reg_l (only parsing).
+Notation Zplus_succ_l := Z.add_succ_l (only parsing).
+Notation Zplus_succ_comm := Z.add_succ_comm (only parsing).
+Notation Zsucc_discr := Z.neq_succ_diag_r (only parsing).
+Notation Zsucc_inj := Z.succ_inj (only parsing).
+Notation Zsucc'_inj := Z.succ_inj (only parsing).
+Notation Zsucc'_pred' := Z.succ_pred (only parsing).
+Notation Zpred'_succ' := Z.pred_succ (only parsing).
+Notation Zpred'_inj := Z.pred_inj (only parsing).
+Notation Zsucc'_discr := Z.neq_succ_diag_r (only parsing).
+Notation Zminus_0_r := Z.sub_0_r (only parsing).
+Notation Zminus_diag := Z.sub_diag (only parsing).
+Notation Zminus_plus_distr := Z.sub_add_distr (only parsing).
+Notation Zminus_succ_r := Z.sub_succ_r (only parsing).
+Notation Zminus_plus := Z.add_simpl_l (only parsing).
+Notation Zmult_0_l := Z.mul_0_l (only parsing).
+Notation Zmult_0_r := Z.mul_0_r (only parsing).
+Notation Zmult_1_l := Z.mul_1_l (only parsing).
+Notation Zmult_1_r := Z.mul_1_r (only parsing).
+Notation Zmult_comm := Z.mul_comm (only parsing).
+Notation Zmult_assoc := Z.mul_assoc (only parsing).
+Notation Zmult_permute := Z.mul_shuffle3 (only parsing).
+Notation Zmult_1_inversion_l := Z.mul_eq_1 (only parsing).
+Notation Zdouble_mult := Z.double_spec (only parsing).
+Notation Zdouble_plus_one_mult := Z.succ_double_spec (only parsing).
+Notation Zopp_mult_distr_l_reverse := Z.mul_opp_l (only parsing).
+Notation Zmult_opp_opp := Z.mul_opp_opp (only parsing).
+Notation Zmult_opp_comm := Z.mul_opp_comm (only parsing).
+Notation Zopp_eq_mult_neg_1 := Z.opp_eq_mul_m1 (only parsing).
+Notation Zmult_plus_distr_r := Z.mul_add_distr_l (only parsing).
+Notation Zmult_plus_distr_l := Z.mul_add_distr_r (only parsing).
+Notation Zmult_minus_distr_r := Z.mul_sub_distr_r (only parsing).
+Notation Zmult_reg_l := Z.mul_reg_l (only parsing).
+Notation Zmult_reg_r := Z.mul_reg_r (only parsing).
+Notation Zmult_succ_l := Z.mul_succ_l (only parsing).
+Notation Zmult_succ_r := Z.mul_succ_r (only parsing).
+Notation Zpos_xI := Z.pos_xI (only parsing).
+Notation Zpos_xO := Z.pos_xO (only parsing).
+Notation Zneg_xI := Z.neg_xI (only parsing).
+Notation Zneg_xO := Z.neg_xO (only parsing).
+
+Notation Z := Z (only parsing).
+Notation Z_rect := Z_rect (only parsing).
+Notation Z_rec := Z_rec (only parsing).
+Notation Z_ind := Z_ind (only parsing).
+Notation Z0 := Z0 (only parsing).
+Notation Zpos := Zpos (only parsing).
+Notation Zneg := Zneg (only parsing).
+
+(** Compatibility lemmas. These could be notations,
+    but scope information would be lost.
+*)
+
+Notation SYM1 lem := (fun n => eq_sym (lem n)).
+Notation SYM2 lem := (fun n m => eq_sym (lem n m)).
+Notation SYM3 lem := (fun n m p => eq_sym (lem n m p)).
+
+Lemma Zplus_assoc_reverse : forall n m p, n+m+p = n+(m+p).
+Proof (SYM3 Z.add_assoc).
+Lemma Zplus_succ_r_reverse : forall n m, Z.succ (n+m) = n+Z.succ m.
+Proof (SYM2 Z.add_succ_r).
+Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing).
+Lemma Zplus_0_r_reverse : forall n, n = n + 0.
+Proof (SYM1 Z.add_0_r).
+Lemma Zplus_eq_compat : forall n m p q, n=m -> p=q -> n+p=m+q.
+Proof (f_equal2 Z.add).
+Lemma Zpos_succ_morphism : forall p, Zpos (Psucc p) = Zsucc (Zpos p).
+Proof (SYM1 Z.succ_Zpos).
+Lemma Zsucc_pred : forall n, n = Z.succ (Z.pred n).
+Proof (SYM1 Z.succ_pred).
+Lemma Zpred_succ : forall n, n = Z.pred (Z.succ n).
+Proof (SYM1 Z.pred_succ).
+Lemma Zsucc_eq_compat : forall n m, n = m -> Z.succ n = Z.succ m.
+Proof (f_equal Z.succ).
+Lemma Zminus_0_l_reverse : forall n, n = n - 0.
+Proof (SYM1 Z.sub_0_r).
+Lemma Zminus_diag_reverse : forall n, 0 = n-n.
+Proof (SYM1 Z.sub_diag).
+Lemma Zminus_succ_l : forall n m, Z.succ (n - m) = Z.succ n - m.
+Proof (SYM2 Z.sub_succ_l).
+Lemma Zplus_minus_eq : forall n m p, n = m + p -> p = n - m.
+Proof. intros. now apply Z.add_move_l. Qed.
+Lemma Zplus_minus : forall n m, n + (m - n) = m.
+Proof (fun n m => eq_trans (Z.add_comm n (m-n)) (Z.sub_add n m)).
+Lemma Zminus_plus_simpl_l : forall n m p, p + n - (p + m) = n - m.
+Proof (fun n m p => Z.add_add_simpl_l_l p n m).
+Lemma Zminus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
+Proof (SYM3 Zminus_plus_simpl_l).
+Lemma Zminus_plus_simpl_r : forall n m p, n + p - (m + p) = n - m.
+Proof (fun n m p => Z.add_add_simpl_r_r n p m).
+Lemma Zpos_minus_morphism : forall a b,
+ Pcompare a b Eq = Lt -> Zpos (b - a) = Zpos b - Zpos a.
+Proof. intros. now rewrite Z.sub_Zpos. Qed.
+Lemma Zeq_minus : forall n m, n = m -> n - m = 0.
+Proof (fun n m => proj2 (Z.sub_move_0_r n m)).
+Lemma Zminus_eq : forall n m, n - m = 0 -> n = m.
+Proof (fun n m => proj1 (Z.sub_move_0_r n m)).
+Lemma Zpos_mult_morphism : forall p q, Zpos (p * q) = Zpos p * Zpos q.
+Proof (SYM2 Z.mul_Zpos).
+Lemma Zmult_0_r_reverse : forall n, 0 = n * 0.
+Proof (SYM1 Z.mul_0_r).
+Lemma Zmult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
+Proof (SYM3 Z.mul_assoc).
+Lemma Zmult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0.
+Proof (fun n m => proj1 (Z.mul_eq_0 n m)).
+Lemma Zmult_integral_l : forall n m, n <> 0 -> m * n = 0 -> m = 0.
+Proof (fun n m H H' => Z.mul_eq_0_l m n H' H).
+Lemma Zopp_mult_distr_l : forall n m, - (n * m) = - n * m.
+Proof (SYM2 Z.mul_opp_l).
+Lemma Zopp_mult_distr_r : forall n m, - (n * m) = n * - m.
+Proof (SYM2 Z.mul_opp_r).
+Lemma Zmult_minus_distr_l : forall n m p, p * (n - m) = p * n - p * m.
+Proof (fun n m p => Z.mul_sub_distr_l p n m).
+Lemma Zmult_succ_r_reverse : forall n m, n * m + n = n * Zsucc m.
+Proof (SYM2 Z.mul_succ_r).
+Lemma Zmult_succ_l_reverse : forall n m, n * m + m = Zsucc n * m.
+Proof (SYM2 Z.mul_succ_l).
+Lemma Zpos_eq : forall p q, p = q -> Zpos p = Zpos q.
+Proof (fun p q => proj2 (Z.inj_Zpos p q)).
+Lemma Zpos_eq_rev : forall p q, Zpos p = Zpos q -> p = q.
+Proof (fun p q => proj1 (Z.inj_Zpos p q)).
+Lemma Zpos_eq_iff : forall p q, p = q <-> Zpos p = Zpos q.
+Proof (fun p q => iff_sym (Z.inj_Zpos p q)).
+Lemma Zpos_plus_distr : forall p q, Zpos (p + q) = Zpos p + Zpos q.
+Proof (SYM2 Z.add_Zpos).
+Lemma Zneg_plus_distr : forall p q, Zneg (p + q) = Zneg p + Zneg q.
+Proof (SYM2 Z.add_Zneg).
+
+Hint Immediate Zsucc_pred: zarith.
+
+(* Not kept :
+Zplus_0_simpl_l
+Zplus_0_simpl_l_reverse
+Zplus_opp_expand
+Zsucc_inj_contrapositive
+Zsucc_succ'
+Zpred_pred'
+*)
+
+(* No compat notation for :
+weak_assoc (now Z.add_assoc_pos)
+weak_Zmult_plus_distr_r (now Z.mul_add_distr_pos)
+*)
+
+(** Obsolete stuff *)
+
+Definition Zne (x y:Z) := x <> y. (* TODO : to remove someday ? *)
+
+Ltac elim_compare com1 com2 :=
+  case (Dcompare (com1 ?= com2)%Z);
+    [ idtac | let x := fresh "H" in
+      (intro x; case x; clear x) ].
+
+Lemma ZL0 : 2%nat = (1 + 1)%nat.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma Zplus_diag_eq_mult_2 n : n + n = n * 2.
+Proof.
+ rewrite Z.mul_comm. apply Z.add_diag.
+Qed.
+
+Lemma Z_eq_mult n m : m = 0 -> m * n = 0.
+Proof.
+ intros; now subst.
+Qed.
diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v
new file mode 100644
index 00000000..d96d20fb
--- /dev/null
+++ b/theories/ZArith/BinIntDef.v
@@ -0,0 +1,610 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export BinNums.
+Require Import BinPos BinNat.
+
+Local Open Scope Z_scope.
+
+(***********************************************************)
+(** * Binary Integers, Definitions of Operations *)
+(***********************************************************)
+
+(** Initial author: Pierre Crégut, CNET, Lannion, France *)
+
+Module Z.
+
+Definition t := Z.
+
+(** ** Constants *)
+
+Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
+
+(** ** Doubling and variants *)
+
+Definition double x :=
+  match x with
+    | 0 => 0
+    | Zpos p => Zpos p~0
+    | Zneg p => Zneg p~0
+  end.
+
+Definition succ_double x :=
+  match x with
+    | 0 => 1
+    | Zpos p => Zpos p~1
+    | Zneg p => Zneg (Pos.pred_double p)
+  end.
+
+Definition pred_double x :=
+  match x with
+    | 0 => -1
+    | Zneg p => Zneg p~1
+    | Zpos p => Zpos (Pos.pred_double p)
+  end.
+
+(** ** Subtraction of positive into Z *)
+
+Fixpoint pos_sub (x y:positive) {struct y} : Z :=
+  match x, y with
+    | p~1, q~1 => double (pos_sub p q)
+    | p~1, q~0 => succ_double (pos_sub p q)
+    | p~1, 1 => Zpos p~0
+    | p~0, q~1 => pred_double (pos_sub p q)
+    | p~0, q~0 => double (pos_sub p q)
+    | p~0, 1 => Zpos (Pos.pred_double p)
+    | 1, q~1 => Zneg q~0
+    | 1, q~0 => Zneg (Pos.pred_double q)
+    | 1, 1 => Z0
+  end%positive.
+
+(** ** Addition *)
+
+Definition add x y :=
+  match x, y with
+    | 0, y => y
+    | x, 0 => x
+    | Zpos x', Zpos y' => Zpos (x' + y')
+    | Zpos x', Zneg y' => pos_sub x' y'
+    | Zneg x', Zpos y' => pos_sub y' x'
+    | Zneg x', Zneg y' => Zneg (x' + y')
+  end.
+
+Infix "+" := add : Z_scope.
+
+(** ** Opposite *)
+
+Definition opp x :=
+  match x with
+    | 0 => 0
+    | Zpos x => Zneg x
+    | Zneg x => Zpos x
+  end.
+
+Notation "- x" := (opp x) : Z_scope.
+
+(** ** Successor *)
+
+Definition succ x := x + 1.
+
+(** ** Predecessor *)
+
+Definition pred x := x + -1.
+
+(** ** Subtraction *)
+
+Definition sub m n := m + -n.
+
+Infix "-" := sub : Z_scope.
+
+(** ** Multiplication *)
+
+Definition mul x y :=
+  match x, y with
+    | 0, _ => 0
+    | _, 0 => 0
+    | Zpos x', Zpos y' => Zpos (x' * y')
+    | Zpos x', Zneg y' => Zneg (x' * y')
+    | Zneg x', Zpos y' => Zneg (x' * y')
+    | Zneg x', Zneg y' => Zpos (x' * y')
+  end.
+
+Infix "*" := mul : Z_scope.
+
+(** ** Power function *)
+
+Definition pow_pos (z:Z) (n:positive) := Pos.iter n (mul z) 1.
+
+Definition pow x y :=
+  match y with
+    | Zpos p => pow_pos x p
+    | 0 => 1
+    | Zneg _ => 0
+  end.
+
+Infix "^" := pow : Z_scope.
+
+(** ** Square *)
+
+Definition square x :=
+  match x with
+    | 0 => 0
+    | Zpos p => Zpos (Pos.square p)
+    | Zneg p => Zpos (Pos.square p)
+  end.
+
+(** ** Comparison *)
+
+Definition compare x y :=
+  match x, y with
+    | 0, 0 => Eq
+    | 0, Zpos y' => Lt
+    | 0, Zneg y' => Gt
+    | Zpos x', 0 => Gt
+    | Zpos x', Zpos y' => (x' ?= y')%positive
+    | Zpos x', Zneg y' => Gt
+    | Zneg x', 0 => Lt
+    | Zneg x', Zpos y' => Lt
+    | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive)
+  end.
+
+Infix "?=" := compare (at level 70, no associativity) : Z_scope.
+
+(** ** Sign function *)
+
+Definition sgn z :=
+  match z with
+    | 0 => 0
+    | Zpos p => 1
+    | Zneg p => -1
+  end.
+
+(** Boolean equality and comparisons *)
+
+Definition leb x y :=
+  match x ?= y with
+    | Gt => false
+    | _ => true
+  end.
+
+Definition ltb x y :=
+  match x ?= y with
+    | Lt => true
+    | _ => false
+  end.
+
+(** Nota: [geb] and [gtb] are provided for compatibility,
+  but [leb] and [ltb] should rather be used instead, since
+  more results we be available on them. *)
+
+Definition geb x y :=
+  match x ?= y with
+    | Lt => false
+    | _ => true
+  end.
+
+Definition gtb x y :=
+  match x ?= y with
+    | Gt => true
+    | _ => false
+  end.
+
+(** Nota: this [eqb] is not convertible with the generated [Z_beq],
+    since the underlying [Pos.eqb] differs from [positive_beq]
+    (cf BinIntDef). *)
+
+Fixpoint eqb x y :=
+  match x, y with
+    | 0, 0 => true
+    | Zpos p, Zpos q => Pos.eqb p q
+    | Zneg p, Zneg q => Pos.eqb p q
+    | _, _ => false
+  end.
+
+Infix "=?" := eqb (at level 70, no associativity) : Z_scope.
+Infix "<=?" := leb (at level 70, no associativity) : Z_scope.
+Infix "<?" := ltb (at level 70, no associativity) : Z_scope.
+Infix ">=?" := geb (at level 70, no associativity) : Z_scope.
+Infix ">?" := gtb (at level 70, no associativity) : Z_scope.
+
+(** ** Minimum and maximum *)
+
+Definition max n m :=
+  match n ?= m with
+    | Eq | Gt => n
+    | Lt => m
+  end.
+
+Definition min n m :=
+  match n ?= m with
+    | Eq | Lt => n
+    | Gt => m
+  end.
+
+(** ** Absolute value *)
+
+Definition abs z :=
+  match z with
+    | 0 => 0
+    | Zpos p => Zpos p
+    | Zneg p => Zpos p
+  end.
+
+(** ** Conversions *)
+
+(** From [Z] to [nat] via absolute value *)
+
+Definition abs_nat (z:Z) : nat :=
+  match z with
+    | 0 => 0%nat
+    | Zpos p => Pos.to_nat p
+    | Zneg p => Pos.to_nat p
+  end.
+
+(** From [Z] to [N] via absolute value *)
+
+Definition abs_N (z:Z) : N :=
+  match z with
+    | Z0 => 0%N
+    | Zpos p => Npos p
+    | Zneg p => Npos p
+  end.
+
+(** From [Z] to [nat] by rounding negative numbers to 0 *)
+
+Definition to_nat (z:Z) : nat :=
+  match z with
+    | Zpos p => Pos.to_nat p
+    | _ => O
+  end.
+
+(** From [Z] to [N] by rounding negative numbers to 0 *)
+
+Definition to_N (z:Z) : N :=
+  match z with
+    | Zpos p => Npos p
+    | _ => 0%N
+  end.
+
+(** From [nat] to [Z] *)
+
+Definition of_nat (n:nat) : Z :=
+  match n with
+   | O => 0
+   | S n => Zpos (Pos.of_succ_nat n)
+  end.
+
+(** From [N] to [Z] *)
+
+Definition of_N (n:N) : Z :=
+  match n with
+    | N0 => 0
+    | Npos p => Zpos p
+  end.
+
+(** ** Iteration of a function
+
+    By convention, iterating a negative number of times is identity.
+*)
+
+Definition iter (n:Z) {A} (f:A -> A) (x:A) :=
+  match n with
+    | Zpos p => Pos.iter p f x
+    | _ => x
+  end.
+
+(** ** Euclidean divisions for binary integers *)
+
+(** Concerning the many possible variants of integer divisions,
+    see the headers of the generic files [ZDivFloor], [ZDivTrunc],
+    [ZDivEucl], and the article by R. Boute mentioned there.
+    We provide here two flavours, Floor and Trunc, while
+    the Euclid convention can be found in file Zeuclid.v
+    For non-zero b, they all satisfy [a = b*(a/b) + (a mod b)]
+    and [ |a mod b| < |b| ], but the sign of the modulo will differ
+    when [a<0] and/or [b<0].
+*)
+
+(** ** Floor division *)
+
+(** [div_eucl] provides a Truncated-Toward-Bottom (a.k.a Floor)
+  Euclidean division. Its projections are named [div] (noted "/")
+  and [modulo] (noted with an infix "mod").
+  These functions correspond to the `div` and `mod` of Haskell.
+  This is the historical convention of Coq.
+
+  The main properties of this convention are :
+    - we have [sgn (a mod b) = sgn (b)]
+    - [div a b] is the greatest integer smaller or equal to the exact
+      fraction [a/b].
+    - there is no easy sign rule.
+
+  In addition, note that we arbitrary take [a/0 = 0] and [a mod 0 = 0].
+*)
+
+(** First, a division for positive numbers. Even if the second
+   argument is a Z, the answer is arbitrary is it isn't a Zpos. *)
+
+Fixpoint pos_div_eucl (a:positive) (b:Z) : Z * Z :=
+  match a with
+    | xH => if 2 <=? b then (0, 1) else (1, 0)
+    | xO a' =>
+      let (q, r) := pos_div_eucl a' b in
+      let r' := 2 * r in
+      if r' <? b then (2 * q, r') else (2 * q + 1, r' - b)
+    | xI a' =>
+      let (q, r) := pos_div_eucl a' b in
+      let r' := 2 * r + 1 in
+      if r' <? b then (2 * q, r') else (2 * q + 1, r' - b)
+  end.
+
+(** Then the general euclidean division *)
+
+Definition div_eucl (a b:Z) : Z * Z :=
+  match a, b with
+    | 0, _ => (0, 0)
+    | _, 0 => (0, 0)
+    | Zpos a', Zpos _ => pos_div_eucl a' b
+    | Zneg a', Zpos _ =>
+      let (q, r) := pos_div_eucl a' b in
+	match r with
+	  | 0 => (- q, 0)
+	  | _ => (- (q + 1), b - r)
+	end
+    | Zneg a', Zneg b' =>
+      let (q, r) := pos_div_eucl a' (Zpos b') in (q, - r)
+    | Zpos a', Zneg b' =>
+      let (q, r) := pos_div_eucl a' (Zpos b') in
+	match r with
+	  | 0 => (- q, 0)
+	  | _ => (- (q + 1), b + r)
+	end
+  end.
+
+Definition div (a b:Z) : Z := let (q, _) := div_eucl a b in q.
+Definition modulo (a b:Z) : Z := let (_, r) := div_eucl a b in r.
+
+Infix "/" := div : Z_scope.
+Infix "mod" := modulo (at level 40, no associativity) : Z_scope.
+
+
+(** ** Trunc Division *)
+
+(** [quotrem] provides a Truncated-Toward-Zero Euclidean division.
+  Its projections are named [quot] (noted "÷") and [rem].
+  These functions correspond to the `quot` and `rem` of Haskell.
+  This division convention is used in most programming languages,
+  e.g. Ocaml.
+
+  With this convention:
+   - we have [sgn(a rem b) = sgn(a)]
+   - sign rule for division: [quot (-a) b = quot a (-b) = -(quot a b)]
+   - and for modulo: [a rem (-b) = a rem b] and [(-a) rem b = -(a rem b)]
+
+ Note that we arbitrary take here [quot a 0 = 0] and [a rem 0 = a].
+*)
+
+Definition quotrem (a b:Z) : Z * Z :=
+  match a, b with
+   | 0,  _ => (0, 0)
+   | _, 0  => (0, a)
+   | Zpos a, Zpos b =>
+     let (q, r) := N.pos_div_eucl a (Npos b) in (of_N q, of_N r)
+   | Zneg a, Zpos b =>
+     let (q, r) := N.pos_div_eucl a (Npos b) in (-of_N q, - of_N r)
+   | Zpos a, Zneg b =>
+     let (q, r) := N.pos_div_eucl a (Npos b) in (-of_N q, of_N r)
+   | Zneg a, Zneg b =>
+     let (q, r) := N.pos_div_eucl a (Npos b) in (of_N q, - of_N r)
+  end.
+
+Definition quot a b := fst (quotrem a b).
+Definition rem a b := snd (quotrem a b).
+
+Infix "÷" := quot (at level 40, left associativity) : Z_scope.
+(** No infix notation for rem, otherwise it becomes a keyword *)
+
+
+(** ** Parity functions *)
+
+Definition even z :=
+  match z with
+    | 0 => true
+    | Zpos (xO _) => true
+    | Zneg (xO _) => true
+    | _ => false
+  end.
+
+Definition odd z :=
+  match z with
+    | 0 => false
+    | Zpos (xO _) => false
+    | Zneg (xO _) => false
+    | _ => true
+  end.
+
+
+(** ** Division by two *)
+
+(** [div2] performs rounding toward bottom, it is hence a particular
+   case of [div], and for all relative number [n] we have:
+   [n = 2 * div2 n + if odd n then 1 else 0].  *)
+
+Definition div2 z :=
+ match z with
+   | 0 => 0
+   | Zpos 1 => 0
+   | Zpos p => Zpos (Pos.div2 p)
+   | Zneg p => Zneg (Pos.div2_up p)
+ end.
+
+(** [quot2] performs rounding toward zero, it is hence a particular
+   case of [quot], and for all relative number [n] we have:
+   [n = 2 * quot2 n + if odd n then sgn n else 0].  *)
+
+Definition quot2 (z:Z) :=
+  match z with
+    | 0 => 0
+    | Zpos 1 => 0
+    | Zpos p => Zpos (Pos.div2 p)
+    | Zneg 1 => 0
+    | Zneg p => Zneg (Pos.div2 p)
+  end.
+
+(** NB: [Z.quot2] used to be named [Zdiv2] in Coq <= 8.3 *)
+
+
+(** * Base-2 logarithm *)
+
+Definition log2 z :=
+  match z with
+    | Zpos (p~1) => Zpos (Pos.size p)
+    | Zpos (p~0) => Zpos (Pos.size p)
+    | _ => 0
+  end.
+
+
+(** ** Square root *)
+
+Definition sqrtrem n :=
+ match n with
+  | 0 => (0, 0)
+  | Zpos p =>
+    match Pos.sqrtrem p with
+     | (s, IsPos r) => (Zpos s, Zpos r)
+     | (s, _) => (Zpos s, 0)
+    end
+  | Zneg _ => (0,0)
+ end.
+
+Definition sqrt n :=
+ match n with
+  | Zpos p => Zpos (Pos.sqrt p)
+  | _ => 0
+ end.
+
+
+(** ** Greatest Common Divisor *)
+
+Definition gcd a b :=
+  match a,b with
+    | 0, _ => abs b
+    | _, 0 => abs a
+    | Zpos a, Zpos b => Zpos (Pos.gcd a b)
+    | Zpos a, Zneg b => Zpos (Pos.gcd a b)
+    | Zneg a, Zpos b => Zpos (Pos.gcd a b)
+    | Zneg a, Zneg b => Zpos (Pos.gcd a b)
+  end.
+
+(** A generalized gcd, also computing division of a and b by gcd. *)
+
+Definition ggcd a b : Z*(Z*Z) :=
+  match a,b with
+    | 0, _ => (abs b,(0, sgn b))
+    | _, 0 => (abs a,(sgn a, 0))
+    | Zpos a, Zpos b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zpos aa, Zpos bb))
+    | Zpos a, Zneg b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zpos aa, Zneg bb))
+    | Zneg a, Zpos b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zneg aa, Zpos bb))
+    | Zneg a, Zneg b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zneg aa, Zneg bb))
+  end.
+
+
+(** ** Bitwise functions *)
+
+(** When accessing the bits of negative numbers, all functions
+  below will use the two's complement representation. For instance,
+  [-1] will correspond to an infinite stream of true bits. If this
+  isn't what you're looking for, you can use [abs] first and then
+  access the bits of the absolute value.
+*)
+
+(** [testbit] : accessing the [n]-th bit of a number [a].
+    For negative [n], we arbitrarily answer [false]. *)
+
+Definition testbit a n :=
+ match n with
+   | 0 => odd a
+   | Zpos p =>
+     match a with
+       | 0 => false
+       | Zpos a => Pos.testbit a (Npos p)
+       | Zneg a => negb (N.testbit (Pos.pred_N a) (Npos p))
+     end
+   | Zneg _ => false
+ end.
+
+(** Shifts
+
+   Nota: a shift to the right by [-n] will be a shift to the left
+   by [n], and vice-versa.
+
+   For fulfilling the two's complement convention, shifting to
+   the right a negative number should correspond to a division
+   by 2 with rounding toward bottom, hence the use of [div2]
+   instead of [quot2].
+*)
+
+Definition shiftl a n :=
+ match n with
+   | 0 => a
+   | Zpos p => Pos.iter p (mul 2) a
+   | Zneg p => Pos.iter p div2 a
+ end.
+
+Definition shiftr a n := shiftl a (-n).
+
+(** Bitwise operations [lor] [land] [ldiff] [lxor] *)
+
+Definition lor a b :=
+ match a, b with
+   | 0, _ => b
+   | _, 0 => a
+   | Zpos a, Zpos b => Zpos (Pos.lor a b)
+   | Zneg a, Zpos b => Zneg (N.succ_pos (N.ldiff (Pos.pred_N a) (Npos b)))
+   | Zpos a, Zneg b => Zneg (N.succ_pos (N.ldiff (Pos.pred_N b) (Npos a)))
+   | Zneg a, Zneg b => Zneg (N.succ_pos (N.land (Pos.pred_N a) (Pos.pred_N b)))
+ end.
+
+Definition land a b :=
+ match a, b with
+   | 0, _ => 0
+   | _, 0 => 0
+   | Zpos a, Zpos b => of_N (Pos.land a b)
+   | Zneg a, Zpos b => of_N (N.ldiff (Npos b) (Pos.pred_N a))
+   | Zpos a, Zneg b => of_N (N.ldiff (Npos a) (Pos.pred_N b))
+   | Zneg a, Zneg b => Zneg (N.succ_pos (N.lor (Pos.pred_N a) (Pos.pred_N b)))
+ end.
+
+Definition ldiff a b :=
+ match a, b with
+   | 0, _ => 0
+   | _, 0 => a
+   | Zpos a, Zpos b => of_N (Pos.ldiff a b)
+   | Zneg a, Zpos b => Zneg (N.succ_pos (N.lor (Pos.pred_N a) (Npos b)))
+   | Zpos a, Zneg b => of_N (N.land (Npos a) (Pos.pred_N b))
+   | Zneg a, Zneg b => of_N (N.ldiff (Pos.pred_N b) (Pos.pred_N a))
+ end.
+
+Definition lxor a b :=
+ match a, b with
+   | 0, _ => b
+   | _, 0 => a
+   | Zpos a, Zpos b => of_N (Pos.lxor a b)
+   | Zneg a, Zpos b => Zneg (N.succ_pos (N.lxor (Pos.pred_N a) (Npos b)))
+   | Zpos a, Zneg b => Zneg (N.succ_pos (N.lxor (Npos a) (Pos.pred_N b)))
+   | Zneg a, Zneg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b))
+ end.
+
+End Z.
\ No newline at end of file
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index c0123ca8..bac50fc4 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -6,8 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: Int.v 12363 2009-09-28 15:04:07Z letouzey $ *)
-
 (** * An light axiomatization of integers (used in FSetAVL). *)
 
 (** We define a signature for an integer datatype based on [Z].
@@ -29,7 +27,7 @@ Module Type Int.
   Parameter int : Set.
 
   Parameter i2z : int -> Z.
-  Arguments Scope i2z [ Int_scope ].
+  Arguments i2z _%I.
 
   Parameter _0 : int.
   Parameter _1 : int.
@@ -222,10 +220,10 @@ Module MoreInt (I:Int).
       | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey)
       | (~ ?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:(EPge 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:(EPge ex ey)
       | ?x =>  constr:(EPraw x)
     end.
 
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index 0fe6d623..bcccc126 100644
--- a/theories/ZArith/Wf_Z.v
+++ b/theories/ZArith/Wf_Z.v
@@ -1,123 +1,83 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_Z.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import BinInt.
 Require Import Zcompare.
 Require Import Zorder.
 Require Import Znat.
 Require Import Zmisc.
 Require Import Wf_nat.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (** Our purpose is to write an induction shema for {0,1,2,...}
   similar to the [nat] schema (Theorem [Natlike_rec]). For that the
   following implications will be used :
 <<
- (n:nat)(Q n)==(n:nat)(P (inject_nat n)) ===> (x:Z)`x > 0) -> (P x)
+ ∀n:nat, Q n == ∀n:nat, P (Z.of_nat n) ===> ∀x:Z, x <= 0 -> P x
 
        	     /\
              ||
              ||
 
-  (Q O) (n:nat)(Q n)->(Q (S n)) <=== (P 0) (x:Z) (P x) -> (P (Zs x))
+ (Q O) ∧ (∀n:nat, Q n -> Q (S n)) <=== (P 0) ∧ (∀x:Z, P x -> P (Z.succ x))
 
-      	       	       	       	<=== (inject_nat (S n))=(Zs (inject_nat n))
+				  <=== (Z.of_nat (S n) = Z.succ (Z.of_nat n))
 
-      	       	       	       	<=== inject_nat_complete
+				  <=== Z_of_nat_complete
 >>
   Then the  diagram will be closed and the theorem proved. *)
 
-Lemma Z_of_nat_complete :
-  forall x:Z, 0 <= x ->  exists n : nat, x = Z_of_nat n.
-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);
-	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
-	    apply nat_of_P_inj; auto with arith
-      | absurd (0 <= Zneg p);
-	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
-	  auto with arith
-	  | assumption ] ].
-Qed.
-
-Lemma ZL4_inf : forall y:positive, {h : nat | nat_of_P y = S h}.
+Lemma Z_of_nat_complete (x : Z) :
+ 0 <= x -> exists n : nat, x = Z.of_nat n.
 Proof.
-  intro y; induction y as [p H| p H1| ];
-    [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *;
-      simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
-	unfold nat_of_P in H1; rewrite H1; auto with arith
-      | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *;
-	simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
-	  unfold nat_of_P in H2; rewrite H2; auto with arith
-      | exists 0%nat; auto with arith ].
+ intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
 Qed.
 
-Lemma Z_of_nat_complete_inf :
- forall x:Z, 0 <= x -> {n : nat | x = Z_of_nat n}.
+Lemma Z_of_nat_complete_inf (x : Z) :
+ 0 <= x -> {n : nat | x = Z_of_nat n}.
 Proof.
-  intro x; destruct x; intros;
-    [ exists 0%nat; auto with arith
-      | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0);
-	intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0);
-	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
-	    apply nat_of_P_inj; auto with arith
-      | absurd (0 <= Zneg p);
-	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
-	  auto with arith
-	  | assumption ] ].
+ intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
 Qed.
 
 Lemma Z_of_nat_prop :
   forall P:Z -> Prop,
-    (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
+    (forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x.
 Proof.
-  intros P H x H0.
-  specialize (Z_of_nat_complete x H0).
-  intros Hn; elim Hn; intros.
-  rewrite H1; apply H.
+ intros P H x Hx. now destruct (Z_of_nat_complete x Hx) as (n,->).
 Qed.
 
 Lemma Z_of_nat_set :
  forall P:Z -> Set,
    (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
 Proof.
-  intros P H x H0.
-  specialize (Z_of_nat_complete_inf x H0).
-  intros Hn; elim Hn; intros.
-  rewrite p; apply H.
+ intros P H x Hx. now destruct (Z_of_nat_complete_inf x Hx) as (n,->).
 Qed.
 
 Lemma natlike_ind :
  forall P:Z -> Prop,
    P 0 ->
-   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
+   (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
+   forall x:Z, 0 <= x -> P x.
 Proof.
-  intros P H H0 x H1; apply Z_of_nat_prop;
-    [ simple induction n;
-      [ simpl in |- *; assumption
-	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
-      | assumption ].
+ intros P Ho Hrec x Hx; apply Z_of_nat_prop; trivial.
+ induction n. exact Ho.
+ rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
 Qed.
 
 Lemma natlike_rec :
  forall P:Z -> Set,
    P 0 ->
-   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
+   (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
+   forall x:Z, 0 <= x -> P x.
 Proof.
-  intros P H H0 x H1; apply Z_of_nat_set;
-    [ simple induction n;
-      [ simpl in |- *; assumption
-	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
-      | assumption ].
+ intros P Ho Hrec x Hx; apply Z_of_nat_set; trivial.
+ induction n. exact Ho.
+ rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
 Qed.
 
 Section Efficient_Rec.
@@ -129,58 +89,44 @@ Section Efficient_Rec.
 
   Let R_wf : well_founded R.
   Proof.
-    set
-      (f :=
-	fun z =>
-	  match z with
-	    | Zpos p => nat_of_P p
-	    | Z0 => 0%nat
-	    | Zneg _ => 0%nat
-	  end) in *.
-    apply well_founded_lt_compat with f.
-    unfold R, f in |- *; clear f R.
-    intros x y; case x; intros; elim H; clear H.
-    case y; intros; apply lt_O_nat_of_P || inversion H0.
-    case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto.
-    intros; elim H; auto.
+   apply well_founded_lt_compat with Z.to_nat.
+   intros x y (Hx,H). apply Z2Nat.inj_lt; Z.order.
   Qed.
 
   Lemma natlike_rec2 :
     forall P:Z -> Type,
       P 0 ->
-      (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z.
+      (forall z:Z, 0 <= z -> P z -> P (Z.succ z)) ->
+      forall z:Z, 0 <= z -> P z.
   Proof.
-    intros P Ho Hrec z; pattern z in |- *;
-      apply (well_founded_induction_type R_wf).
-    intro x; case x.
-    trivial.
-    intros.
-    assert (0 <= Zpred (Zpos p)).
-    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
-    rewrite Zsucc_pred.
-    apply Hrec.
-    auto.
-    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
-    intros; elim H; simpl in |- *; trivial.
+   intros P Ho Hrec.
+   induction z as [z IH] using (well_founded_induction_type R_wf).
+   destruct z; intros Hz.
+   - apply Ho.
+   - set (y:=Z.pred (Zpos p)).
+     assert (LE : 0 <= y) by (unfold y; now apply Z.lt_le_pred).
+     assert (EQ : Zpos p = Z.succ y) by (unfold y; now rewrite Z.succ_pred).
+     rewrite EQ. apply Hrec, IH; trivial.
+     split; trivial. unfold y; apply Z.lt_pred_l.
+   - now destruct Hz.
   Qed.
 
-  (** A variant of the previous using [Zpred] instead of [Zs]. *)
+  (** A variant of the previous using [Z.pred] instead of [Z.succ]. *)
 
   Lemma natlike_rec3 :
     forall P:Z -> Type,
       P 0 ->
-      (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z.
+      (forall z:Z, 0 < z -> P (Z.pred z) -> P z) ->
+      forall z:Z, 0 <= z -> P z.
   Proof.
-    intros P Ho Hrec z; pattern z in |- *;
-      apply (well_founded_induction_type R_wf).
-    intro x; case x.
-    trivial.
-    intros; apply Hrec.
-    unfold Zlt in |- *; trivial.
-    assert (0 <= Zpred (Zpos p)).
-    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
-    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
-    intros; elim H; simpl in |- *; trivial.
+   intros P Ho Hrec.
+   induction z as [z IH] using (well_founded_induction_type R_wf).
+   destruct z; intros Hz.
+   - apply Ho.
+   - assert (EQ : 0 <= Z.pred (Zpos p)) by now apply Z.lt_le_pred.
+     apply Hrec. easy. apply IH; trivial. split; trivial.
+     apply Z.lt_pred_l.
+   - now destruct Hz.
   Qed.
 
   (** A more general induction principle on non-negative numbers using [Zlt]. *)
@@ -190,15 +136,15 @@ Section Efficient_Rec.
       (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
       forall x:Z, 0 <= x -> P x.
   Proof.
-    intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf).
-    intro x; case x; intros.
-    apply Hrec; intros.
-    assert (H2 : 0 < 0).
-    apply Zle_lt_trans with y; intuition.
-    inversion H2.
-    assumption.
-    firstorder.
-    unfold Zle, Zcompare in H; elim H; auto.
+   intros P Hrec.
+   induction x as [x IH] using (well_founded_induction_type R_wf).
+   destruct x; intros Hx.
+   - apply Hrec; trivial. intros y (Hy,Hy').
+     assert (0 < 0) by now apply Z.le_lt_trans with y.
+     discriminate.
+   - apply Hrec; trivial. intros y (Hy,Hy').
+     apply IH; trivial. now split.
+   - now destruct Hx.
   Defined.
 
   Lemma Zlt_0_ind :
@@ -234,22 +180,15 @@ Section Efficient_Rec.
       (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
       forall x:Z, z <= x -> P x.
   Proof.
-    intros P z Hrec x.
-    assert (Hexpand : forall x, x = x - z + z).
-    intro; unfold Zminus; rewrite <- Zplus_assoc; rewrite Zplus_opp_l;
-      rewrite Zplus_0_r; trivial.
-    intro Hz.
-    rewrite (Hexpand x); pattern (x - z) in |- *; apply Zlt_0_rec.
-    2: apply Zplus_le_reg_r with z; rewrite <- Hexpand; assumption.
-    intros x0 Hlt_x0 H.
-    apply Hrec.
-    2: change z with (0+z); apply Zplus_le_compat_r; assumption.
-    intro y; rewrite (Hexpand y); intros.
-    destruct H0.
-    apply Hlt_x0.
-    split.
-    apply Zplus_le_reg_r with z; assumption.
-    apply Zplus_lt_reg_r with z; assumption.
+    intros P z Hrec x Hx.
+    rewrite <- (Z.sub_simpl_r x z). apply Z.le_0_sub in Hx.
+    pattern (x - z); apply Zlt_0_rec; trivial.
+    clear x Hx. intros x IH Hx.
+    apply Hrec. intros y (Hy,Hy').
+    rewrite <- (Z.sub_simpl_r y z). apply IH; split.
+    now rewrite Z.le_0_sub.
+    now apply Z.lt_sub_lt_add_r.
+    now rewrite <- (Z.add_le_mono_r 0 x z).
   Qed.
 
   Lemma Zlt_lower_bound_ind :
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
index bc79e373..265e62f0 100644
--- a/theories/ZArith/ZArith.v
+++ b/theories/ZArith/ZArith.v
@@ -1,21 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Library for manipulating integers based on binary encoding *)
 
 Require Export ZArith_base.
 
+(** Extra definitions *)
+
+Require Export Zpow_def.
+
 (** Extra modules using [Omega] or [Ring]. *)
 
 Require Export Zcomplements.
-Require Export Zsqrt.
 Require Export Zpower.
 Require Export Zdiv.
 Require Export Zlogarithm.
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
index 8cdae80d..8eeca3b9 100644
--- a/theories/ZArith/ZArith_base.v
+++ b/theories/ZArith/ZArith_base.v
@@ -1,17 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZArith_base.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (** Library for manipulating integers based on binary encoding.
     These are the basic modules, required by [Omega] and [Ring] for instance.
     The full library is [ZArith]. *)
 
+Require Export BinNums.
 Require Export BinPos.
 Require Export BinNat.
 Require Export BinInt.
@@ -29,8 +28,8 @@ Require Export Zbool.
 Require Export Zmisc.
 Require Export Wf_Z.
 
-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
-  Zmult_plus_distr_r: zarith.
+Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l
+  Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_l
+  Z.mul_add_distr_r: zarith.
 
 Require Export Zhints.
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
index b6766640..76308e60 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Sumbool.
 
 Require Import BinInt.
@@ -38,17 +36,12 @@ Proof.
   intro; apply Zcompare_rect.
 Defined.
 
+Notation Z_eq_dec := Z.eq_dec (only parsing).
+
 Section decidability.
 
   Variables x y : Z.
 
-  (** * Decidability of equality on binary integers *)
-
-  Definition Z_eq_dec : {x = y} + {x <> y}.
-  Proof.
-    decide equality; apply positive_eq_dec.
-  Defined.
-
   (** * Decidability of order on binary integers *)
 
   Definition Z_lt_dec : {x < y} + {~ x < y}.
diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v
deleted file mode 100644
index 70f6866e..00000000
--- a/theories/ZArith/ZOdiv.v
+++ /dev/null
@@ -1,947 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-
-Require Import BinPos BinNat Nnat ZArith_base ROmega ZArithRing.
-Require Export ZOdiv_def.
-Require Zdiv.
-
-Open Scope Z_scope.
-
-(** 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].
-
-  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
-  properties with respect to opposite and other usual operations.
-*)
-
-(** Since ZOdiv and Zdiv are not meant to be used concurrently,
-   we reuse the same notation. *)
-
-Infix "/" := ZOdiv : Z_scope.
-Infix "mod" := ZOmod (at level 40, no associativity) : Z_scope.
-
-Infix "/" := Ndiv : N_scope.
-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),
-  NPgeb n p = true -> Z_of_N n >= Zpos p.
-Proof.
- destruct n as [|n]; simpl; intros.
- discriminate.
- red; simpl; destruct Pcompare; now auto.
-Qed.
-
-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.
- red; auto.
- red; simpl; destruct Pcompare; now auto.
-Qed.
-
-(** * Relation between division on N and on Z. *)
-
-Lemma Ndiv_Z0div : forall a b:N,
-  Z_of_N (a/b) = (Z_of_N a / Z_of_N b).
-Proof.
-  intros.
-  destruct a; destruct b; simpl; auto.
-  unfold Ndiv, ZOdiv; simpl; destruct Pdiv_eucl; auto.
-Qed.
-
-Lemma Nmod_Z0mod : forall a b:N,
-  Z_of_N (a mod b) = (Z_of_N a) mod (Z_of_N b).
-Proof.
-  intros.
-  destruct a; destruct b; simpl; auto.
-  unfold Nmod, ZOmod; simpl; destruct Pdiv_eucl; auto.
-Qed.
-
-(** * Characterization of this euclidean division. *)
-
-(** 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,
-  a = (b * (Ndiv a b) + (Nmod a b))%N.
-Proof.
-  intros; generalize (Ndiv_eucl_correct a b).
-  unfold Ndiv, Nmod; destruct Ndiv_eucl; simpl.
-  intro H; rewrite H; rewrite Nmult_comm; auto.
-Qed.
-
-Theorem ZO_div_mod_eq : forall a b,
-  a = b * (ZOdiv a b) + (ZOmod a b).
-Proof.
-  intros; generalize (ZOdiv_eucl_correct a b).
-  unfold ZOdiv, ZOmod; destruct ZOdiv_eucl; simpl.
-  intro H; rewrite H; rewrite Zmult_comm; auto.
-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.
-Proof.
-  induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
-  intros b; generalize (IHa b); case Pdiv_eucl.
-    intros q1 r1 Hr1; simpl in Hr1.
-    case_eq (NPgeb (2*r1+1) b); intros; unfold snd.
-    romega with *.
-    apply NPgeb_Zlt; auto.
-  intros b; generalize (IHa b); case Pdiv_eucl.
-    intros q1 r1 Hr1; simpl in Hr1.
-    case_eq (NPgeb (2*r1) b); intros; unfold snd.
-    romega with *.
-    apply NPgeb_Zlt; auto.
-  destruct b; simpl; romega with *.
-Qed.
-
-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].
-  destruct a as [ |a]; try solve [compute;auto]; unfold Nmod, Ndiv_eucl.
-  generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl.
-  romega with *.
-Qed.
-
-(** The remainder is bounded by the divisor, in term of absolute values *)
-
-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;
-  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
-   nullity of [a], a general result is to be stated in the following form:
-*)
-
-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;
-  unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl;
-  simpl; destruct n0; simpl; auto with zarith.
-Qed.
-
-(** This can also be said in a simplier way: *)
-
-Theorem Zsgn_pos_iff : forall z, 0 <= Zsgn z <-> 0 <= z.
-Proof.
- destruct z; simpl; intuition auto with zarith.
-Qed.
-
-Theorem ZOmod_sgn2 : forall a b:Z,
-  0 <= (a mod b) * a.
-Proof.
-  intros; rewrite <-Zsgn_pos_iff, Zsgn_Zmult; apply ZOmod_sgn.
-Qed.
-
-(** 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 ->
-  0 <= a mod b < Zabs b.
-Proof.
-  intros.
-  assert (0 <= a mod b).
-   generalize (ZOmod_sgn a b).
-   destruct (Zle_lt_or_eq 0 a H).
-   rewrite <- Zsgn_pos in H1; rewrite H1; romega with *.
-   subst a; simpl; auto.
-  generalize (ZOmod_lt a b H0); romega with *.
-Qed.
-
-Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 ->
-  -Zabs b < a mod b <= 0.
-Proof.
-  intros.
-  assert (a mod b <= 0).
-   generalize (ZOmod_sgn a b).
-   destruct (Zle_lt_or_eq a 0 H).
-   rewrite <- Zsgn_neg in H1; rewrite H1; romega with *.
-   subst a; simpl; auto.
-  generalize (ZOmod_lt a b H0); romega with *.
-Qed.
-
-Theorem ZOmod_lt_pos_pos : forall a b:Z, 0<=a -> 0<b -> 0 <= a mod b < b.
-Proof.
-  intros; generalize (ZOmod_lt_pos a b); romega with *.
-Qed.
-
-Theorem ZOmod_lt_pos_neg : forall a b:Z, 0<=a -> b<0 -> 0 <= a mod b < -b.
-Proof.
-  intros; generalize (ZOmod_lt_pos a b); romega with *.
-Qed.
-
-Theorem ZOmod_lt_neg_pos : forall a b:Z, a<=0 -> 0<b -> -b < a mod b <= 0.
-Proof.
-  intros; generalize (ZOmod_lt_neg a b); romega with *.
-Qed.
-
-Theorem ZOmod_lt_neg_neg : forall a b:Z, a<=0 -> b<0 -> b < a mod b <= 0.
-Proof.
-  intros; generalize (ZOmod_lt_neg a b); romega with *.
-Qed.
-
-(** * Division and Opposite *)
-
-(* The precise equalities that are invalid with "historic" Zdiv. *)
-
-Theorem ZOdiv_opp_l : forall a b:Z, (-a)/b = -(a/b).
-Proof.
- 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;
-  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;
-  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;
-  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;
-  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;
-  unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
-Qed.
-
-(** * Unicity results *)
-
-Definition Remainder a b r :=
-  (0 <= a /\ 0 <= r < Zabs b) \/ (a <= 0 /\ -Zabs b < r <= 0).
-
-Definition Remainder_alt a b r :=
-  Zabs r < Zabs b /\ 0 <= r * a.
-
-Lemma Remainder_equiv : forall a b r,
- Remainder a b r <-> Remainder_alt a b r.
-Proof.
-  unfold Remainder, Remainder_alt; intuition.
-  romega with *.
-  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).
-  destruct r; simpl Zsgn in *; romega with *.
-Qed.
-
-Theorem ZOdiv_mod_unique_full:
- 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.
-  apply Zdiv.Zdiv_mod_unique with b; auto.
-  apply ZOmod_lt_pos; auto.
-  romega with *.
-  rewrite <- H1; apply ZO_div_mod_eq.
-
-  rewrite <- (Zopp_involutive a).
-  rewrite ZOdiv_opp_l, ZOmod_opp_l.
-  generalize (Zdiv.Zdiv_mod_unique b (-q) (-a/b) (-r) (-a mod b)).
-  generalize (ZOmod_lt_pos (-a) b).
-  rewrite <-ZO_div_mod_eq, <-Zopp_mult_distr_r, <-Zopp_plus_distr, <-H1.
-  romega with *.
-Qed.
-
-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 ->
-   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 ->
-  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 ->
-   a = b*q + r -> r = a mod b.
-Proof.
-  intros; eapply ZOmod_unique_full; eauto.
-  red; romega with *.
-Qed.
-
-(** * Basic values of divisions and modulo. *)
-
-Lemma ZOmod_0_l: forall a, 0 mod a = 0.
-Proof.
-  destruct a; simpl; auto.
-Qed.
-
-Lemma ZOmod_0_r: forall a, a mod 0 = a.
-Proof.
-  destruct a; simpl; auto.
-Qed.
-
-Lemma ZOdiv_0_l: forall a, 0/a = 0.
-Proof.
-  destruct a; simpl; auto.
-Qed.
-
-Lemma ZOdiv_0_r: forall a, a/0 = 0.
-Proof.
-  destruct a; simpl; auto.
-Qed.
-
-Lemma ZOmod_1_r: forall a, a mod 1 = 0.
-Proof.
-  intros; symmetry; apply ZOmod_unique_full with a; auto with zarith.
-  rewrite Remainder_equiv; red; simpl; auto with zarith.
-Qed.
-
-Lemma ZOdiv_1_r: forall a, a/1 = a.
-Proof.
-  intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith.
-  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
- : zarith.
-
-Lemma ZOdiv_1_l: forall a, 1 < a -> 1/a = 0.
-Proof.
-  intros; symmetry; apply ZOdiv_unique with 1; auto with zarith.
-Qed.
-
-Lemma ZOmod_1_l: forall a, 1 < a ->  1 mod a = 1.
-Proof.
-  intros; symmetry; apply ZOmod_unique with 0; auto with zarith.
-Qed.
-
-Lemma ZO_div_same : forall a:Z, a<>0 -> a/a = 1.
-Proof.
-  intros; symmetry; apply ZOdiv_unique_full with 0; auto with *.
-  rewrite Remainder_equiv; red; simpl; romega with *.
-Qed.
-
-Lemma ZO_mod_same : forall a, a mod a = 0.
-Proof.
-  destruct a; intros; symmetry.
-  compute; auto.
-  apply ZOmod_unique with 1; auto with *; romega with *.
-  apply ZOmod_unique_full with 1; auto with *; red; romega with *.
-Qed.
-
-Lemma ZO_mod_mult : forall a b, (a*b) mod b = 0.
-Proof.
-  intros a b; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; simpl; rewrite ZOmod_0_r; auto with zarith.
-  symmetry; apply ZOmod_unique_full with a; [ red; romega with * | ring ].
-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;
-   [ red; romega with * | ring].
-Qed.
-
-(** * Order results about ZOmod and ZOdiv *)
-
-(* Division of positive numbers is positive. *)
-
-Lemma ZO_div_pos: forall a b, 0 <= a -> 0 <= b -> 0 <= a/b.
-Proof.
-  intros.
-  destruct (Zle_lt_or_eq 0 b H0).
-  assert (H2:=ZOmod_lt_pos_pos a b H H1).
-  rewrite (ZO_div_mod_eq a b) in H.
-  destruct (Z_lt_le_dec (a/b) 0); auto.
-  assert (b*(a/b) <= -b).
-   replace (-b) with (b*-1); [ | ring].
-   apply Zmult_le_compat_l; auto with zarith.
-  romega.
-  subst b; rewrite ZOdiv_0_r; auto.
-Qed.
-
-(** 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.
-  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).
-  destruct (Zle_lt_or_eq 0 (a/b) H1) as [H3|H3]; [ | rewrite <- H3; auto].
-  pattern a at 2; rewrite (ZO_div_mod_eq a b).
-  apply Zlt_le_trans with (2*(a/b)).
-  romega.
-  apply Zle_trans with (b*(a/b)).
-  apply Zmult_le_compat_r; auto.
-  romega.
-Qed.
-
-(** A division of a small number by a bigger one yields zero. *)
-
-Theorem ZOdiv_small: forall a b, 0 <= a < b -> a/b = 0.
-Proof.
-  intros a b H; apply sym_equal; apply ZOdiv_unique with a; auto with zarith.
-Qed.
-
-(** Same situation, in term of modulo: *)
-
-Theorem ZOmod_small: forall a n, 0 <= a < n -> a mod n = a.
-Proof.
-  intros a b H; apply sym_equal; apply ZOmod_unique with 0; auto with zarith.
-Qed.
-
-(** [Zge] is compatible with a positive division. *)
-
-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);
-   [ 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).
-  generalize (ZO_div_mod_eq b c).
-  generalize (ZOmod_lt_pos_pos b c (Zle_trans _ _ _ H0 H1) H2).
-  intros.
-  elim (Z_le_gt_dec (a / c) (b / c)); auto with zarith.
-  intro.
-  absurd (a - b >= 1).
-  omega.
-  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.
-  omega.
-  omega.
-  assert (c * 1 = c).
-  ring.
-  omega.
-Qed.
-
-Lemma ZO_div_monotone : forall a b c, 0<=c -> a<=b -> a/c <= b/c.
-Proof.
-  intros.
-  destruct (Z_le_gt_dec 0 a).
-  apply ZO_div_monotone_pos; auto with zarith.
-  destruct (Z_le_gt_dec 0 b).
-  apply Zle_trans with 0.
-  apply Zle_left_rev.
-  simpl.
-  rewrite <- ZOdiv_opp_l.
-  apply ZO_div_pos; auto with zarith.
-  apply ZO_div_pos; auto with zarith.
-  rewrite <-(Zopp_involutive a), (ZOdiv_opp_l (-a)).
-  rewrite <-(Zopp_involutive b), (ZOdiv_opp_l (-b)).
-  generalize (ZO_div_monotone_pos (-b) (-a) c H).
-  romega.
-Qed.
-
-(** With our choice of division, rounding of (a/b) is always done toward zero: *)
-
-Lemma ZO_mult_div_le : forall a b:Z, 0 <= a -> 0 <= b*(a/b) <= a.
-Proof.
-  intros a b Ha.
-  destruct b as [ |b|b].
-  simpl; auto with zarith.
-  split.
-  apply Zmult_le_0_compat; auto with zarith.
-  apply ZO_div_pos; auto with zarith.
-  generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_pos_pos a (Zpos b) Ha); romega with *.
-  change (Zneg b) with (-Zpos b); rewrite ZOdiv_opp_r, Zmult_opp_opp.
-  split.
-  apply Zmult_le_0_compat; auto with zarith.
-  apply ZO_div_pos; auto with zarith.
-  generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_pos_pos a (Zpos b) Ha); romega with *.
-Qed.
-
-Lemma ZO_mult_div_ge : forall a b:Z, a <= 0 -> a <= b*(a/b) <= 0.
-Proof.
-  intros a b Ha.
-  destruct b as [ |b|b].
-  simpl; auto with zarith.
-  split.
-  generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_neg_pos a (Zpos b) Ha); romega with *.
-  apply Zle_left_rev; unfold Zplus.
-  rewrite Zopp_mult_distr_r, <-ZOdiv_opp_l.
-  apply Zmult_le_0_compat; auto with zarith.
-  apply ZO_div_pos; auto with zarith.
-  change (Zneg b) with (-Zpos b); rewrite ZOdiv_opp_r, Zmult_opp_opp.
-  split.
-  generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_neg_pos a (Zpos b) Ha); romega with *.
-  apply Zle_left_rev; unfold Zplus.
-  rewrite Zopp_mult_distr_r, <-ZOdiv_opp_l.
-  apply Zmult_le_0_compat; auto with zarith.
-  apply ZO_div_pos; auto with zarith.
-Qed.
-
-(** 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.
-Proof.
-  intros; generalize (ZO_div_mod_eq a b); romega.
-Qed.
-
-Lemma ZO_div_exact_full_2 : forall a b:Z, a mod b = 0 -> a = b*(a/b).
-Proof.
-  intros; generalize (ZO_div_mod_eq a b); romega.
-Qed.
-
-(** A modulo cannot grow beyond its starting point. *)
-
-Theorem ZOmod_le: forall a b, 0 <= a -> 0 <= b -> a mod b <= a.
-Proof.
-  intros a b H1 H2.
-  destruct (Zle_lt_or_eq _ _ H2).
-  case (Zle_or_lt b a); intros H3.
-  case (ZOmod_lt_pos_pos a b); auto with zarith.
-  rewrite ZOmod_small; auto with zarith.
-  subst; rewrite ZOmod_0_r; auto with zarith.
-Qed.
-
-(** Some additionnal inequalities about Zdiv. *)
-
-Theorem ZOdiv_le_upper_bound:
-  forall a b q, 0 < b -> a <= q*b -> a/b <= q.
-Proof.
-  intros.
-  rewrite <- (ZO_div_mult q b); auto with zarith.
-  apply ZO_div_monotone; auto with zarith.
-Qed.
-
-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.
-  apply Zmult_lt_reg_r with b; auto with zarith.
-  apply Zle_lt_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.
-Qed.
-
-Theorem ZOdiv_le_lower_bound:
-  forall a b q, 0 < b -> q*b <= a -> q <= a/b.
-Proof.
-  intros.
-  rewrite <- (ZO_div_mult q b); auto with zarith.
-  apply ZO_div_monotone; auto with zarith.
-Qed.
-
-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;
-  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.
-    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 ->
- (a + b * c) mod c = a mod c.
-Proof.
-  intros; destruct (Z_eq_dec a 0) as [Ha|Ha].
-  subst; simpl; rewrite ZOmod_0_l; apply ZO_mod_mult.
-  intros; destruct (Z_eq_dec c 0) as [Hc|Hc].
-  subst; do 2 rewrite ZOmod_0_r; romega.
-  symmetry; apply ZOmod_unique_full with (a/c+b); auto with zarith.
-  rewrite Remainder_equiv; split.
-  apply ZOmod_lt; auto.
-  apply Zmult_le_0_reg_r with (a*a); eauto.
-  destruct a; simpl; auto with zarith.
-  replace ((a mod c)*(a+b*c)*(a*a)) with (((a mod c)*a)*((a+b*c)*a)) by ring.
-  apply Zmult_le_0_compat; auto.
-  apply ZOmod_sgn2.
-  rewrite Zmult_plus_distr_r, Zmult_comm.
-  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 ->
- (a + b * c) / c = a / c + b.
-Proof.
-  intros; destruct (Z_eq_dec a 0) as [Ha|Ha].
-  subst; simpl; apply ZO_div_mult; auto.
-  symmetry.
-  apply ZOdiv_unique_full with (a mod c); auto with zarith.
-  rewrite Remainder_equiv; split.
-  apply ZOmod_lt; auto.
-  apply Zmult_le_0_reg_r with (a*a); eauto.
-  destruct a; simpl; auto with zarith.
-  replace ((a mod c)*(a+b*c)*(a*a)) with (((a mod c)*a)*((a+b*c)*a)) by ring.
-  apply Zmult_le_0_compat; auto.
-  apply ZOmod_sgn2.
-  rewrite Zmult_plus_distr_r, Zmult_comm.
-  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 ->
- 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.
-Qed.
-
-(** Cancellations. *)
-
-Lemma ZOdiv_mult_cancel_r : forall a b c:Z,
- c<>0 -> (a*c)/(b*c) = a/b.
-Proof.
- intros a b c Hc.
- destruct (Z_eq_dec b 0).
- subst; simpl; do 2 rewrite ZOdiv_0_r; auto.
- symmetry.
- apply ZOdiv_unique_full with ((a mod b)*c); auto with zarith.
- rewrite Remainder_equiv.
- split.
- do 2 rewrite Zabs_Zmult.
- apply Zmult_lt_compat_r.
- romega with *.
- apply ZOmod_lt; auto.
- replace ((a mod b)*c*(a*c)) with (((a mod b)*a)*(c*c)) by ring.
- apply Zmult_le_0_compat.
- apply ZOmod_sgn2.
- destruct c; simpl; auto with zarith.
- pattern a at 1; rewrite (ZO_div_mod_eq a b); ring.
-Qed.
-
-Lemma ZOdiv_mult_cancel_l : forall a b c:Z,
- c<>0 -> (c*a)/(c*b) = a/b.
-Proof.
-  intros.
-  rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
-  apply ZOdiv_mult_cancel_r; auto.
-Qed.
-
-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].
-  subst; simpl; rewrite ZOmod_0_r; auto.
-  destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; repeat rewrite Zmult_0_r || rewrite ZOmod_0_r; auto.
-  assert (c*b <> 0).
-   contradict Hc; eapply Zmult_integral_l; eauto.
-  rewrite (Zplus_minus_eq _ _ _ (ZO_div_mod_eq (c*a) (c*b))).
-  rewrite (Zplus_minus_eq _ _ _ (ZO_div_mod_eq a b)).
-  rewrite ZOdiv_mult_cancel_l; auto with zarith.
-  ring.
-Qed.
-
-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)).
-  apply ZOmult_mod_distr_l; auto.
-Qed.
-
-(** Operations modulo. *)
-
-Theorem ZOmod_mod: forall a n, (a mod n) mod n = a mod n.
-Proof.
-  intros.
-  generalize (ZOmod_sgn2 a n).
-  pattern a at 2 4; rewrite (ZO_div_mod_eq a n); auto with zarith.
-  rewrite Zplus_comm; rewrite (Zmult_comm n).
-  intros.
-  apply sym_equal; apply ZO_mod_plus; auto with zarith.
-  rewrite Zmult_comm; auto.
-Qed.
-
-Theorem ZOmult_mod: forall a b n,
- (a * b) mod n = ((a mod n) * (b mod n)) mod n.
-Proof.
-  intros.
-  generalize (Zmult_le_0_compat _ _ (ZOmod_sgn2 a n) (ZOmod_sgn2 b n)).
-  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))
-   by ring.
-  replace ((n*A' + A) * (n*B' + B))
-   with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring.
-  intros.
-  apply ZO_mod_plus; auto with zarith.
-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
-  (8 mod 3 + (-10 mod 3)) mod 3 = 1. *)
-
-Theorem ZOplus_mod: forall a b n,
- 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 ->
-           (a + b) mod n = (a mod n + b mod n) mod n).
-  intros a b n Ha Hb.
-  assert (H : 0<=a+b) by (romega with * ); revert H.
-  pattern a at 1 2; rewrite (ZO_div_mod_eq a n); auto with zarith.
-  pattern b at 1 2; rewrite (ZO_div_mod_eq b n); auto with zarith.
-  replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n))
-     with ((a mod n + b mod n) + (a / n + b / n) * n) by ring.
-  intros.
-  apply ZO_mod_plus; auto with zarith.
-  apply Zmult_le_0_compat; auto with zarith.
-  apply Zplus_le_0_compat.
-  apply Zmult_le_reg_r with a; auto with zarith.
-  simpl; apply ZOmod_sgn2; auto.
-  apply Zmult_le_reg_r with b; auto with zarith.
-  simpl; apply ZOmod_sgn2; auto.
-  (* general situation *)
-  intros a b n Hab.
-  destruct (Z_eq_dec a 0).
-  subst; simpl; symmetry; apply ZOmod_mod.
-  destruct (Z_eq_dec b 0).
-  subst; simpl; do 2 rewrite Zplus_0_r; symmetry; apply ZOmod_mod.
-  assert (0<a /\ 0<b \/ a<0 /\ b<0).
-   destruct a; destruct b; simpl in *; intuition; romega with *.
-  destruct H0.
-  apply H; intuition.
-  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 =>
-   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 ->
- (a mod n + b) mod n = (a + b) mod n.
-Proof.
-  intros.
-  rewrite ZOplus_mod.
-  rewrite ZOmod_mod.
-  symmetry.
-  apply ZOplus_mod; auto.
-  destruct (Z_eq_dec a 0).
-  subst; rewrite ZOmod_0_l; auto.
-  destruct (Z_eq_dec b 0).
-  subst; rewrite Zmult_0_r; auto with zarith.
-  apply Zmult_le_reg_r with (a*b).
-  assert (a*b <> 0).
-   intro Hab.
-   rewrite (Zmult_integral_l _ _ n1 Hab) in n0; auto with zarith.
-  auto with zarith.
-  simpl.
-  replace (a mod n * b * (a*b)) with ((a mod n * a)*(b*b)) by ring.
-  apply Zmult_le_0_compat.
-  apply ZOmod_sgn2.
-  destruct b; simpl; auto with zarith.
-Qed.
-
-Lemma ZOplus_mod_idemp_r: forall a b n,
- 0 <= a*b ->
- (b + a mod n) mod n = (b + a) mod n.
-Proof.
-  intros.
-  rewrite Zplus_comm, (Zplus_comm b a).
-  apply ZOplus_mod_idemp_l; auto.
-Qed.
-
-Lemma ZOmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n.
-Proof.
-  intros; rewrite ZOmult_mod, ZOmod_mod, <- ZOmult_mod; auto.
-Qed.
-
-Lemma ZOmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n.
-Proof.
-  intros; rewrite ZOmult_mod, ZOmod_mod, <- ZOmult_mod; auto.
-Qed.
-
-(** Unlike with Zdiv, the following result is true without restrictions. *)
-
-Lemma ZOdiv_ZOdiv : forall a b c, (a/b)/c = a/(b*c).
-Proof.
-  (* particular case: a, b, c positive *)
-  assert (forall a b c, a>0 -> b>0 -> c>0 -> (a/b)/c = a/(b*c)).
-   intros a b c H H0 H1.
-   pattern a at 2;rewrite (ZO_div_mod_eq a b).
-   pattern (a/b) at 2;rewrite (ZO_div_mod_eq (a/b) c).
-   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;
-    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
-    (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)).
-   ring.
-   split.
-   apply Zplus_le_0_compat;auto with zarith.
-   apply Zle_lt_trans with (b * ((a / b) mod c) + (b-1)).
-   apply Zplus_le_compat;auto with zarith.
-   apply Zle_lt_trans with (b * (c-1) + (b - 1)).
-   apply Zplus_le_compat;auto with zarith.
-   replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith.
-   repeat (apply Zmult_le_0_compat || apply Zplus_le_0_compat); auto with zarith.
-   apply (ZO_div_pos (a/b) c); auto with zarith.
-  (* b c positive, a general *)
-  assert (forall a b c, b>0 -> c>0 -> (a/b)/c = a/(b*c)).
-   intros; destruct a as [ |a|a]; try reflexivity.
-   apply H; auto with zarith.
-   change (Zneg a) with (-Zpos a); repeat rewrite ZOdiv_opp_l.
-   f_equal; apply H; auto with zarith.
-  (* c positive, a b general *)
-  assert (forall a b c, c>0 -> (a/b)/c = a/(b*c)).
-   intros; destruct b as [ |b|b].
-   repeat rewrite ZOdiv_0_r; reflexivity.
-   apply H0; auto with zarith.
-   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);
-  rewrite <- Zopp_mult_distr_r; do 2 rewrite ZOdiv_opp_r.
-  f_equal; apply H1; auto with zarith.
-Qed.
-
-(** A last inequality: *)
-
-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);
-   [ | subst; rewrite ZOdiv_0_l, Zmult_0_r, ZOdiv_0_l; auto].
-  destruct (Zle_lt_or_eq _ _ Hb);
-   [ | subst; rewrite ZOdiv_0_r, ZOdiv_0_r, Zmult_0_r; auto].
-  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.
-  apply Zmult_le_reg_r with b; auto with zarith.
-  rewrite <- Zmult_assoc.
-  replace (a / b * b) with (a - a mod b).
-  replace (c * a / b * b) with (c * a - (c * a) mod b).
-  rewrite Zmult_minus_distr_l.
-  unfold Zminus; apply Zplus_le_compat_l.
-  match goal with |- - ?X <= -?Y => assert (Y <= X); auto with zarith end.
-  apply Zle_trans with ((c mod b) * (a mod b)); auto with zarith.
-  rewrite ZOmult_mod; auto with zarith.
-  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;
-    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,
- a mod b = 0 <-> exists c, a = b*c.
-Proof.
- split; intros.
- exists (a/b).
- pattern a at 1; rewrite (ZO_div_mod_eq a b).
- rewrite H; auto with zarith.
- destruct H as [c Hc].
- destruct (Z_eq_dec b 0).
- subst b; simpl in *; subst a; auto.
- symmetry.
- apply ZOmod_unique_full with c; auto with zarith.
- red; romega with *.
-Qed.
-
-(** * Interaction with "historic" Zdiv *)
-
-(** They agree at least on positive numbers: *)
-
-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.
-  apply Zdiv.Zdiv_mod_unique with b.
-  apply ZOmod_lt_pos; auto with zarith.
-  rewrite Zabs_eq; auto with *; apply Zdiv.Z_mod_lt; auto with *.
-  rewrite <- Zdiv.Z_div_mod_eq; auto with *.
-  symmetry; apply ZO_div_mod_eq; auto with *.
-Qed.
-
-Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
-  a/b = Zdiv.Zdiv a b.
-Proof.
- intros a b Ha Hb.
- destruct (Zle_lt_or_eq _ _ Hb).
- generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha H); intuition.
- subst; rewrite ZOdiv_0_r, Zdiv.Zdiv_0_r; reflexivity.
-Qed.
-
-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);
- intuition.
-Qed.
-
-(** Modulos are null at the same places *)
-
-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.
diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v
deleted file mode 100644
index 71d6cad4..00000000
--- a/theories/ZArith/ZOdiv_def.v
+++ /dev/null
@@ -1,136 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-
-Require Import BinPos BinNat Nnat ZArith_base.
-
-Open Scope Z_scope.
-
-Definition NPgeb (a:N)(b:positive) :=
-  match a with
-   | N0 => false
-   | Npos na => match Pcompare na b Eq with Lt => false | _ => true end
-  end.
-
-Fixpoint Pdiv_eucl (a b:positive) : N * N :=
-  match a with
-    | xH =>
-       match b with xH => (1, 0)%N | _ => (0, 1)%N end
-    | xO a' =>
-       let (q, r) := Pdiv_eucl a' b in
-       let r' := (2 * r)%N in
-        if (NPgeb r' b) then (2 * q + 1, (Nminus r'  (Npos b)))%N
-        else  (2 * q, r')%N
-    | xI a' =>
-       let (q, r) := Pdiv_eucl a' b in
-       let r' := (2 * r + 1)%N in
-        if (NPgeb r' b) then (2 * q + 1, (Nminus r' (Npos b)))%N
-        else  (2 * q, r')%N
-  end.
-
-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
-         (Z_of_N nq, Z_of_N nr)
-   | 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
-         (Zopp (Z_of_N nq), Z_of_N nr)
-   | Zneg na, Zneg nb =>
-         let (nq, nr) := Pdiv_eucl na nb in
-         (Z_of_N nq, Zopp (Z_of_N nr))
-  end.
-
-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 :=
-  match a, b with
-   | N0,  _ => (N0, N0)
-   | _, N0  => (N0, a)
-   | Npos na, Npos nb => Pdiv_eucl na nb
-  end.
-
-Definition Ndiv a b := fst (Ndiv_eucl a b).
-Definition Nmod a b := snd (Ndiv_eucl a b).
-
-
-(* Proofs of specifications for these euclidean divisions. *)
-
-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.
-  now rewrite Pminus_mask_diag.
-  destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]].
-  rewrite H2. rewrite <- H3.
-  simpl; f_equal; apply Pplus_comm.
-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.
-
-Theorem Pdiv_eucl_correct: forall a b,
-  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.
-  intros b; generalize (IHa b); case Pdiv_eucl.
-    intros q1 r1 Hq1.
-     generalize (NPgeb_correct (2 * r1 + 1) b); case NPgeb; intros H.
-     set (u := Nminus (2 * r1 + 1) (Npos b)) in * |- *.
-     assert (HH: Z_of_N u = (Z_of_N (2 * r1 + 1) - Zpos b)%Z).
-        rewrite H; autorewrite with zdiv; simpl.
-        rewrite Zplus_comm, Zminus_plus; trivial.
-     rewrite HH; autorewrite with zdiv; simpl Z_of_N.
-     rewrite Zpos_xI, Hq1.
-     autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial.
-     rewrite Zpos_xI, Hq1; autorewrite with zdiv; auto.
-  intros b; generalize (IHa b); case Pdiv_eucl.
-    intros q1 r1 Hq1.
-     generalize (NPgeb_correct (2 * r1) b); case NPgeb; intros H.
-     set (u := Nminus (2 * r1) (Npos b)) in * |- *.
-     assert (HH: Z_of_N u = (Z_of_N (2 * r1) - Zpos b)%Z).
-        rewrite H; autorewrite with zdiv; simpl.
-        rewrite Zplus_comm, Zminus_plus; trivial.
-     rewrite HH; autorewrite with zdiv; simpl Z_of_N.
-     rewrite Zpos_xO, Hq1.
-     autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial.
-     rewrite Zpos_xO, Hq1; autorewrite with zdiv; auto.
-  destruct b; auto.
-Qed.
-
-Theorem ZOdiv_eucl_correct: forall a b,
-  let (q,r) := ZOdiv_eucl a b in a = q * b + r.
-Proof.
-  destruct a; destruct b; simpl; auto;
-  generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros;
-  try change (Zneg p) with (Zopp (Zpos p)); rewrite H.
-    destruct n; auto.
-  repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_l); trivial.
-  repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_r); trivial.
-Qed.
-
-Theorem Ndiv_eucl_correct: forall a b,
-  let (q,r) := Ndiv_eucl a b in a = (q * b + r)%N.
-Proof.
-  destruct a; destruct b; simpl; auto;
-  generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros;
-  destruct n; destruct n0; simpl; simpl in H; try discriminate;
-  injection H; intros; subst; trivial.
-Qed.
diff --git a/theories/ZArith/ZOrderedType.v b/theories/ZArith/ZOrderedType.v
deleted file mode 100644
index de4e4e98..00000000
--- a/theories/ZArith/ZOrderedType.v
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \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 0f6e62b7..23473e93 100644
--- a/theories/ZArith/Zabs.v
+++ b/theories/ZArith/Zabs.v
@@ -1,226 +1,106 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zabs.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+(** Binary Integers : properties of absolute value *)
+(** Initial author : Pierre Crégut (CNET, Lannion, France) *)
+
+(** THIS FILE IS DEPRECATED.
+    It is now almost entirely made of compatibility formulations
+    for results already present in BinInt.Z. *)
 
 Require Import Arith_base.
 Require Import BinPos.
 Require Import BinInt.
+Require Import Zcompare.
 Require Import Zorder.
-Require Import Zmax.
 Require Import Znat.
 Require Import ZArith_dec.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (**********************************************************************)
 (** * Properties of absolute value *)
 
-Lemma Zabs_eq : forall n:Z, 0 <= n -> Zabs n = n.
-Proof.
-  intro x; destruct x; auto with arith.
-  compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
-Qed.
-
-Lemma Zabs_non_eq : forall n:Z, n <= 0 -> Zabs n = - n.
-Proof.
-  intro x; destruct x; auto with arith.
-  compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
-Qed.
-
-Theorem Zabs_Zopp : forall n:Z, Zabs (- n) = Zabs n.
-Proof.
-  intros z; case z; simpl in |- *; auto.
-Qed.
+Notation Zabs_eq := Z.abs_eq (only parsing).
+Notation Zabs_non_eq := Z.abs_neq (only parsing).
+Notation Zabs_Zopp := Z.abs_opp (only parsing).
+Notation Zabs_pos := Z.abs_nonneg (only parsing).
+Notation Zabs_involutive := Z.abs_involutive (only parsing).
+Notation Zabs_eq_case := Z.abs_eq_cases (only parsing).
+Notation Zabs_triangle := Z.abs_triangle (only parsing).
+Notation Zsgn_Zabs := Z.sgn_abs (only parsing).
+Notation Zabs_Zsgn := Z.abs_sgn (only parsing).
+Notation Zabs_Zmult := Z.abs_mul (only parsing).
+Notation Zabs_square := Z.abs_square (only parsing).
 
 (** * Proving a property of the absolute value by cases *)
 
 Lemma Zabs_ind :
   forall (P:Z -> Prop) (n:Z),
-    (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Zabs n).
+    (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Z.abs n).
 Proof.
-  intros P x H H0; elim (Z_lt_ge_dec x 0); intro.
-  assert (x <= 0). apply Zlt_le_weak; assumption.
-  rewrite Zabs_non_eq. apply H0. assumption. assumption.
-  rewrite Zabs_eq. apply H; assumption. apply Zge_le. assumption.
+ intros. apply Z.abs_case_strong; Z.swap_greater; trivial.
+ intros x y Hx; now subst.
 Qed.
 
-Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Zabs n).
+Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Z.abs n).
 Proof.
-  intros P z; case z; simpl in |- *; auto.
+ now destruct n.
 Qed.
 
-Definition Zabs_dec : forall x:Z, {x = Zabs x} + {x = - Zabs x}.
+Definition Zabs_dec : forall x:Z, {x = Z.abs x} + {x = - Z.abs x}.
 Proof.
-  intro x; destruct x; auto with arith.
+ destruct x; auto.
 Defined.
 
-Lemma Zabs_pos : forall n:Z, 0 <= Zabs n.
-  intro x; destruct x; auto with arith; compute in |- *; intros H; inversion H.
-Qed.
-
-Lemma Zabs_involutive : forall x:Z, Zabs (Zabs x) = Zabs x.
-Proof.
-  intros; apply Zabs_eq; apply Zabs_pos.
-Qed.
-
-Theorem Zabs_eq_case : forall n m:Z, Zabs n = Zabs m -> n = m \/ n = - m.
-Proof.
-  intros z1 z2; case z1; case z2; simpl in |- *; auto;
-    try (intros; discriminate); intros p1 p2 H1; injection H1;
-      (intros H2; rewrite H2); auto.
-Qed.
-
-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.
-
-(** * Triangular inequality *)
-
-Hint Local Resolve Zle_neg_pos: zarith.
-
-Theorem Zabs_triangle : forall n m:Z, Zabs (n + m) <= Zabs n + Zabs m.
-Proof.
-  intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail).
-  intros p1 p2;
-    apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
-      try rewrite Zopp_plus_distr; auto with zarith.
-  apply Zplus_le_compat; simpl in |- *; auto with zarith.
-  apply Zplus_le_compat; simpl in |- *; auto with zarith.
-  intros p1 p2;
-    apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
-      try rewrite Zopp_plus_distr; auto with zarith.
-  apply Zplus_le_compat; simpl in |- *; auto with zarith.
-  apply Zplus_le_compat; simpl in |- *; auto with zarith.
-Qed.
-
-(** * Absolute value and multiplication *)
-
-Lemma Zsgn_Zabs : forall n:Z, n * Zsgn n = Zabs n.
-Proof.
-  intro x; destruct x; rewrite Zmult_comm; auto with arith.
-Qed.
-
-Lemma Zabs_Zsgn : forall n:Z, Zabs n * Zsgn n = n.
-Proof.
-  intro x; destruct x; rewrite Zmult_comm; auto with arith.
-Qed.
-
-Theorem Zabs_Zmult : forall n m:Z, Zabs (n * m) = Zabs n * Zabs m.
-Proof.
-  intros z1 z2; case z1; case z2; simpl in |- *; auto.
-Qed.
-
-Theorem Zabs_square : forall a, Zabs a * Zabs a = a * a.
+Lemma Zabs_spec x :
+  0 <= x /\ Z.abs x = x \/
+  0 > x /\ Z.abs x = -x.
 Proof.
-  destruct a; simpl; auto.
-Qed.
-
-(** * Results about absolute value in nat. *)
-
-Theorem inj_Zabs_nat : forall z:Z, Z_of_nat (Zabs_nat z) = Zabs z.
-Proof.
-  destruct z; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P.
-Qed.
-
-Theorem Zabs_nat_Z_of_nat: forall n, Zabs_nat (Z_of_nat n) = n.
-Proof.
-  destruct n; simpl; auto.
-  apply nat_of_P_o_P_of_succ_nat_eq_succ.
-Qed.
-
-Lemma Zabs_nat_mult: forall n m:Z, Zabs_nat (n*m) = (Zabs_nat n * Zabs_nat m)%nat.
-Proof.
-  intros; apply inj_eq_rev.
-  rewrite inj_mult; repeat rewrite inj_Zabs_nat; apply Zabs_Zmult.
-Qed.
-
-Lemma Zabs_nat_Zsucc:
- forall p, 0 <= p ->  Zabs_nat (Zsucc p) = S (Zabs_nat p).
-Proof.
-  intros; apply inj_eq_rev.
-  rewrite inj_S; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith.
-Qed.
-
-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.
-
-Lemma Zabs_nat_Zminus:
- forall x y, 0 <= x <= y ->  Zabs_nat (y - x) = (Zabs_nat y - Zabs_nat x)%nat.
-Proof.
-  intros x y (H,H').
-  assert (0 <= y) by (apply Zle_trans with x; auto).
-  assert (0 <= y-x) by (apply Zle_minus_le_0; auto).
-  apply inj_eq_rev.
-  rewrite inj_minus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto.
-  rewrite Zmax_right; auto.
-Qed.
-
-Lemma Zabs_nat_le :
-  forall n m:Z, 0 <= n <= m -> (Zabs_nat n <= Zabs_nat m)%nat.
-Proof.
-  intros n m (H,H'); apply inj_le_rev.
-  repeat rewrite inj_Zabs_nat, Zabs_eq; auto.
-  apply Zle_trans with n; auto.
-Qed.
-
-Lemma Zabs_nat_lt :
-  forall n m:Z, 0 <= n < m -> (Zabs_nat n < Zabs_nat m)%nat.
-Proof.
-  intros n m (H,H'); apply inj_lt_rev.
-  repeat rewrite inj_Zabs_nat, Zabs_eq; auto.
-  apply Zlt_le_weak; apply Zle_lt_trans with n; auto.
+ Z.swap_greater. apply Z.abs_spec.
 Qed.
 
 (** * Some results about the sign function. *)
 
-Lemma Zsgn_Zmult : forall a b, Zsgn (a*b) = Zsgn a * Zsgn b.
-Proof.
-  destruct a; destruct b; simpl; auto.
-Qed.
-
-Lemma Zsgn_Zopp : forall a, Zsgn (-a) = - Zsgn a.
-Proof.
-  destruct a; simpl; auto.
-Qed.
+Notation Zsgn_Zmult := Z.sgn_mul (only parsing).
+Notation Zsgn_Zopp := Z.sgn_opp (only parsing).
+Notation Zsgn_pos := Z.sgn_pos_iff (only parsing).
+Notation Zsgn_neg := Z.sgn_neg_iff (only parsing).
+Notation Zsgn_null := Z.sgn_null_iff (only parsing).
 
 (** A characterization of the sign function: *)
 
-Lemma Zsgn_spec : forall x:Z,
+Lemma Zsgn_spec x :
   0 < x /\ Zsgn x = 1 \/
   0 = x /\ Zsgn x = 0 \/
   0 > x /\ Zsgn x = -1.
 Proof.
- intros; unfold Zsgn, Zle, Zgt; destruct x; compute; intuition.
+ intros. Z.swap_greater. apply Z.sgn_spec.
 Qed.
 
-Lemma Zsgn_pos : forall x:Z, Zsgn x = 1 <-> 0 < x.
-Proof.
- destruct x; now intuition.
-Qed.
+(** Compatibility *)
 
-Lemma Zsgn_neg : forall x:Z, Zsgn x = -1 <-> x < 0.
+Notation inj_Zabs_nat := Zabs2Nat.id_abs (only parsing).
+Notation Zabs_nat_Z_of_nat := Zabs2Nat.id (only parsing).
+Notation Zabs_nat_mult := Zabs2Nat.inj_mul (only parsing).
+Notation Zabs_nat_Zsucc := Zabs2Nat.inj_succ (only parsing).
+Notation Zabs_nat_Zplus := Zabs2Nat.inj_add (only parsing).
+Notation Zabs_nat_Zminus := (fun n m => Zabs2Nat.inj_sub m n) (only parsing).
+Notation Zabs_nat_compare := Zabs2Nat.inj_compare (only parsing).
+
+Lemma Zabs_nat_le n m : 0 <= n <= m -> (Z.abs_nat n <= Z.abs_nat m)%nat.
 Proof.
- destruct x; now intuition.
+ intros (H,H'). apply Zabs2Nat.inj_le; trivial. now transitivity n.
 Qed.
 
-Lemma Zsgn_null : forall x:Z, Zsgn x = 0 <-> x = 0.
+Lemma Zabs_nat_lt n m : 0 <= n < m -> (Zabs_nat n < Zabs_nat m)%nat.
 Proof.
- destruct x; now intuition.
+ intros (H,H'). apply Zabs2Nat.inj_lt; trivial.
+  transitivity n; trivial. now apply Z.lt_le_incl.
 Qed.
-
diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
index a4eebfb2..d0901282 100644
--- a/theories/ZArith/Zbool.v
+++ b/theories/ZArith/Zbool.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zbool.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import BinInt.
 Require Import Zeven.
 Require Import Zorder.
@@ -15,7 +13,6 @@ Require Import Zcompare.
 Require Import ZArith_dec.
 Require Import Sumbool.
 
-Unset Boxed Definitions.
 Open Local Scope Z_scope.
 
 (** * Boolean operations from decidability of order *)
@@ -36,29 +33,13 @@ Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).
 (**********************************************************************)
 (** * Boolean comparisons of binary integers *)
 
-Definition Zle_bool (x y:Z) :=
-  match x ?= y with
-    | Gt => false
-    | _ => true
-  end.
+Notation Zle_bool := Z.leb (only parsing).
+Notation Zge_bool := Z.geb (only parsing).
+Notation Zlt_bool := Z.ltb (only parsing).
+Notation Zgt_bool := Z.gtb (only parsing).
 
-Definition Zge_bool (x y:Z) :=
-  match x ?= y with
-    | Lt => false
-    | _ => true
-  end.
-
-Definition Zlt_bool (x y:Z) :=
-  match x ?= y with
-    | Lt => true
-    | _ => false
-  end.
-
-Definition Zgt_bool (x y:Z) :=
-  match x ?= y with
-    | Gt => true
-    | _ => false
-  end.
+(** We now provide a direct [Z.eqb] that doesn't refer to [Z.compare].
+   The old [Zeq_bool] is kept for compatibility. *)
 
 Definition Zeq_bool (x y:Z) :=
   match x ?= y with
@@ -74,162 +55,130 @@ Definition Zneq_bool (x y:Z) :=
 
 (** Properties in term of [if ... then ... else ...] *)
 
-Lemma Zle_cases :
-  forall n m:Z, if Zle_bool n m then (n <= m) else (n > m).
+Lemma Zle_cases n m : if n <=? m then n <= m else n > m.
 Proof.
-  intros x y; unfold Zle_bool, Zle, Zgt in |- *.
-  case (x ?= y); auto; discriminate.
+ case Z.leb_spec; now Z.swap_greater.
 Qed.
 
-Lemma Zlt_cases :
-  forall n m:Z, if Zlt_bool n m then (n < m) else (n >= m).
+Lemma Zlt_cases n m : if n <? m then n < m else n >= m.
 Proof.
-  intros x y; unfold Zlt_bool, Zlt, Zge in |- *.
-  case (x ?= y); auto; discriminate.
+ case Z.ltb_spec; now Z.swap_greater.
 Qed.
 
-Lemma Zge_cases :
-  forall n m:Z, if Zge_bool n m then (n >= m) else (n < m).
+Lemma Zge_cases n m : if n >=? m then n >= m else n < m.
 Proof.
-  intros x y; unfold Zge_bool, Zge, Zlt in |- *.
-  case (x ?= y); auto; discriminate.
+ rewrite Z.geb_leb. case Z.leb_spec; now Z.swap_greater.
 Qed.
 
-Lemma Zgt_cases :
-  forall n m:Z, if Zgt_bool n m then (n > m) else (n <= m).
+Lemma Zgt_cases n m : if n >? m then n > m else n <= m.
 Proof.
-  intros x y; unfold Zgt_bool, Zgt, Zle in |- *.
-  case (x ?= y); auto; discriminate.
+ rewrite Z.gtb_ltb. case Z.ltb_spec; now Z.swap_greater.
 Qed.
 
-(** Lemmas on [Zle_bool] used in contrib/graphs *)
+(** Lemmas on [Z.leb] used in contrib/graphs *)
 
-Lemma Zle_bool_imp_le : forall n m:Z, Zle_bool n m = true -> (n <= m).
+Lemma Zle_bool_imp_le n m : (n <=? m) = true -> (n <= m).
 Proof.
-  unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *.
-  case (x ?= y); intros; discriminate.
+ apply Z.leb_le.
 Qed.
 
-Lemma Zle_imp_le_bool : forall n m:Z, (n <= m) -> Zle_bool n m = true.
+Lemma Zle_imp_le_bool n m : (n <= m) -> (n <=? m) = true.
 Proof.
-  unfold Zle, Zle_bool in |- *. intros x y. case (x ?= y); trivial. intro. elim (H (refl_equal _)).
+ apply Z.leb_le.
 Qed.
 
-Lemma Zle_bool_refl : forall n:Z, Zle_bool n n = true.
-Proof.
-  intro. apply Zle_imp_le_bool. apply Zeq_le. reflexivity.
-Qed.
+Notation Zle_bool_refl := Z.leb_refl (only parsing).
 
-Lemma Zle_bool_antisym :
-  forall n m:Z, Zle_bool n m = true -> Zle_bool m n = true -> n = m.
+Lemma Zle_bool_antisym n m :
+ (n <=? m) = true -> (m <=? n) = true -> n = m.
 Proof.
-  intros. apply Zle_antisym. apply Zle_bool_imp_le. assumption.
-  apply Zle_bool_imp_le. assumption.
+ rewrite !Z.leb_le. apply Z.le_antisymm.
 Qed.
 
-Lemma Zle_bool_trans :
-  forall n m p:Z,
-    Zle_bool n m = true -> Zle_bool m p = true -> Zle_bool n p = true.
+Lemma Zle_bool_trans n m p :
+ (n <=? m) = true -> (m <=? p) = true -> (n <=? p) = true.
 Proof.
-  intros x y z; intros. apply Zle_imp_le_bool. apply Zle_trans with (m := y). apply Zle_bool_imp_le. assumption.
-  apply Zle_bool_imp_le. assumption.
+ rewrite !Z.leb_le. apply Z.le_trans.
 Qed.
 
-Definition Zle_bool_total :
-  forall x y:Z, {Zle_bool x y = true} + {Zle_bool y x = true}.
+Definition Zle_bool_total x y :
+  { x <=? y = true } + { y <=? x = true }.
 Proof.
-  intros x y; intros. unfold Zle_bool in |- *. cut ((x ?= y) = Gt <-> (y ?= x) = Lt).
-  case (x ?= y). left. reflexivity.
-  left. reflexivity.
-  right. rewrite (proj1 H (refl_equal _)). reflexivity.
-  apply Zcompare_Gt_Lt_antisym.
+ case_eq (x <=? y); intros H.
+ - left; trivial.
+ - right. apply Z.leb_gt in H. now apply Z.leb_le, Z.lt_le_incl.
 Defined.
 
-Lemma Zle_bool_plus_mono :
-  forall n m p q:Z,
-    Zle_bool n m = true ->
-    Zle_bool p q = true -> Zle_bool (n + p) (m + q) = true.
+Lemma Zle_bool_plus_mono n m p q :
+ (n <=? m) = true ->
+ (p <=? q) = true ->
+ (n + p <=? m + q) = true.
 Proof.
-  intros. apply Zle_imp_le_bool. apply Zplus_le_compat. apply Zle_bool_imp_le. assumption.
-  apply Zle_bool_imp_le. assumption.
+ rewrite !Z.leb_le. apply Z.add_le_mono.
 Qed.
 
-Lemma Zone_pos : Zle_bool 1 0 = false.
+Lemma Zone_pos : 1 <=? 0 = false.
 Proof.
-  reflexivity.
+ reflexivity.
 Qed.
 
-Lemma Zone_min_pos : forall n:Z, Zle_bool n 0 = false -> Zle_bool 1 n = true.
+Lemma Zone_min_pos n : (n <=? 0) = false -> (1 <=? n) = true.
 Proof.
-  intros x; intros. apply Zle_imp_le_bool. change (Zsucc 0 <= x) in |- *. apply Zgt_le_succ. generalize H.
-  unfold Zle_bool, Zgt in |- *. case (x ?= 0). intro H0. discriminate H0.
-  intro H0. discriminate H0.
-  reflexivity.
+ rewrite Z.leb_le, Z.leb_gt. apply Z.le_succ_l.
 Qed.
 
 (** Properties in term of [iff] *)
 
-Lemma Zle_is_le_bool : forall n m:Z, (n <= m) <-> Zle_bool n m = true.
+Lemma Zle_is_le_bool n m : (n <= m) <-> (n <=? m) = true.
 Proof.
-  intros. split. intro. apply Zle_imp_le_bool. assumption.
-  intro. apply Zle_bool_imp_le. assumption.
+ symmetry. apply Z.leb_le.
 Qed.
 
-Lemma Zge_is_le_bool : forall n m:Z, (n >= m) <-> Zle_bool m n = true.
+Lemma Zge_is_le_bool n m : (n >= m) <-> (m <=? n) = true.
 Proof.
-  intros. split. intro. apply Zle_imp_le_bool. apply Zge_le. assumption.
-  intro. apply Zle_ge. apply Zle_bool_imp_le. assumption.
+ Z.swap_greater. symmetry. apply Z.leb_le.
 Qed.
 
-Lemma Zlt_is_lt_bool : forall n m:Z, (n < m) <-> Zlt_bool n m = true.
+Lemma Zlt_is_lt_bool n m : (n < m) <-> (n <? m) = true.
 Proof.
-intros n m; unfold Zlt_bool, Zlt.
-destruct (n ?= m); simpl; split; now intro.
+ symmetry. apply Z.ltb_lt.
 Qed.
 
-Lemma Zgt_is_gt_bool : forall n m:Z, (n > m) <-> Zgt_bool n m = true.
+Lemma Zgt_is_gt_bool n m : (n > m) <-> (n >? m) = true.
 Proof.
-intros n m; unfold Zgt_bool, Zgt.
-destruct (n ?= m); simpl; split; now intro.
+ Z.swap_greater. rewrite Z.gtb_ltb. symmetry. apply Z.ltb_lt.
 Qed.
 
-Lemma Zlt_is_le_bool :
-  forall n m:Z, (n < m) <-> Zle_bool n (m - 1) = true.
+Lemma Zlt_is_le_bool n m : (n < m) <-> (n <=? m - 1) = true.
 Proof.
-  intros x y. split. intro. apply Zle_imp_le_bool. apply Zlt_succ_le. rewrite (Zsucc_pred y) in H.
-  assumption.
-  intro. rewrite (Zsucc_pred y). apply Zle_lt_succ. apply Zle_bool_imp_le. assumption.
+ rewrite Z.leb_le. apply Z.lt_le_pred.
 Qed.
 
-Lemma Zgt_is_le_bool :
-  forall n m:Z, (n > m) <-> Zle_bool m (n - 1) = true.
+Lemma Zgt_is_le_bool n m : (n > m) <-> (m <=? n - 1) = true.
 Proof.
-  intros x y. apply iff_trans with (y < x). split. exact (Zgt_lt x y).
-  exact (Zlt_gt y x).
-  exact (Zlt_is_le_bool y x).
+ Z.swap_greater. rewrite Z.leb_le. apply Z.lt_le_pred.
 Qed.
 
-Lemma Zeq_is_eq_bool : forall x y, x = y <-> Zeq_bool x y = true.
+(** Properties of the deprecated [Zeq_bool] *)
+
+Lemma Zeq_is_eq_bool x y : x = y <-> Zeq_bool x y = true.
 Proof.
-  intros; unfold Zeq_bool.
-  generalize (Zcompare_Eq_iff_eq x y); destruct Zcompare; intuition;
-   try discriminate.
+ unfold Zeq_bool.
+ rewrite <- Z.compare_eq_iff. destruct Z.compare; now split.
 Qed.
 
-Lemma Zeq_bool_eq : forall x y, Zeq_bool x y = true -> x = y.
+Lemma Zeq_bool_eq x y : Zeq_bool x y = true -> x = y.
 Proof.
-  intros x y H; apply <- Zeq_is_eq_bool; auto.
+ apply Zeq_is_eq_bool.
 Qed.
 
-Lemma Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y.
+Lemma Zeq_bool_neq x y : Zeq_bool x y = false -> x <> y.
 Proof.
-  unfold Zeq_bool; red ; intros; subst.
-  rewrite Zcompare_refl in H.
-  discriminate.
+ rewrite Zeq_is_eq_bool; now destruct Zeq_bool.
 Qed.
 
-Lemma Zeq_bool_if : forall x y, if Zeq_bool x y then x=y else x<>y.
+Lemma Zeq_bool_if 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
+ generalize (Zeq_bool_eq x y) (Zeq_bool_neq x y).
+ destruct Zeq_bool; auto.
+Qed.
diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
index ae5302ee..20e1b006 100644
--- a/theories/ZArith/Zcompare.v
+++ b/theories/ZArith/Zcompare.v
@@ -1,387 +1,91 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $$ i*)
+(** Binary Integers : results about Zcompare *)
+(** Initial author: Pierre Crégut (CNET, Lannion, France *)
 
-(**********************************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
-(**********************************************************************)
+(** THIS FILE IS DEPRECATED.
+    It is now almost entirely made of compatibility formulations
+    for results already present in BinInt.Z. *)
 
-Require Export BinPos.
-Require Export BinInt.
-Require Import Lt.
-Require Import Gt.
-Require Import Plus.
-Require Import Mult.
+Require Export BinPos BinInt.
+Require Import Lt Gt Plus Mult. (* Useless now, for compatibility only *)
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (***************************)
 (** * Comparison on integers *)
 
-Lemma Zcompare_refl : forall n:Z, (n ?= n) = Eq.
-Proof.
-  intro x; destruct x as [| p| p]; simpl in |- *;
-    [ reflexivity | apply Pcompare_refl | rewrite Pcompare_refl; reflexivity ].
-Qed.
-
-Lemma Zcompare_Eq_eq : forall n m:Z, (n ?= m) = Eq -> n = m.
-Proof.
-  intros x y; destruct x as [| x'| x']; destruct y as [| y'| y']; simpl in |- *;
-    intro H; reflexivity || (try discriminate H);
-      [ rewrite (Pcompare_Eq_eq x' y' H); reflexivity
-	| rewrite (Pcompare_Eq_eq x' y');
-	  [ reflexivity
-	    | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ].
-Qed.
-
-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 ]
- end.
-
-Lemma Zcompare_Eq_iff_eq : forall n m:Z, (n ?= m) = Eq <-> n = m.
-Proof.
-  intros x y; split; intro E;
-    [ apply Zcompare_Eq_eq; assumption | rewrite E; apply Zcompare_refl ].
-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.
-Qed.
-
 Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
-Proof.
-  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.
+Proof Z.gt_lt_iff.
 
+Lemma Zcompare_antisym n m : CompOpp (n ?= m) = (m ?= n).
+Proof eq_sym (Z.compare_antisym n m).
 
 (** * 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.
+Proof Z.lt_trans.
 
 Lemma Zcompare_Gt_trans :
   forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
 Proof.
-  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.
+ intros n m p. change (n > m -> m > p -> n > p).
+ Z.swap_greater. intros. now transitivity m.
 Qed.
 
 (** * Comparison and opposite *)
 
-Lemma Zcompare_opp : forall n m:Z, (n ?= m) = (- m ?= - n).
+Lemma Zcompare_opp n m : (n ?= m) = (- m ?= - n).
 Proof.
-  intros x y; case x; case y; simpl in |- *; auto with arith; intros;
-    rewrite <- ZC4; trivial with arith.
+ symmetry. apply Z.compare_opp.
 Qed.
 
-Hint Local Resolve Pcompare_refl.
-
 (** * Comparison first-order specification *)
 
-Lemma Zcompare_Gt_spec :
-  forall n m:Z, (n ?= m) = Gt ->  exists h : positive, n + - m = Zpos h.
+Lemma Zcompare_Gt_spec n m : (n ?= m) = Gt ->  exists h, n + - m = Zpos h.
 Proof.
-  intros x y; case x; case y;
-    [ simpl in |- *; intros H; discriminate H
-      | simpl in |- *; intros p H; discriminate H
-      | intros p H; exists p; simpl in |- *; auto with arith
-      | intros p H; exists p; simpl in |- *; auto with arith
-      | intros q p H; exists (p - q)%positive; unfold Zplus, Zopp in |- *;
-	unfold Zcompare in H; rewrite H; trivial with arith
-      | intros q p H; exists (p + q)%positive; simpl in |- *; trivial with arith
-      | simpl in |- *; intros p H; discriminate H
-      | simpl in |- *; intros q p H; discriminate H
-      | unfold Zcompare in |- *; intros q p; rewrite <- ZC4; intros H;
-	exists (q - p)%positive; simpl in |- *; rewrite (ZC1 q p H);
-	  trivial with arith ].
+ rewrite Z.compare_sub. unfold Z.sub.
+ destruct (n+-m) as [|p|p]; try discriminate. now exists p.
 Qed.
 
 (** * Comparison and addition *)
 
-Lemma weaken_Zcompare_Zplus_compatible :
-  (forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m)) ->
-  forall n m p:Z, (p + n ?= p + m) = (n ?= m).
+Lemma Zcompare_plus_compat n m p : (p + n ?= p + m) = (n ?= m).
 Proof.
-  intros H x y z; destruct z;
-    [ reflexivity
-      | apply H
-      | rewrite (Zcompare_opp x y); rewrite Zcompare_opp;
-	do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg;
-	  apply H ].
+ apply Z.add_compare_mono_l.
 Qed.
 
-Hint Local Resolve ZC4.
-
-Lemma weak_Zcompare_Zplus_compatible :
-  forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m).
-Proof.
-  intros x y z; case x; case y; simpl in |- *; auto with arith;
-    [ intros p; apply nat_of_P_lt_Lt_compare_complement_morphism; apply ZL17
-      | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
-	apply nat_of_P_gt_Gt_compare_complement_morphism;
-	  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;
-	  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
-	  | apply nat_of_P_lt_Lt_compare_complement_morphism;
-	    do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
-	      apply nat_of_P_lt_Lt_compare_morphism with (1 := E)
-	  | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
-	    do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
-	      exact (nat_of_P_gt_Gt_compare_morphism q p E) ]
-      | intros p q; ElimPcompare z p; intros E; rewrite E; auto with arith;
-	apply nat_of_P_gt_Gt_compare_complement_morphism;
-	  rewrite nat_of_P_minus_morphism;
-	    [ unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-	      [ apply ZL16 | apply ZL17 ]
-	      | assumption ]
-      | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
-	simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-	  rewrite nat_of_P_minus_morphism; [ apply ZL16 | assumption ]
-      | intros p q; ElimPcompare z q; intros E; rewrite E; auto with arith;
-	simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-	  rewrite nat_of_P_minus_morphism;
-	    [ 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;
-	  rewrite E2; auto with arith;
-	    [ absurd ((q ?= p)%positive Eq = Lt);
-	      [ rewrite <- (Pcompare_Eq_eq z q E0);
-		rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
-		  discriminate
-		| assumption ]
-	      | absurd ((q ?= p)%positive Eq = Gt);
-		[ rewrite <- (Pcompare_Eq_eq z q E0);
-		  rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
-		    discriminate
-		  | assumption ]
-	      | absurd ((z ?= p)%positive Eq = Lt);
-		[ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
-		  rewrite (Pcompare_refl q); discriminate
-		  | assumption ]
-	      | absurd ((z ?= p)%positive Eq = Lt);
-		[ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
-		  | assumption ]
-	      | absurd ((z ?= p)%positive Eq = Gt);
-		[ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
-		  rewrite (Pcompare_refl q); discriminate
-		  | assumption ]
-	      | absurd ((z ?= p)%positive Eq = Gt);
-		[ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
-		  | assumption ]
-	      | absurd ((z ?= q)%positive Eq = Lt);
-		[ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
-		  rewrite (Pcompare_refl p); discriminate
-		  | assumption ]
-	      | absurd ((p ?= q)%positive Eq = Gt);
-		[ rewrite <- (Pcompare_Eq_eq z p E1); rewrite E0; discriminate
-		  | apply ZC2; assumption ]
-	      | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2);
-		rewrite (Pcompare_refl (p - z)); auto with arith
-	      | simpl in |- *; rewrite <- ZC4;
-		apply nat_of_P_gt_Gt_compare_complement_morphism;
-		  rewrite nat_of_P_minus_morphism;
-		    [ rewrite nat_of_P_minus_morphism;
-		      [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
-			rewrite le_plus_minus_r;
-			  [ rewrite le_plus_minus_r;
-			    [ apply nat_of_P_lt_Lt_compare_morphism; assumption
-			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-				assumption ]
-			    | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-			      assumption ]
-			| apply ZC2; assumption ]
-		      | apply ZC2; assumption ]
-	      | simpl in |- *; rewrite <- ZC4;
-		apply nat_of_P_lt_Lt_compare_complement_morphism;
-		  rewrite nat_of_P_minus_morphism;
-		    [ rewrite nat_of_P_minus_morphism;
-		      [ apply plus_lt_reg_l with (p := nat_of_P z);
-			rewrite le_plus_minus_r;
-			  [ rewrite le_plus_minus_r;
-			    [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
-			      assumption
-			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-				assumption ]
-			    | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-			      assumption ]
-			| apply ZC2; assumption ]
-		      | apply ZC2; assumption ]
-	      | absurd ((z ?= q)%positive Eq = Lt);
-		[ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
-		  | assumption ]
-	      | absurd ((q ?= p)%positive Eq = Lt);
-		[ cut ((q ?= p)%positive Eq = Gt);
-		  [ intros E; rewrite E; discriminate
-		    | apply nat_of_P_gt_Gt_compare_complement_morphism;
-		      unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-			  | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
-		  | assumption ]
-	      | absurd ((z ?= q)%positive Eq = Gt);
-		[ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
-		  rewrite (Pcompare_refl p); discriminate
-		  | assumption ]
-	      | absurd ((z ?= q)%positive Eq = Gt);
-		[ rewrite (Pcompare_Eq_eq z p E1); rewrite ZC1;
-		  [ discriminate | assumption ]
-		  | assumption ]
-	      | absurd ((z ?= q)%positive Eq = Gt);
-		[ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
-		  | assumption ]
-	      | absurd ((q ?= p)%positive Eq = Gt);
-		[ rewrite ZC1;
-		  [ discriminate
-		    | apply nat_of_P_gt_Gt_compare_complement_morphism;
-		      unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-			  | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
-		  | assumption ]
-	      | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); apply Pcompare_refl
-	      | simpl in |- *; apply nat_of_P_gt_Gt_compare_complement_morphism;
-		unfold gt in |- *; rewrite nat_of_P_minus_morphism;
-		  [ rewrite nat_of_P_minus_morphism;
-		    [ apply plus_lt_reg_l with (p := nat_of_P p);
-		      rewrite le_plus_minus_r;
-			[ 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;
-				assumption
-			      | apply lt_le_weak; 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 ]
-		      | assumption ]
-		    | assumption ]
-	      | simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-		rewrite nat_of_P_minus_morphism;
-		  [ rewrite nat_of_P_minus_morphism;
-		    [ apply plus_lt_reg_l with (p := nat_of_P q);
-		      rewrite le_plus_minus_r;
-			[ 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 ZC1; assumption
-			      | apply lt_le_weak; 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 ]
-		      | assumption ]
-		    | assumption ] ] ].
-Qed.
-
-Lemma Zcompare_plus_compat : forall n m p:Z, (p + n ?= p + m) = (n ?= m).
+Lemma Zplus_compare_compat (r:comparison) (n m p q:Z) :
+  (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
 Proof.
-  exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible).
+ rewrite (Z.compare_sub n), (Z.compare_sub p), (Z.compare_sub (n+p)).
+ unfold Z.sub. rewrite Z.opp_add_distr. rewrite Z.add_shuffle1.
+ destruct (n+-m), (p+-q); simpl; intros; now subst.
 Qed.
 
-Lemma Zplus_compare_compat :
-  forall (r:comparison) (n m p q:Z),
-    (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
+Lemma Zcompare_succ_Gt n : (Z.succ n ?= n) = Gt.
 Proof.
-  intros r x y z t; case r;
-    [ intros H1 H2; elim (Zcompare_Eq_iff_eq x y); elim (Zcompare_Eq_iff_eq z t);
-      intros H3 H4 H5 H6; rewrite H3;
-	[ rewrite H5;
-	  [ elim (Zcompare_Eq_iff_eq (y + t) (y + t)); auto with arith
-	    | auto with arith ]
-	  | auto with arith ]
-      | intros H1 H2; elim (Zcompare_Gt_Lt_antisym (y + t) (x + z)); intros H3 H4;
-	apply H3; apply Zcompare_Gt_trans with (m := y + z);
-	  [ rewrite Zcompare_plus_compat; elim (Zcompare_Gt_Lt_antisym t z);
-	    auto with arith
-	    | do 2 rewrite <- (Zplus_comm z); rewrite Zcompare_plus_compat;
-	      elim (Zcompare_Gt_Lt_antisym y x); auto with arith ]
-      | intros H1 H2; apply Zcompare_Gt_trans with (m := x + t);
-	[ rewrite Zcompare_plus_compat; assumption
-	  | do 2 rewrite <- (Zplus_comm t); rewrite Zcompare_plus_compat;
-	    assumption ] ].
+ apply Z.lt_gt. apply Z.lt_succ_diag_r.
 Qed.
 
-Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt.
+Lemma Zcompare_Gt_not_Lt n m : (n ?= m) = Gt <-> (n ?= m+1) <> Lt.
 Proof.
-  intro x; unfold Zsucc in |- *; pattern x at 2 in |- *;
-    rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat;
-      reflexivity.
-Qed.
-
-Lemma Zcompare_Gt_not_Lt : forall n m:Z, (n ?= m) = Gt <-> (n ?= m + 1) <> Lt.
-Proof.
-  intros x y; split;
-    [ intro H; elim_compare x (y + 1);
-      [ intro H1; rewrite H1; discriminate
-	| intros H1; elim Zcompare_Gt_spec with (1 := H); intros h H2;
-	  absurd ((nat_of_P h > 0)%nat /\ (nat_of_P h < 1)%nat);
-	    [ unfold not in |- *; intros H3; elim H3; intros H4 H5;
-              absurd (nat_of_P h > 0)%nat;
-		[ unfold gt in |- *; apply le_not_lt; apply le_S_n; exact H5
-		  | assumption ]
-	      | split;
-		[ elim (ZL4 h); intros i H3; rewrite H3; apply gt_Sn_O
-		  | change (nat_of_P h < nat_of_P 1)%nat in |- *;
-		    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_opp_r; simpl in |- *; exact H1 ] ]
-	| intros H1; rewrite H1; discriminate ]
-      | intros H; elim_compare x (y + 1);
-	[ intros H1; elim (Zcompare_Eq_iff_eq x (y + 1)); intros H2 H3;
-	  rewrite (H2 H1); exact (Zcompare_succ_Gt y)
-	  | intros H1; absurd ((x ?= y + 1) = Lt); assumption
-	  | intros H1; apply Zcompare_Gt_trans with (m := Zsucc y);
-	    [ exact H1 | exact (Zcompare_succ_Gt y) ] ] ].
+ change (n > m <-> n >= m+1). Z.swap_greater. symmetry. apply Z.le_succ_l.
 Qed.
 
 (** * Successor and comparison *)
 
-Lemma Zcompare_succ_compat : forall n m:Z, (Zsucc n ?= Zsucc m) = (n ?= m).
+Lemma Zcompare_succ_compat n m : (Z.succ n ?= Z.succ m) = (n ?= m).
 Proof.
-  intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1);
-    rewrite Zcompare_plus_compat; auto with arith.
+ rewrite <- 2 Z.add_1_l. apply Zcompare_plus_compat.
 Qed.
 
 (** * Multiplication and comparison *)
@@ -389,28 +93,24 @@ Qed.
 Lemma Zcompare_mult_compat :
   forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
 Proof.
-  intros x; induction x as [p H| p H| ];
-    [ intros y z; cut (Zpos (xI p) = Zpos p + Zpos p + 1);
-      [ intros E; rewrite E; do 4 rewrite Zmult_plus_distr_l;
-	do 2 rewrite Zmult_1_l; apply Zplus_compare_compat;
-	  [ apply Zplus_compare_compat; apply H | trivial with arith ]
-	| simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
-      | intros y z; cut (Zpos (xO p) = Zpos p + Zpos p);
-	[ intros E; rewrite E; do 2 rewrite Zmult_plus_distr_l;
-	  apply Zplus_compare_compat; apply H
-	  | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
-      | intros y z; do 2 rewrite Zmult_1_l; trivial with arith ].
+ intros p [|n|n] [|m|m]; simpl; trivial; now rewrite Pos.mul_compare_mono_l.
 Qed.
 
+Lemma Zmult_compare_compat_l n m p:
+  p > 0 -> (n ?= m) = (p * n ?= p * m).
+Proof.
+ intros; destruct p; try discriminate.
+ symmetry. apply Zcompare_mult_compat.
+Qed.
 
-(** * Reverting [x ?= y] to trichotomy *)
-
-Lemma rename :
-  forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
+Lemma Zmult_compare_compat_r n m p :
+  p > 0 -> (n ?= m) = (n * p ?= m * p).
 Proof.
-  auto with arith.
+ intros; rewrite 2 (Zmult_comm _ p); now apply Zmult_compare_compat_l.
 Qed.
 
+(** * Relating [x ?= y] to [=], [<=], [<], [>=] or [>] *)
+
 Lemma Zcompare_elim :
   forall (c1 c2 c3:Prop) (n m:Z),
     (n = m -> c1) ->
@@ -421,11 +121,7 @@ Lemma Zcompare_elim :
                        | Gt => c3
                      end.
 Proof.
-  intros c1 c2 c3 x y; intros.
-  apply rename with (x := x ?= y); intro r; elim r;
-    [ intro; apply H; apply (Zcompare_Eq_eq x y); assumption
-      | unfold Zlt in H0; assumption
-      | unfold Zgt in H1; assumption ].
+ intros. case Z.compare_spec; trivial. now Z.swap_greater.
 Qed.
 
 Lemma Zcompare_eq_case :
@@ -436,26 +132,9 @@ Lemma Zcompare_eq_case :
                      | Gt => c3
                    end.
 Proof.
-  intros c1 c2 c3 x y; intros.
-  rewrite H0; rewrite Zcompare_refl.
-  assumption.
+ intros. subst. now rewrite Z.compare_refl.
 Qed.
 
-(** * Decompose an egality between two [?=] relations into 3 implications *)
-
-Lemma Zcompare_egal_dec :
-  forall n m p q:Z,
-    (n < m -> p < q) ->
-    ((n ?= m) = Eq -> (p ?= q) = Eq) ->
-    (n > m -> p > q) -> (n ?= m) = (p ?= q).
-Proof.
-  intros x1 y1 x2 y2.
-  unfold Zgt in |- *; unfold Zlt in |- *; case (x1 ?= y1); case (x2 ?= y2);
-    auto with arith; symmetry  in |- *; auto with arith.
-Qed.
-
-(** * Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)
-
 Lemma Zle_compare :
   forall n m:Z,
     n <= m -> match n ?= m with
@@ -464,7 +143,7 @@ Lemma Zle_compare :
 		| Gt => False
               end.
 Proof.
-  intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith.
+  intros. case Z.compare_spec; trivial; Z.order.
 Qed.
 
 Lemma Zlt_compare :
@@ -475,8 +154,7 @@ Lemma Zlt_compare :
               | Gt => False
             end.
 Proof.
-  intros x y; unfold Zlt in |- *; elim (x ?= y); intros;
-    discriminate || trivial with arith.
+  intros x y H; now rewrite H.
 Qed.
 
 Lemma Zge_compare :
@@ -487,7 +165,7 @@ Lemma Zge_compare :
 		| Gt => True
               end.
 Proof.
-  intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith.
+  intros. now case Z.compare_spec.
 Qed.
 
 Lemma Zgt_compare :
@@ -498,26 +176,23 @@ Lemma Zgt_compare :
                | Gt => True
              end.
 Proof.
-  intros x y; unfold Zgt in |- *; elim (x ?= y); intros;
-    discriminate || trivial with arith.
+  intros x y H; now rewrite H.
 Qed.
 
-(*********************)
-(** * Other properties *)
+(** Compatibility notations *)
 
-Lemma Zmult_compare_compat_l :
-  forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
-Proof.
-  intros x y z H; destruct z.
-  discriminate H.
-  rewrite Zcompare_mult_compat; reflexivity.
-  discriminate H.
-Qed.
-
-Lemma Zmult_compare_compat_r :
-  forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p).
-Proof.
-  intros x y z H; rewrite (Zmult_comm x z); rewrite (Zmult_comm y z);
-    apply Zmult_compare_compat_l; assumption.
-Qed.
+Notation Zcompare_refl := Z.compare_refl (only parsing).
+Notation Zcompare_Eq_eq := Z.compare_eq (only parsing).
+Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (only parsing).
+Notation Zcompare_spec := Z.compare_spec (only parsing).
+Notation Zmin_l := Z.min_l (only parsing).
+Notation Zmin_r := Z.min_r (only parsing).
+Notation Zmax_l := Z.max_l (only parsing).
+Notation Zmax_r := Z.max_r (only parsing).
+Notation Zabs_eq := Z.abs_eq (only parsing).
+Notation Zabs_non_eq := Z.abs_neq (only parsing).
+Notation Zsgn_0 := Z.sgn_null (only parsing).
+Notation Zsgn_1 := Z.sgn_pos (only parsing).
+Notation Zsgn_m1 := Z.sgn_neg (only parsing).
 
+(** Not kept: Zcompare_egal_dec *)
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index ca72f8a8..5a2c3cc3 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zcomplements.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import ZArithRing.
 Require Import ZArith_base.
 Require Export Omega.
@@ -18,29 +16,7 @@ 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}.
-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.
+Notation two_or_two_plus_one := Z_modulo_2 (only parsing).
 
 (**********************************************************************)
 (** The biggest power of 2 that is stricly less than [a]
@@ -58,31 +34,14 @@ Fixpoint floor_pos (a:positive) : positive :=
 Definition floor (a:positive) := Zpos (floor_pos a).
 
 Lemma floor_gt0 : forall p:positive, floor p > 0.
-Proof.
-  intro.
-  compute in |- *.
-  trivial.
-Qed.
+Proof. reflexivity. Qed.
 
 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 (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.
+ unfold floor. induction p; simpl.
+ - rewrite !Z.pos_xI, (Z.pos_xO (xO _)), Z.pos_xO. omega.
+ - rewrite (Z.pos_xO (xO _)), (Z.pos_xO p), Z.pos_xO. omega.
+ - omega.
 Qed.
 
 (**********************************************************************)
@@ -90,41 +49,39 @@ Qed.
 
 Theorem Z_lt_abs_rec :
   forall P:Z -> Set,
-    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+    (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
     forall n:Z, P n.
 Proof.
   intros P HP p.
   set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
-  cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
+  cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
   elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
   unfold Q in |- *; clear Q; intros.
-  apply pair; apply HP.
-  rewrite Zabs_eq; auto; intros.
-  elim (H (Zabs m)); intros; auto with zarith.
+  split; apply HP.
+  rewrite Z.abs_eq; auto; intros.
+  elim (H (Z.abs m)); intros; auto with zarith.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-  rewrite Zabs_non_eq; auto with zarith.
-  rewrite Zopp_involutive; intros.
-  elim (H (Zabs m)); intros; auto with zarith.
+  rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
+  elim (H (Z.abs m)); intros; auto with zarith.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
 Qed.
 
 Theorem Z_lt_abs_induction :
   forall P:Z -> Prop,
-    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+    (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
     forall n:Z, P n.
 Proof.
   intros P HP p.
   set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
-  cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
+  cut (Q (Z.abs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
   elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
   unfold Q in |- *; clear Q; intros.
   split; apply HP.
-  rewrite Zabs_eq; auto; intros.
-  elim (H (Zabs m)); intros; auto with zarith.
+  rewrite Z.abs_eq; auto; intros.
+  elim (H (Z.abs m)); intros; auto with zarith.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-  rewrite Zabs_non_eq; auto with zarith.
-  rewrite Zopp_involutive; intros.
-  elim (H (Zabs m)); intros; auto with zarith.
+  rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
+  elim (H (Z.abs m)); intros; auto with zarith.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
 Qed.
 
@@ -134,25 +91,12 @@ Lemma Zcase_sign :
   forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
 Proof.
   intros x P Hzero Hpos Hneg.
-  induction  x as [| p| p].
-  apply Hzero; trivial.
-  apply Hpos; apply Zorder.Zgt_pos_0.
-  apply Hneg; apply Zorder.Zlt_neg_0.
+  destruct x; [apply Hzero|apply Hpos|apply Hneg]; easy.
 Qed.
 
-Lemma sqr_pos : forall n:Z, n * n >= 0.
+Lemma sqr_pos n : n * n >= 0.
 Proof.
-  intro x.
-  apply (Zcase_sign x (x * x >= 0)).
-  intros H; rewrite H; omega.
-  intros H; replace 0 with (0 * 0).
-  apply Zmult_ge_compat; omega.
-  omega.
-  intros H; replace 0 with (0 * 0).
-  replace (x * x) with (- x * - x).
-  apply Zmult_ge_compat; omega.
-  ring.
-  omega.
+ Z.swap_greater. apply Z.square_nonneg.
 Qed.
 
 (**********************************************************************)
@@ -167,7 +111,7 @@ Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
   end.
 
 Definition Zlength := Zlength_aux 0.
-Implicit Arguments Zlength [A].
+Arguments Zlength [A] l.
 
 Section Zlength_properties.
 
@@ -175,38 +119,33 @@ Section Zlength_properties.
 
   Implicit Type l : list A.
 
-  Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
+  Lemma Zlength_correct 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)).
-    simple induction l.
-    simpl in |- *; auto with zarith.
-    intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
-    simpl in |- *; rewrite H; auto with zarith.
-    unfold Zlength in |- *; intros; rewrite H; auto.
+    assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)).
+    clear l. induction l.
+    auto with zarith.
+    intros. simpl length; simpl Zlength_aux.
+     rewrite IHl, Nat2Z.inj_succ; auto with zarith.
+    unfold Zlength. now rewrite H.
   Qed.
 
   Lemma Zlength_nil : Zlength (A:=A) nil = 0.
-  Proof.
-    auto.
-  Qed.
+  Proof. reflexivity. Qed.
 
-  Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
+  Lemma Zlength_cons (x:A) l : Zlength (x :: l) = Z.succ (Zlength l).
   Proof.
-    intros; do 2 rewrite Zlength_correct.
-    simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
+    intros. now rewrite !Zlength_correct, <- Nat2Z.inj_succ.
   Qed.
 
-  Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
+  Lemma Zlength_nil_inv l : Zlength l = 0 -> l = nil.
   Proof.
-    intro l; rewrite Zlength_correct.
-    case l; auto.
-    intros x l'; simpl (length (x :: l')) in |- *.
-    rewrite Znat.inj_S.
-    intros; exfalso; generalize (Zle_0_nat (length l')); omega.
+    rewrite Zlength_correct.
+    destruct l as [|x l]; auto.
+    now rewrite <- Nat2Z.inj_0, Nat2Z.inj_iff.
   Qed.
 
 End Zlength_properties.
 
-Implicit Arguments Zlength_correct [A].
-Implicit Arguments Zlength_cons [A].
-Implicit Arguments Zlength_nil_inv [A].
+Arguments Zlength_correct [A] l.
+Arguments Zlength_cons [A] x l.
+Arguments Zlength_nil_inv [A] l _.
diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v
index c43b241d..ff1d96df 100644
--- a/theories/ZArith/Zdigits.v
+++ b/theories/ZArith/Zdigits.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zdigits.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Bit vectors interpreted as integers.
     Contribution by Jean Duprat (ENS Lyon). *)
 
@@ -47,17 +45,17 @@ Section VALUE_OF_BOOLEAN_VECTORS.
     exact 0%Z.
 
     inversion H0.
-    exact (bit_value a + 2 * H H2)%Z.
+    exact (bit_value h + 2 * H H2)%Z.
   Defined.
 
   Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
   Proof.
     simple induction n; intros.
     inversion H.
-    exact (- bit_value a)%Z.
+    exact (- bit_value h)%Z.
 
     inversion H0.
-    exact (bit_value a + 2 * H H2)%Z.
+    exact (bit_value h + 2 * H H2)%Z.
   Defined.
 
 End VALUE_OF_BOOLEAN_VECTORS.
@@ -136,7 +134,7 @@ Section Z_BRIC_A_BRAC.
 
   Lemma binary_value_Sn :
     forall (n:nat) (b:bool) (bv:Bvector n),
-      binary_value (S n) (Vcons bool b n bv) =
+      binary_value (S n) ( b :: bv) =
       (bit_value b + 2 * binary_value n bv)%Z.
   Proof.
     intros; auto.
@@ -221,7 +219,7 @@ Section Z_BRIC_A_BRAC.
     destruct (Zeven.Zeven_odd_dec z); intros.
     rewrite <- Zeven.Zeven_div2; auto.
 
-    generalize (Zeven.Zodd_div2 z H z0); omega.
+    generalize (Zeven.Zodd_div2 z z0); omega.
   Qed.
 
   Lemma Z_to_two_compl_Sn_z :
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index df22371e..314f696a 100644
--- a/theories/ZArith/Zdiv.v
+++ b/theories/ZArith/Zdiv.v
@@ -1,200 +1,57 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zdiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** * Euclidean Division *)
 
-(* Contribution by Claude Marché and Xavier Urbain *)
-
-(** Euclidean Division
-
-    Defines first of function that allows Coq to normalize.
-    Then only after proves the main required property.
-*)
+(** Initial Contribution by Claude Marché and Xavier Urbain *)
 
 Require Export ZArith_base.
-Require Import Zbool.
-Require Import Omega.
-Require Import ZArithRing.
-Require Import Zcomplements.
-Require Export Setoid.
-Open Local Scope Z_scope.
-
-(** * Definitions of Euclidian operations *)
-
-(** 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) : Z * Z :=
-  match a with
-    | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
-    | xO a' =>
-      let (q, r) := Zdiv_eucl_POS a' b in
-	let r' := 2 * r in
-	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
-    | xI a' =>
-      let (q, r) := Zdiv_eucl_POS a' b in
-	let r' := 2 * r + 1 in
-	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
-  end.
-
-
-(** Euclidean division of integers.
-
-    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 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 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).
-*)
+Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms.
+Local Open Scope Z_scope.
 
-(* 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)
-   on negative numbers.
+(** The definition of the division is now in [BinIntDef], the initial
+    specifications and properties are in [BinInt]. *)
 
-   * 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).
+Notation Zdiv_eucl_POS := Z.pos_div_eucl (only parsing).
+Notation Zdiv_eucl := Z.div_eucl (only parsing).
+Notation Zdiv := Z.div (only parsing).
+Notation Zmod := Z.modulo (only parsing).
 
-   * Another solution is to always pick a non-negative remainder:
-     a=b*q+r with 0 <= r < |b|
-*)
-
-Definition Zdiv_eucl (a b:Z) : Z * Z :=
-  match a, b with
-    | Z0, _ => (0, 0)
-    | _, Z0 => (0, 0)
-    | Zpos a', Zpos _ => Zdiv_eucl_POS a' b
-    | Zneg a', Zpos _ =>
-      let (q, r) := Zdiv_eucl_POS a' b in
-	match r with
-	  | Z0 => (- q, 0)
-	  | _ => (- (q + 1), b - r)
-	end
-    | Zneg a', Zneg b' => let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r)
-    | Zpos a', Zneg b' =>
-      let (q, r) := Zdiv_eucl_POS a' (Zpos b') in
-	match r with
-	  | Z0 => (- q, 0)
-	  | _ => (- (q + 1), b + r)
-	end
-  end.
-
-
-(** Division and modulo are projections of [Zdiv_eucl] *)
-
-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.
-
-(** Syntax *)
-
-Infix "/" := Zdiv : Z_scope.
-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).
+Notation Zdiv_eucl_eq := Z.div_eucl_eq (only parsing).
+Notation Z_div_mod_eq_full := Z.div_mod (only parsing).
+Notation Zmod_POS_bound := Z.pos_div_eucl_bound (only parsing).
+Notation Zmod_pos_bound := Z.mod_pos_bound (only parsing).
+Notation Zmod_neg_bound := Z.mod_neg_bound (only parsing).
 
-Eval compute in (Zdiv_eucl 7 (-3)).
+(** * Main division theorems *)
 
-Eval compute in (Zdiv_eucl (-7) (-3)).
-
-*)
-
-
-(** * Main division theorem *)
-
-(** First a lemma for two positive arguments *)
+(** NB: many things are stated twice for compatibility reasons *)
 
 Lemma Z_div_mod_POS :
   forall b:Z,
     b > 0 ->
     forall a:positive,
-      let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b.
+      let (q, r) := Z.pos_div_eucl a b in Zpos a = b * q + r /\ 0 <= r < b.
 Proof.
-simple induction a; cbv beta iota delta [Zdiv_eucl_POS] in |- *;
-  fold Zdiv_eucl_POS in |- *; cbv zeta.
-
-intro p; case (Zdiv_eucl_POS p b); intros q r [H0 H1].
-generalize (Zgt_cases b (2 * r + 1)).
-case (Zgt_bool b (2 * r + 1));
- (rewrite BinInt.Zpos_xI; rewrite H0; split; [ ring | omega ]).
-
-intros p; case (Zdiv_eucl_POS p b); intros q r [H0 H1].
-generalize (Zgt_cases b (2 * r)).
-case (Zgt_bool b (2 * r)); rewrite BinInt.Zpos_xO;
- change (Zpos (xO p)) with (2 * Zpos p) in |- *; rewrite H0;
- (split; [ ring | omega ]).
-
-generalize (Zge_cases b 2).
-case (Zge_bool b 2); (intros; split; [ try ring | omega ]).
-omega.
+ intros b Hb a. Z.swap_greater.
+ generalize (Z.pos_div_eucl_eq a b Hb) (Z.pos_div_eucl_bound a b Hb).
+ destruct Z.pos_div_eucl. rewrite Z.mul_comm. auto.
 Qed.
 
-(** Then the usual situation of a positive [b] and no restriction on [a] *)
-
-Theorem Z_div_mod :
-  forall a b:Z,
-    b > 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ 0 <= r < b.
+Theorem Z_div_mod a b :
+  b > 0 ->
+  let (q, r) := Z.div_eucl a b in a = b * q + r /\ 0 <= r < b.
 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.
-  generalize (Z_div_mod_POS (Zpos p) H p0).
-  unfold Zdiv_eucl in |- *.
-  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.
+ Z.swap_greater. intros Hb.
+ assert (Hb' : b<>0) by (now destruct b).
+ generalize (Z.div_eucl_eq a b Hb') (Z.mod_pos_bound a b Hb).
+ unfold Z.modulo. destruct Z.div_eucl. auto.
 Qed.
 
 (** For stating the fully general result, let's give a short name
@@ -204,7 +61,7 @@ Definition Remainder r b :=  0 <= r < b \/ b < r <= 0.
 
 (** Another equivalent formulation: *)
 
-Definition Remainder_alt r b :=  Zabs r < Zabs b /\ Zsgn r <> - Zsgn b.
+Definition Remainder_alt r b :=  Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b.
 
 (* 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. *)
@@ -218,90 +75,44 @@ Hint Unfold Remainder.
 
 (** Now comes the fully general result about Euclidean division. *)
 
-Theorem Z_div_mod_full :
-  forall a b:Z,
-    b <> 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ Remainder r b.
+Theorem Z_div_mod_full a b :
+  b <> 0 ->
+  let (q, r) := Z.div_eucl a b in a = b * q + r /\ Remainder r b.
 Proof.
-  destruct b as [|b|b].
-  (* b = 0 *)
-  intro H; elim H; auto.
-  (* b > 0 *)
-  intros _.
-  assert (Zpos b > 0) by auto with zarith.
-  generalize (Z_div_mod a (Zpos b) H).
-  destruct Zdiv_eucl as (q,r); intuition; simpl; auto.
-  (* b < 0 *)
-  intros _.
-  assert (Zpos b > 0) by auto with zarith.
-  generalize (Z_div_mod a (Zpos b) H).
-  unfold Remainder.
-  destruct a as [|a|a].
-  (* a = 0 *)
-  simpl; intuition.
-  (* a > 0 *)
-  unfold Zdiv_eucl; destruct Zdiv_eucl_POS as (q,r).
-  destruct r as [|r|r]; [ | | omega with *].
-  rewrite <- Zmult_opp_comm; simpl Zopp; intuition.
-  rewrite <- Zmult_opp_comm; simpl Zopp.
-  rewrite Zmult_plus_distr_r; omega with *.
-  (* a < 0 *)
-  unfold Zdiv_eucl.
-  generalize (Z_div_mod_POS (Zpos b) H a).
-  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;
-   repeat rewrite Zmult_opp_comm; omega.
-  rewrite Zmult_opp_comm; omega with *.
+ intros Hb.
+ generalize (Z.div_eucl_eq a b Hb)
+  (Z.mod_pos_bound a b) (Z.mod_neg_bound a b).
+ unfold Z.modulo. destruct Z.div_eucl as (q,r).
+ intros EQ POS NEG.
+ split; auto.
+ red; destruct b.
+  now destruct Hb. left; now apply POS. right; now apply NEG.
 Qed.
 
 (** The same results as before, stated separately in terms of Zdiv and Zmod *)
 
-Lemma Z_mod_remainder : forall a b:Z, b<>0 -> Remainder (a mod b) b.
-Proof.
-  unfold Zmod; intros a b Hb; generalize (Z_div_mod_full a b Hb); auto.
-  destruct Zdiv_eucl; tauto.
-Qed.
-
-Lemma Z_mod_lt : forall a b:Z, b > 0 -> 0 <= a mod b < b.
+Lemma Z_mod_remainder a b : b<>0 -> Remainder (a mod b) b.
 Proof.
-  unfold Zmod; intros a b Hb; generalize (Z_div_mod a b Hb).
-  destruct Zdiv_eucl; tauto.
+  unfold Z.modulo; intros Hb; generalize (Z_div_mod_full a b Hb); auto.
+  destruct Z.div_eucl; tauto.
 Qed.
 
-Lemma Z_mod_neg : forall a b:Z, b < 0 -> b < a mod b <= 0.
-Proof.
-  unfold Zmod; intros a b Hb.
-  assert (Hb' : b<>0) by (auto with zarith).
-  generalize (Z_div_mod_full a b Hb').
-  destruct Zdiv_eucl.
-  unfold Remainder; intuition.
-Qed.
+Lemma Z_mod_lt a b : b > 0 -> 0 <= a mod b < b.
+Proof (fun Hb => Z.mod_pos_bound a b (Zgt_lt _ _ Hb)).
 
-Lemma Z_div_mod_eq_full : forall a b:Z, b <> 0 -> a = b*(a/b) + (a mod b).
-Proof.
-  unfold Zdiv, Zmod; intros a b Hb; generalize (Z_div_mod_full a b Hb).
-  destruct Zdiv_eucl; tauto.
-Qed.
+Lemma Z_mod_neg a b : b < 0 -> b < a mod b <= 0.
+Proof (Z.mod_neg_bound a b).
 
-Lemma Z_div_mod_eq : forall a b:Z, b > 0 -> a = b*(a/b) + (a mod b).
+Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b).
 Proof.
-  intros; apply Z_div_mod_eq_full; auto with zarith.
+  intros Hb; apply Z.div_mod; auto with zarith.
 Qed.
 
-Lemma Zmod_eq_full : forall a b:Z, b<>0 -> a mod b = a - (a/b)*b.
-Proof.
-  intros.
-  rewrite <- Zeq_plus_swap, Zplus_comm, Zmult_comm; symmetry.
-  apply Z_div_mod_eq_full; auto.
-Qed.
+Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b.
+Proof. intros. rewrite Z.mul_comm. now apply Z.mod_eq. Qed.
 
-Lemma Zmod_eq : forall a b:Z, b>0 -> a mod b = a - (a/b)*b.
-Proof.
-  intros.
-  rewrite <- Zeq_plus_swap, Zplus_comm, Zmult_comm; symmetry.
-  apply Z_div_mod_eq; auto.
-Qed.
+Lemma Zmod_eq a b : b>0 -> a mod b = a - (a/b)*b.
+Proof. intros. apply Zmod_eq_full. now destruct b. Qed.
 
 (** Existence theorem *)
 
@@ -309,89 +120,51 @@ Theorem Zdiv_eucl_exist : forall (b:Z)(Hb:b>0)(a:Z),
  {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
 Proof.
   intros b Hb a.
-  exists (Zdiv_eucl a b).
+  exists (Z.div_eucl a b).
   exact (Z_div_mod a b Hb).
 Qed.
 
-Implicit Arguments Zdiv_eucl_exist.
+Arguments Zdiv_eucl_exist : default implicits.
 
 
 (** Uniqueness theorems *)
 
-Theorem Zdiv_mod_unique :
- forall b q1 q2 r1 r2:Z,
-  0 <= r1 < Zabs b -> 0 <= r2 < Zabs b ->
+Theorem Zdiv_mod_unique b q1 q2 r1 r2 :
+  0 <= r1 < Z.abs b -> 0 <= r2 < Z.abs b ->
   b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
 Proof.
-intros b q1 q2 r1 r2 Hr1 Hr2 H.
-destruct (Z_eq_dec q1 q2) as [Hq|Hq].
+intros Hr1 Hr2 H. rewrite <- (Z.abs_sgn b), <- !Z.mul_assoc in H.
+destruct (Z.div_mod_unique (Z.abs b) (Z.sgn b * q1) (Z.sgn b * q2) r1 r2); auto.
 split; trivial.
-rewrite Hq in H; omega.
-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.
-apply Zmult_le_compat_l; auto with *.
-omega with *.
+apply Z.mul_cancel_l with (Z.sgn b); trivial.
+rewrite Z.sgn_null_iff, <- Z.abs_0_iff. destruct Hr1; Z.order.
 Qed.
 
 Theorem Zdiv_mod_unique_2 :
  forall b q1 q2 r1 r2:Z,
   Remainder r1 b -> Remainder r2 b ->
   b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
-Proof.
-unfold Remainder.
-intros b q1 q2 r1 r2 Hr1 Hr2 H.
-destruct (Z_eq_dec q1 q2) as [Hq|Hq].
-split; trivial.
-rewrite Hq in H; omega.
-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.
-apply Zmult_le_compat_l; auto with *.
-omega with *.
-Qed.
+Proof Z.div_mod_unique.
 
 Theorem Zdiv_unique_full:
  forall a b q r, Remainder r b ->
    a = b*q + r -> q = a/b.
-Proof.
-  intros.
-  assert (b <> 0) by (unfold Remainder in *; omega with *).
-  generalize (Z_div_mod_full a b H1).
-  unfold Zdiv; destruct Zdiv_eucl as (q',r').
-  intros (H2,H3); rewrite H2 in H0.
-  destruct (Zdiv_mod_unique_2 b q q' r r'); auto.
-Qed.
+Proof Z.div_unique.
 
 Theorem Zdiv_unique:
  forall a b q r, 0 <= r < b ->
    a = b*q + r -> q = a/b.
-Proof.
-  intros; eapply Zdiv_unique_full; eauto.
-Qed.
+Proof. intros; eapply Zdiv_unique_full; eauto. Qed.
 
 Theorem Zmod_unique_full:
  forall a b q r, Remainder r b ->
   a = b*q + r ->  r = a mod b.
-Proof.
-  intros.
-  assert (b <> 0) by (unfold Remainder in *; omega with *).
-  generalize (Z_div_mod_full a b H1).
-  unfold Zmod; destruct Zdiv_eucl as (q',r').
-  intros (H2,H3); rewrite H2 in H0.
-  destruct (Zdiv_mod_unique_2 b q q' r r'); auto.
-Qed.
+Proof Z.mod_unique.
 
 Theorem Zmod_unique:
  forall a b q r, 0 <= r < b ->
   a = b*q + r -> r = a mod b.
-Proof.
-  intros; eapply Zmod_unique_full; eauto.
-Qed.
+Proof. intros; eapply Zmod_unique_full; eauto. Qed.
 
 (** * Basic values of divisions and modulo. *)
 
@@ -415,70 +188,44 @@ Proof.
   destruct a; simpl; auto.
 Qed.
 
+Ltac zero_or_not a :=
+  destruct (Z.eq_dec a 0);
+  [subst; rewrite ?Zmod_0_l, ?Zdiv_0_l, ?Zmod_0_r, ?Zdiv_0_r;
+   auto with zarith|].
+
 Lemma Zmod_1_r: forall a, a mod 1 = 0.
-Proof.
-  intros; symmetry; apply Zmod_unique with a; auto with zarith.
-Qed.
+Proof. intros. zero_or_not a. apply Z.mod_1_r. Qed.
 
 Lemma Zdiv_1_r: forall a, a/1 = a.
-Proof.
-  intros; symmetry; apply Zdiv_unique with 0; auto with zarith.
-Qed.
+Proof. intros. zero_or_not a. apply Z.div_1_r. Qed.
 
 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.
-Proof.
-  intros; symmetry; apply Zdiv_unique with 1; auto with zarith.
-Qed.
+Proof Z.div_1_l.
 
 Lemma Zmod_1_l: forall a, 1 < a ->  1 mod a = 1.
-Proof.
-  intros; symmetry; apply Zmod_unique with 0; auto with zarith.
-Qed.
+Proof Z.mod_1_l.
 
 Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1.
-Proof.
-  intros; symmetry; apply Zdiv_unique_full with 0; auto with *; red; omega.
-Qed.
+Proof Z.div_same.
 
 Lemma Z_mod_same_full : forall a, a mod a = 0.
-Proof.
-  destruct a; intros; symmetry.
-  compute; auto.
-  apply Zmod_unique with 1; auto with *; omega with *.
-  apply Zmod_unique_full with 1; auto with *; red; omega with *.
-Qed.
+Proof. intros. zero_or_not a. apply Z.mod_same; auto. Qed.
 
 Lemma Z_mod_mult : forall a b, (a*b) mod b = 0.
-Proof.
-  intros a b; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; simpl; rewrite Zmod_0_r; auto.
-  symmetry; apply Zmod_unique_full with a; [ red; omega | ring ].
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_mul. auto. 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;
-   [ red; omega | ring].
-Qed.
+Proof Z.div_mul.
 
 (** * Order results about Zmod and Zdiv *)
 
 (* Division of positive numbers is positive. *)
 
 Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b.
-Proof.
-  intros.
-  rewrite (Z_div_mod_eq a b H) in H0.
-  assert (H1:=Z_mod_lt a b H).
-  destruct (Z_lt_le_dec (a/b) 0); auto.
-  assert (b*(a/b) <= -b).
-   replace (-b) with (b*-1); [ | ring].
-   apply Zmult_le_compat_l; auto with zarith.
-  omega.
-Qed.
+Proof. intros. apply Z.div_pos; auto with zarith. Qed.
 
 Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0.
 Proof.
@@ -489,366 +236,165 @@ Qed.
     the division is strictly decreasing. *)
 
 Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a.
-Proof.
-  intros. cut (b > 0); [ intro Hb | omega ].
-  generalize (Z_div_mod a b Hb).
-  cut (a >= 0); [ intro Ha | omega ].
-  generalize (Z_div_ge0 a b Hb Ha).
-  unfold Zdiv in |- *; case (Zdiv_eucl a b); intros q r H1 [H2 H3].
-  cut (a >= 2 * q -> q < a); [ intro h; apply h; clear h | intros; omega ].
-  apply Zge_trans with (b * q).
-  omega.
-  auto with zarith.
-Qed.
-
+Proof. intros. apply Z.div_lt; auto with zarith. Qed.
 
 (** A division of a small number by a bigger one yields zero. *)
 
 Theorem Zdiv_small: forall a b, 0 <= a < b -> a/b = 0.
-Proof.
-  intros a b H; apply sym_equal; apply Zdiv_unique with a; auto with zarith.
-Qed.
+Proof Z.div_small.
 
 (** Same situation, in term of modulo: *)
 
 Theorem Zmod_small: forall a n, 0 <= a < n -> a mod n = a.
-Proof.
-  intros a b H; apply sym_equal; apply Zmod_unique with 0; auto with zarith.
-Qed.
+Proof Z.mod_small.
 
 (** [Zge] is compatible with a positive division. *)
 
 Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c.
-Proof.
-  intros a b c cPos aGeb.
-  generalize (Z_div_mod_eq a c cPos).
-  generalize (Z_mod_lt a c cPos).
-  generalize (Z_div_mod_eq b c cPos).
-  generalize (Z_mod_lt b c cPos).
-  intros.
-  elim (Z_ge_lt_dec (a / c) (b / c)); trivial.
-  intro.
-  absurd (b - a >= 1).
-  omega.
-  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.
-  omega.
-  omega.
-  assert (c * 1 = c).
-  ring.
-  omega.
-Qed.
+Proof. intros. apply Zle_ge. apply Z.div_le_mono; auto with zarith. Qed.
 
 (** Same, with [Zle]. *)
 
 Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c.
-Proof.
-  intros a b c H H0.
-  apply Zge_le.
-  apply Z_div_ge; auto with *.
-Qed.
+Proof. intros. apply Z.div_le_mono; auto with zarith. Qed.
 
 (** With our choice of division, rounding of (a/b) is always done toward bottom: *)
 
 Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a.
-Proof.
-  intros a b H; generalize (Z_div_mod_eq a b H) (Z_mod_lt a b H); omega.
-Qed.
+Proof. intros. apply Z.mul_div_le; auto with zarith. Qed.
 
 Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a.
-Proof.
-  intros a b H.
-  generalize (Z_div_mod_eq_full a _ (Zlt_not_eq _ _ H)) (Z_mod_neg a _ H); omega.
-Qed.
+Proof. intros. apply Zle_ge. apply Z.mul_div_ge; auto with zarith. Qed.
 
 (** The previous inequalities are exact iff the modulo is zero. *)
 
 Lemma Z_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0.
-Proof.
-  intros; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst b; simpl in *; subst; auto.
-  generalize (Z_div_mod_eq_full a b Hb); omega.
-Qed.
+Proof. intros a b. zero_or_not b. rewrite Z.div_exact; auto. Qed.
 
 Lemma Z_div_exact_full_2 : forall a b:Z, b <> 0 -> a mod b = 0 -> a = b*(a/b).
-Proof.
-  intros; generalize (Z_div_mod_eq_full a b H); omega.
-Qed.
+Proof. intros; rewrite Z.div_exact; auto. Qed.
 
 (** A modulo cannot grow beyond its starting point. *)
 
 Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a.
-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.
-Qed.
+Proof. intros. apply Z.mod_le; auto. Qed.
 
 (** Some additionnal inequalities about Zdiv. *)
 
 Theorem Zdiv_lt_upper_bound:
   forall a b q, 0 < b -> a < q*b -> a/b < q.
-Proof.
-  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.
+Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_lt_upper_bound. Qed.
 
 Theorem Zdiv_le_upper_bound:
   forall a b q, 0 < b -> a <= q*b -> a/b <= q.
-Proof.
-  intros.
-  rewrite <- (Z_div_mult_full q b); auto with zarith.
-  apply Z_div_le; auto with zarith.
-Qed.
+Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_upper_bound. Qed.
 
 Theorem Zdiv_le_lower_bound:
   forall a b q, 0 < b -> q*b <= a -> q <= a/b.
-Proof.
-  intros.
-  rewrite <- (Z_div_mult_full q b); auto with zarith.
-  apply Z_div_le; auto with zarith.
-Qed.
+Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. 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.
-  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.
-  apply Zle_trans with (r * (p / r)); auto with zarith.
-  apply Zmult_le_compat_r; auto with zarith.
-  apply Zdiv_le_lower_bound; auto with zarith.
-  case (Z_mod_lt p r); auto with zarith.
-Qed.
+Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed.
 
 Theorem Zdiv_sgn: forall a b,
-  0 <= Zsgn (a/b) * Zsgn a * Zsgn b.
+  0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn 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 Zdiv_eucl_POS as (q,r); destruct r; omega with *.
+  generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl;
+  destruct Z.pos_div_eucl as (q,r); destruct r; omega with *.
 Qed.
 
 (** * Relations between usual operations and Zmod and Zdiv *)
 
 Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c.
-Proof.
-  intros; destruct (Z_eq_dec c 0) as [Hc|Hc].
-  subst; do 2 rewrite Zmod_0_r; auto.
-  symmetry; apply Zmod_unique_full with (a/c+b); auto with zarith.
-  red; generalize (Z_mod_lt a c)(Z_mod_neg a c); omega.
-  rewrite Zmult_plus_distr_r, Zmult_comm.
-  generalize (Z_div_mod_eq_full a c Hc); omega.
-Qed.
+Proof. intros. zero_or_not c. apply Z.mod_add; auto. Qed.
 
 Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b.
-Proof.
-  intro; symmetry.
-  apply Zdiv_unique_full with (a mod c); auto with zarith.
-  red; generalize (Z_mod_lt a c)(Z_mod_neg a c); omega.
-  rewrite Zmult_plus_distr_r, Zmult_comm.
-  generalize (Z_div_mod_eq_full a c H); omega.
-Qed.
+Proof Z.div_add.
 
 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.
-Qed.
+Proof Z.div_add_l.
 
 (** [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. *)
 
 Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b.
-Proof.
-  intros [|a|a] [|b|b]; try reflexivity; unfold Zdiv; simpl;
-  destruct (Zdiv_eucl_POS a (Zpos b)); destruct z0; try reflexivity.
-Qed.
+Proof. intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed.
 
 Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b).
-Proof.
-  intros; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; do 2 rewrite Zmod_0_r; auto.
-  intros; symmetry.
-  apply Zmod_unique_full with ((-a)/(-b)); auto.
-  generalize (Z_mod_remainder a b Hb); destruct 1; [right|left]; omega.
-  rewrite Zdiv_opp_opp.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a b Hb); ring.
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed.
 
 Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0.
-Proof.
-  intros; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; rewrite Zmod_0_r; auto.
-  rewrite Z_div_exact_full_2 with a b; auto.
-  replace (- (b * (a / b))) with (0 + - (a / b) * b).
-  rewrite Z_mod_plus_full; auto.
-  ring.
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed.
 
 Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 ->
  (-a) mod b = b - (a mod b).
-Proof.
-  intros.
-  assert (b<>0) by (contradict H; subst; rewrite Zmod_0_r; auto).
-  symmetry; apply Zmod_unique_full with (-1-a/b); auto.
-  generalize (Z_mod_remainder a b H0); destruct 1; [left|right]; omega.
-  rewrite Zmult_minus_distr_l.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a b H0); ring.
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed.
 
 Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0.
-Proof.
-  intros.
-  rewrite <- (Zopp_involutive a).
-  rewrite Zmod_opp_opp.
-  rewrite Z_mod_zero_opp_full; auto.
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed.
 
 Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 ->
  a mod (-b) = (a mod b) - b.
-Proof.
-  intros.
-  pattern a at 1; rewrite <- (Zopp_involutive a).
-  rewrite Zmod_opp_opp.
-  rewrite Z_mod_nz_opp_full; auto; omega.
-Qed.
+Proof. intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed.
 
 Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b).
-Proof.
-  intros; destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; do 2 rewrite Zdiv_0_r; auto.
-  symmetry; apply Zdiv_unique_full with 0; auto.
-  red; omega.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a b Hb).
-  rewrite H; ring.
-Qed.
+Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed.
 
 Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 ->
  (-a)/b = -(a/b)-1.
-Proof.
-  intros.
-  assert (b<>0) by (contradict H; subst; rewrite Zmod_0_r; auto).
-  symmetry; apply Zdiv_unique_full with (b-a mod b); auto.
-  generalize (Z_mod_remainder a b H0); destruct 1; [left|right]; omega.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a b H0); ring.
-Qed.
+Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed.
 
 Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b).
-Proof.
-  intros.
-  pattern a at 1; rewrite <- (Zopp_involutive a).
-  rewrite Zdiv_opp_opp.
-  rewrite Z_div_zero_opp_full; auto.
-Qed.
+Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed.
 
 Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 ->
  a/(-b) = -(a/b)-1.
-Proof.
-  intros.
-  pattern a at 1; rewrite <- (Zopp_involutive a).
-  rewrite Zdiv_opp_opp.
-  rewrite Z_div_nz_opp_full; auto; omega.
-Qed.
+Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. 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).
- intros a b c Hb Hc.
- symmetry.
- apply Zdiv_unique with ((a mod b)*c); auto with zarith.
- destruct (Z_mod_lt a b Hb); split.
- apply Zmult_le_0_compat; auto with zarith.
- 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 Hb as [Hb|Hb]; destruct (not_Zeq_inf _ _ Hc); auto with *.
-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,
- 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.
+Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed.
 
 Lemma Zdiv_mult_cancel_l : forall a b c:Z,
  c<>0 -> (c*a)/(c*b) = a/b.
 Proof.
-  intros.
-  rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
-  apply Zdiv_mult_cancel_r; auto.
+ intros. rewrite (Zmult_comm c b); zero_or_not b.
+ rewrite (Zmult_comm b c). apply Z.div_mul_cancel_l; auto.
 Qed.
 
 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].
-  subst; simpl; rewrite Zmod_0_r; auto.
-  destruct (Z_eq_dec b 0) as [Hb|Hb].
-  subst; repeat rewrite Zmult_0_r || rewrite Zmod_0_r; auto.
-  assert (c*b <> 0).
-   contradict Hc; eapply Zmult_integral_l; eauto.
-  rewrite (Zplus_minus_eq _ _ _ (Z_div_mod_eq_full (c*a) (c*b) H)).
-  rewrite (Zplus_minus_eq _ _ _ (Z_div_mod_eq_full a b Hb)).
-  rewrite Zdiv_mult_cancel_l; auto with zarith.
-  ring.
+ intros. zero_or_not c. rewrite (Zmult_comm c b); zero_or_not b.
+ rewrite (Zmult_comm b c). apply Z.mul_mod_distr_l; auto.
 Qed.
 
 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)).
-  apply Zmult_mod_distr_l; auto.
+ intros. zero_or_not b. rewrite (Zmult_comm b c); zero_or_not c.
+ rewrite (Zmult_comm c b). apply Z.mul_mod_distr_r; auto.
 Qed.
 
 (** Operations modulo. *)
 
 Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n.
-Proof.
-  intros; destruct (Z_eq_dec n 0) as [Hb|Hb].
-  subst; do 2 rewrite Zmod_0_r; auto.
-  pattern a at 2; rewrite (Z_div_mod_eq_full a n); auto with zarith.
-  rewrite Zplus_comm; rewrite Zmult_comm.
-  apply sym_equal; apply Z_mod_plus_full; auto with zarith.
-Qed.
+Proof. intros. zero_or_not n. apply Z.mod_mod; auto. Qed.
 
 Theorem Zmult_mod: forall a b n,
  (a * b) mod n = ((a mod n) * (b mod n)) mod n.
-Proof.
-  intros; destruct (Z_eq_dec n 0) as [Hb|Hb].
-  subst; do 2 rewrite Zmod_0_r; auto.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a n); auto with zarith.
-  pattern b at 1; rewrite (Z_div_mod_eq_full b n); auto with zarith.
-  set (A:=a mod n); set (B:=b mod n); set (A':=a/n); set (B':=b/n).
-  replace ((n*A' + A) * (n*B' + B))
-   with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring.
-  apply Z_mod_plus_full; auto with zarith.
-Qed.
+Proof. intros. zero_or_not n. apply Z.mul_mod; auto. Qed.
 
 Theorem Zplus_mod: forall a b n,
  (a + b) mod n = (a mod n + b mod n) mod n.
-Proof.
-  intros; destruct (Z_eq_dec n 0) as [Hb|Hb].
-  subst; do 2 rewrite Zmod_0_r; auto.
-  pattern a at 1; rewrite (Z_div_mod_eq_full a n); auto with zarith.
-  pattern b at 1; rewrite (Z_div_mod_eq_full b n); auto with zarith.
-  replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n))
-     with ((a mod n + b mod n) + (a / n + b / n) * n) by ring.
-  apply Z_mod_plus_full; auto with zarith.
-Qed.
+Proof. intros. zero_or_not n. apply Z.add_mod; auto. Qed.
 
 Theorem Zminus_mod: forall a b n,
  (a - b) mod n = (a mod n - b mod n) mod n.
@@ -897,49 +443,48 @@ Qed.
 (** For a specific number N, equality modulo N is hence a nice setoid
    equivalence, compatible with [+], [-] and [*]. *)
 
-Definition eqm N a b := (a mod N = b mod N).
+Section EqualityModulo.
+Variable N:Z.
 
-Lemma eqm_refl N : forall a, (eqm N) a a.
+Definition eqm a b := (a mod N = b mod N).
+Infix "==" := eqm (at level 70).
+
+Lemma eqm_refl : forall a, a == a.
 Proof. unfold eqm; auto. Qed.
 
-Lemma eqm_sym N : forall a b, (eqm N) a b -> (eqm N) b a.
+Lemma eqm_sym : forall a b, a == b -> b == a.
 Proof. unfold eqm; auto. Qed.
 
-Lemma eqm_trans N : forall a b c,
-  (eqm N) a b -> (eqm N) b c -> (eqm N) a c.
+Lemma eqm_trans : forall a b c,
+  a == b -> b == c -> a == c.
 Proof. unfold eqm; eauto with *. Qed.
 
-Add Parametric Relation N : Z (eqm N)
-  reflexivity proved by (eqm_refl N)
-  symmetry proved by (eqm_sym N)
-  transitivity proved by (eqm_trans N) as eqm_setoid.
+Instance eqm_setoid : Equivalence eqm.
+Proof.
+ constructor; [exact eqm_refl | exact eqm_sym | exact eqm_trans].
+Qed.
 
-Add Parametric Morphism N : Zplus
-  with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zplus_eqm.
+Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Zplus.
 Proof.
-  unfold eqm; intros; rewrite Zplus_mod, H, H0, <- Zplus_mod; auto.
+  unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto.
 Qed.
 
-Add Parametric Morphism N : Zminus
-  with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zminus_eqm.
+Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Zminus.
 Proof.
-  unfold eqm; intros; rewrite Zminus_mod, H, H0, <- Zminus_mod; auto.
+  unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto.
 Qed.
 
-Add Parametric Morphism N : Zmult
-  with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zmult_eqm.
+Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Zmult.
 Proof.
-  unfold eqm; intros; rewrite Zmult_mod, H, H0, <- Zmult_mod; auto.
+  unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto.
 Qed.
 
-Add Parametric Morphism N : Zopp
-  with signature (eqm N) ==> (eqm N) as Zopp_eqm.
+Instance Zopp_eqm : Proper (eqm ==> eqm) Zopp.
 Proof.
-  intros; change ((eqm N) (-x) (-y)) with ((eqm N) (0-x) (0-y)).
-  rewrite H; red; auto.
+  intros x y H. change ((-x)==(-y)) with ((0-x)==(0-y)). now rewrite H.
 Qed.
 
-Lemma Zmod_eqm N : forall a, (eqm N) (a mod N) a.
+Lemma Zmod_eqm : forall a, (a mod N) == a.
 Proof.
   intros; exact (Zmod_mod a N).
 Qed.
@@ -952,32 +497,12 @@ Qed.
     ~ (1/3 == 1/1)
 *)
 
+End EqualityModulo.
+
 Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c).
 Proof.
-  intros a b c Hb Hc.
-  destruct (Zle_lt_or_eq _ _ Hb); [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zdiv_0_l; auto].
-  destruct (Zle_lt_or_eq _ _ Hc); [ | subst; rewrite Zmult_0_r, Zdiv_0_r, Zdiv_0_r; auto].
-  pattern a at 2;rewrite (Z_div_mod_eq_full a b);auto with zarith.
-  pattern (a/b) at 2;rewrite (Z_div_mod_eq_full (a/b) c);auto with zarith.
-  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.
-  rewrite Z_div_plus_full_l; auto with zarith.
-  rewrite (Zdiv_small (b * ((a / b) mod c) + a mod b)).
-  ring.
-  split.
-  apply Zplus_le_0_compat;auto with zarith.
-  apply Zmult_le_0_compat;auto with zarith.
-  destruct (Z_mod_lt (a/b) c);auto with zarith.
-  destruct (Z_mod_lt a b);auto with zarith.
-  apply Zle_lt_trans with (b * ((a / b) mod c) + (b-1)).
-  destruct (Z_mod_lt a b);auto with zarith.
-  apply Zle_lt_trans with (b * (c-1) + (b - 1)).
-  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;
-  rewrite (Zmult_integral_l _ _ H2 H1) in H; auto with zarith.
+ intros. zero_or_not b. rewrite Zmult_comm. zero_or_not c.
+ rewrite Z.mul_comm. apply Z.div_div; auto with zarith.
 Qed.
 
 (** Unfortunately, the previous result isn't always true on negative numbers.
@@ -988,40 +513,40 @@ Qed.
 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);
-   [ | 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.
-  apply Zmult_le_reg_r with b; auto with zarith.
-  rewrite <- Zmult_assoc.
-  replace (a / b * b) with (a - a mod b).
-  replace (c * a / b * b) with (c * a - (c * a) mod b).
-  rewrite Zmult_minus_distr_l.
-  unfold Zminus; apply Zplus_le_compat_l.
-  match goal with |- - ?X <= -?Y => assert (Y <= X); auto with zarith end.
-  apply Zle_trans with ((c mod b) * (a mod b)); auto with zarith.
-  rewrite Zmult_mod; auto with zarith.
-  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;
-    auto with zarith.
-  pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith.
-Qed.
+ intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed.
 
 (** Zmod is related to divisibility (see more in Znumtheory) *)
 
 Lemma Zmod_divides : forall a b, b<>0 ->
  (a mod b = 0 <-> exists c, a = b*c).
 Proof.
- split; intros.
- exists (a/b).
- pattern a at 1; rewrite (Z_div_mod_eq_full a b); auto with zarith.
- destruct H0 as [c Hc].
- symmetry.
- apply Zmod_unique_full with c; auto with zarith.
- red; omega with *.
+ intros. rewrite Z.mod_divide; trivial.
+ split; intros (c,Hc); exists c; subst; auto with zarith.
+Qed.
+
+(** Particular case : dividing by 2 is related with parity *)
+
+Lemma Zdiv2_div : forall a, Z.div2 a = a/2.
+Proof Z.div2_div.
+
+Lemma Zmod_odd : forall a, a mod 2 = if Z.odd a then 1 else 0.
+Proof.
+ intros a. now rewrite <- Z.bit0_odd, <- Z.bit0_mod.
+Qed.
+
+Lemma Zmod_even : forall a, a mod 2 = if Z.even a then 0 else 1.
+Proof.
+ intros a. rewrite Zmod_odd, Zodd_even_bool. now destruct Zeven_bool.
+Qed.
+
+Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1.
+Proof.
+ intros a. rewrite Zmod_odd. now destruct Zodd_bool.
+Qed.
+
+Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0.
+Proof.
+ intros a. rewrite Zmod_even. now destruct Zeven_bool.
 Qed.
 
 (** * Compatibility *)
@@ -1075,12 +600,12 @@ Fixpoint Zmod_POS (a : positive) (b : Z) : Z  :=
    | xI a' =>
       let r := Zmod_POS a' b in
       let r' := (2 * r + 1) in
-      if Zgt_bool b r' then r' else (r' - b)
+      if r' <? b then r' else (r' - b)
    | xO a' =>
       let r := Zmod_POS a' b in
       let r' := (2 * r) in
-      if Zgt_bool b r' then r' else (r' - b)
-   | xH => if Zge_bool b 2 then 1 else 0
+      if r' <? b then r' else (r' - b)
+   | xH => if 2 <=? b then 1 else 0
   end.
 
 Definition Zmod' a b :=
@@ -1105,30 +630,28 @@ Definition Zmod' a b :=
   end.
 
 
-Theorem Zmod_POS_correct: forall a b, Zmod_POS a b = (snd (Zdiv_eucl_POS a b)).
+Theorem Zmod_POS_correct a b : Zmod_POS a b = snd (Z.pos_div_eucl a b).
 Proof.
-  intros a b; elim a; simpl; auto.
-  intros p Rec; rewrite  Rec.
-  case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto.
-  match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto.
-  intros p Rec; rewrite  Rec.
-  case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto.
-  match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto.
-  case (Zge_bool b 2); auto.
+  induction a as [a IH|a IH| ]; simpl; rewrite ?IH.
+  destruct (Z.pos_div_eucl a b) as (p,q); simpl;
+   case Z.ltb_spec; reflexivity.
+  destruct (Z.pos_div_eucl a b) as (p,q); simpl;
+   case Z.ltb_spec; reflexivity.
+  case Z.leb_spec; trivial.
 Qed.
 
-Theorem Zmod'_correct: forall a b, Zmod' a b = Zmod a b.
+Theorem Zmod'_correct: forall a b, Zmod' a b = a mod b.
 Proof.
-  intros a b; unfold Zmod; case a; simpl; auto.
+  intros a b; unfold Z.modulo; case a; simpl; auto.
   intros p; case b; simpl; auto.
   intros p1; refine (Zmod_POS_correct _ _); auto.
   intros p1; rewrite Zmod_POS_correct; auto.
-  case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
+  case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
   intros p; case b; simpl; auto.
   intros p1; rewrite Zmod_POS_correct; auto.
-  case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
+  case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto.
   intros p1; rewrite Zmod_POS_correct; simpl; auto.
-  case (Zdiv_eucl_POS p (Zpos p1)); auto.
+  case (Z.pos_div_eucl p (Zpos p1)); auto.
 Qed.
 
 
@@ -1140,12 +663,12 @@ Theorem Zdiv_eucl_extended :
   forall b:Z,
     b <> 0 ->
     forall a:Z,
-      {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Zabs b}.
+      {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}.
 Proof.
   intros b Hb a.
   elim (Z_le_gt_dec 0 b); intro Hb'.
   cut (b > 0); [ intro Hb'' | omega ].
-  rewrite Zabs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
+  rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
   cut (- b > 0); [ intro Hb'' | omega ].
   elim (Zdiv_eucl_exist Hb'' a); intros qr.
   elim qr; intros q r Hqr.
@@ -1153,17 +676,33 @@ Proof.
   elim Hqr; intros.
   split.
   rewrite <- Zmult_opp_comm; assumption.
-  rewrite Zabs_non_eq; [ assumption | omega ].
+  rewrite Z.abs_neq; [ assumption | omega ].
 Qed.
 
-Implicit Arguments Zdiv_eucl_extended.
+Arguments Zdiv_eucl_extended : default implicits.
 
-(** A third convention: Ocaml.
+(** * Division and modulo in Z agree with same in nat: *)
 
-     See files ZOdiv_def.v and ZOdiv.v.
+Require Import NPeano.
 
-     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).
-*)
+Lemma div_Zdiv (n m: nat): m <> O ->
+  Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m.
+Proof.
+ intros.
+ apply (Zdiv_unique _ _ _ (Z.of_nat (n mod m))).
+  split. auto with zarith.
+  now apply inj_lt, Nat.mod_upper_bound.
+ rewrite <- inj_mult, <- inj_plus.
+ now apply inj_eq, Nat.div_mod.
+Qed.
+
+Lemma mod_Zmod (n m: nat): m <> O ->
+  Z.of_nat (n mod m) = (Z.of_nat n) mod (Z.of_nat m).
+Proof.
+ intros.
+ apply (Zmod_unique _ _ (Z.of_nat n / Z.of_nat m)).
+  split. auto with zarith.
+  now apply inj_lt, Nat.mod_upper_bound.
+ rewrite <- div_Zdiv, <- inj_mult, <- inj_plus by trivial.
+ now apply inj_eq, Nat.div_mod.
+Qed.
diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v
new file mode 100644
index 00000000..f1b59749
--- /dev/null
+++ b/theories/ZArith/Zeuclid.v
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Morphisms BinInt ZDivEucl.
+Local Open Scope Z_scope.
+
+(** * Definitions of division for binary integers, Euclid convention. *)
+
+(** In this convention, the remainder is always positive.
+    For other conventions, see [Z.div] and [Z.quot] in file [BinIntDef].
+    To avoid collision with the other divisions, we place this one
+    under a module.
+*)
+
+Module ZEuclid.
+
+ Definition modulo a b := Z.modulo a (Z.abs b).
+ Definition div a b := (Z.sgn b) * (Z.div a (Z.abs b)).
+
+ Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+ Proof. congruence. Qed.
+ Instance div_wd : Proper (eq==>eq==>eq) div.
+ Proof. congruence. Qed.
+
+ Theorem div_mod a b : b<>0 -> a = b*(div a b) + modulo a b.
+ Proof.
+  intros Hb. unfold div, modulo.
+  rewrite Z.mul_assoc. rewrite Z.sgn_abs. apply Z.div_mod.
+  now destruct b.
+ Qed.
+
+ Lemma mod_always_pos a b : b<>0 -> 0 <= modulo a b < Z.abs b.
+ Proof.
+  intros Hb. unfold modulo.
+  apply Z.mod_pos_bound.
+  destruct b; compute; trivial. now destruct Hb.
+ Qed.
+
+ Lemma mod_bound_pos a b : 0<=a -> 0<b -> 0 <= modulo a b < b.
+ Proof.
+  intros _ Hb. rewrite <- (Z.abs_eq b) at 3 by Z.order.
+  apply mod_always_pos. Z.order.
+ Qed.
+
+ Include ZEuclidProp Z Z Z.
+
+End ZEuclid.
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
index 883b7f15..550b66f7 100644
--- a/theories/ZArith/Zeven.v
+++ b/theories/ZArith/Zeven.v
@@ -1,22 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zeven.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Binary Integers : Parity and Division by Two *)
+(** Initial author : Pierre Crégut (CNET, Lannion, France) *)
+
+(** THIS FILE IS DEPRECATED.
+    It is now almost entirely made of compatibility formulations
+    for results already present in BinInt.Z. *)
 
 Require Import BinInt.
 
 Open Scope Z_scope.
 
-(*******************************************************************)
-(** About parity: even and odd predicates on Z, division by 2 on Z *)
-
-(***************************************************)
-(** * [Zeven], [Zodd] and their related properties *)
+(** Historical formulation of even and odd predicates, based on
+    case analysis. We now rather recommend using [Z.Even] and
+    [Z.Odd], which are based on the exist predicate. *)
 
 Definition Zeven (z:Z) :=
   match z with
@@ -35,281 +38,253 @@ Definition Zodd (z:Z) :=
     | _ => False
   end.
 
-Definition Zeven_bool (z:Z) :=
-  match z with
-    | Z0 => true
-    | Zpos (xO _) => true
-    | Zneg (xO _) => true
-    | _ => false
-  end.
+Lemma Zeven_equiv z : Zeven z <-> Z.Even z.
+Proof.
+ rewrite <- Z.even_spec.
+ destruct z as [|p|p]; try destruct p; simpl; intuition.
+Qed.
 
-Definition Zodd_bool (z:Z) :=
-  match z with
-    | Z0 => false
-    | Zpos (xO _) => false
-    | Zneg (xO _) => false
-    | _ => true
-  end.
+Lemma Zodd_equiv z : Zodd z <-> Z.Odd z.
+Proof.
+ rewrite <- Z.odd_spec.
+ destruct z as [|p|p]; try destruct p; simpl; intuition.
+Qed.
+
+Theorem Zeven_ex_iff n : Zeven n <-> exists m, n = 2*m.
+Proof (Zeven_equiv n).
+
+Theorem Zodd_ex_iff n : Zodd n <-> exists m, n = 2*m + 1.
+Proof (Zodd_equiv n).
+
+(** Boolean tests of parity (now in BinInt.Z) *)
+
+Notation Zeven_bool := Z.even (only parsing).
+Notation Zodd_bool := Z.odd (only parsing).
+
+Lemma Zeven_bool_iff n : Z.even n = true <-> Zeven n.
+Proof.
+ now rewrite Z.even_spec, Zeven_equiv.
+Qed.
+
+Lemma Zodd_bool_iff n : Z.odd n = true <-> Zodd n.
+Proof.
+ now rewrite Z.odd_spec, Zodd_equiv.
+Qed.
+
+Ltac boolify_even_odd := rewrite <- ?Zeven_bool_iff, <- ?Zodd_bool_iff.
+
+Lemma Zodd_even_bool n : Z.odd n = negb (Z.even n).
+Proof.
+ symmetry. apply Z.negb_even.
+Qed.
+
+Lemma Zeven_odd_bool n : Z.even n = negb (Z.odd n).
+Proof.
+ symmetry. apply Z.negb_odd.
+Qed.
 
-Definition Zeven_odd_dec : forall z:Z, {Zeven z} + {Zodd z}.
+Definition Zeven_odd_dec n : {Zeven n} + {Zodd n}.
 Proof.
-  intro z. case z;
-  [ left; compute in |- *; trivial
-    | intro p; case p; intros;
-      (right; compute in |- *; exact I) || (left; compute in |- *; exact I)
-    | intro p; case p; intros;
-      (right; compute in |- *; exact I) || (left; compute in |- *; exact I) ].
+ destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
 Defined.
 
-Definition Zeven_dec : forall z:Z, {Zeven z} + {~ Zeven z}.
+Definition Zeven_dec n : {Zeven n} + {~ Zeven n}.
 Proof.
-  intro z. case z;
-  [ left; compute in |- *; trivial
-    | intro p; case p; intros;
-      (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
-    | intro p; case p; intros;
-      (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+ destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
 Defined.
 
-Definition Zodd_dec : forall z:Z, {Zodd z} + {~ Zodd z}.
+Definition Zodd_dec n : {Zodd n} + {~ Zodd n}.
 Proof.
-  intro z. case z;
-  [ right; compute in |- *; trivial
-    | intro p; case p; intros;
-      (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
-    | intro p; case p; intros;
-      (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+ destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
 Defined.
 
-Lemma Zeven_not_Zodd : forall n:Z, Zeven n -> ~ Zodd n.
+Lemma Zeven_not_Zodd n : Zeven n -> ~ Zodd n.
 Proof.
-  intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
-    trivial.
+ boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition.
 Qed.
 
-Lemma Zodd_not_Zeven : forall n:Z, Zodd n -> ~ Zeven n.
+Lemma Zodd_not_Zeven n : Zodd n -> ~ Zeven n.
 Proof.
-  intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
-    trivial.
+ boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition.
 Qed.
 
-Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n).
+Lemma Zeven_Sn n : Zodd n -> Zeven (Z.succ n).
 Proof.
-  intro z; destruct z; unfold Zsucc in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *;
-      trivial.
-  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+ boolify_even_odd. now rewrite Z.even_succ.
 Qed.
 
-Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n).
+Lemma Zodd_Sn n : Zeven n -> Zodd (Z.succ n).
 Proof.
-  intro z; destruct z; unfold Zsucc in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *;
-      trivial.
-  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+ boolify_even_odd. now rewrite Z.odd_succ.
 Qed.
 
-Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n).
+Lemma Zeven_pred n : Zodd n -> Zeven (Z.pred n).
 Proof.
-  intro z; destruct z; unfold Zpred in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *;
-      trivial.
-  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+ boolify_even_odd. now rewrite Z.even_pred.
 Qed.
 
-Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n).
+Lemma Zodd_pred n : Zeven n -> Zodd (Z.pred n).
 Proof.
-  intro z; destruct z; unfold Zpred in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *;
-      trivial.
-  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+ boolify_even_odd. now rewrite Z.odd_pred.
 Qed.
 
 Hint Unfold Zeven Zodd: zarith.
 
+Notation Zeven_bool_succ := Z.even_succ (only parsing).
+Notation Zeven_bool_pred := Z.even_pred (only parsing).
+Notation Zodd_bool_succ := Z.odd_succ (only parsing).
+Notation Zodd_bool_pred := Z.odd_pred (only parsing).
 
 (******************************************************************)
-(** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *)
+(** * Definition of [Zquot2], [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
-      [n = 2*(n/2)-1] *)
+Notation Zdiv2 := Z.div2 (only parsing).
+Notation Zquot2 := Z.quot2 (only parsing).
 
-Definition Zdiv2 (z:Z) :=
-  match z with
-    | Z0 => 0
-    | Zpos xH => 0
-    | Zpos p => Zpos (Pdiv2 p)
-    | Zneg xH => 0
-    | Zneg p => Zneg (Pdiv2 p)
-  end.
+(** Properties of [Z.div2] *)
 
-Lemma Zeven_div2 : forall n:Z, Zeven n -> n = 2 * Zdiv2 n.
+Lemma Zdiv2_odd_eqn n : n = 2*(Z.div2 n) + if Z.odd n then 1 else 0.
+Proof (Z.div2_odd n).
+
+Lemma Zeven_div2 n : Zeven n -> n = 2 * Z.div2 n.
 Proof.
-  intro x; destruct x.
-  auto with arith.
-  destruct p; auto with arith.
-  intros. absurd (Zeven (Zpos (xI p))); red in |- *; auto with arith.
-  intros. absurd (Zeven 1); red in |- *; auto with arith.
-  destruct p; auto with arith.
-  intros. absurd (Zeven (Zneg (xI p))); red in |- *; auto with arith.
-  intros. absurd (Zeven (-1)); red in |- *; auto with arith.
+ boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff.
+ intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn, Z.add_0_r.
 Qed.
 
-Lemma Zodd_div2 : forall n:Z, n >= 0 -> Zodd n -> n = 2 * Zdiv2 n + 1.
+Lemma Zodd_div2 n : Zodd n -> n = 2 * Z.div2 n + 1.
 Proof.
-  intro x; destruct x.
-  intros. absurd (Zodd 0); red in |- *; auto with arith.
-  destruct p; auto with arith.
-  intros. absurd (Zodd (Zpos (xO p))); red in |- *; auto with arith.
-  intros. absurd (Zneg p >= 0); red in |- *; auto with arith.
+ boolify_even_odd.
+ intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn.
 Qed.
 
-Lemma Zodd_div2_neg :
-  forall n:Z, n <= 0 -> Zodd n -> n = 2 * Zdiv2 n - 1.
+(** Properties of [Z.quot2] *)
+
+(** TODO: move to Numbers someday *)
+
+Lemma Zquot2_odd_eqn n : n = 2*(Z.quot2 n) + if Z.odd n then Z.sgn n else 0.
 Proof.
-  intro x; destruct x.
-  intros. absurd (Zodd 0); red in |- *; auto with arith.
-  intros. absurd (Zneg p >= 0); red in |- *; auto with arith.
-  destruct p; auto with arith.
-  intros. absurd (Zodd (Zneg (xO p))); red in |- *; auto with arith.
+ now destruct n as [ |[p|p| ]|[p|p| ]].
 Qed.
 
-Lemma Z_modulo_2 :
-  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}.
+Lemma Zeven_quot2 n : Zeven n -> n = 2 * Z.quot2 n.
 Proof.
-  intros x.
-  elim (Zeven_odd_dec x); intro.
-  left. split with (Zdiv2 x). exact (Zeven_div2 x a).
-  right. generalize b; clear b; case x.
-  intro b; inversion b.
-  intro p; split with (Zdiv2 (Zpos p)). apply (Zodd_div2 (Zpos p)); trivial.
-  unfold Zge, Zcompare in |- *; simpl in |- *; discriminate.
-  intro p; split with (Zdiv2 (Zpred (Zneg p))).
-  pattern (Zneg p) at 1 in |- *; rewrite (Zsucc_pred (Zneg p)).
-  pattern (Zpred (Zneg p)) at 1 in |- *; rewrite (Zeven_div2 (Zpred (Zneg p))).
-  reflexivity.
-  apply Zeven_pred; assumption.
+ intros Hn. apply Zeven_bool_iff in Hn.
+ rewrite (Zquot2_odd_eqn n) at 1.
+ now rewrite Zodd_even_bool, Hn, Z.add_0_r.
 Qed.
 
-Lemma Zsplit2 :
-  forall n:Z,
-    {p : Z * Z |
-      let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}.
+Lemma Zodd_quot2 n : n >= 0 -> Zodd n -> n = 2 * Z.quot2 n + 1.
 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.
-  assumption.
-  left; reflexivity.
-  exists (y, (y + 1)%Z); split.
-  rewrite Zplus_assoc; assumption.
-  right; reflexivity.
+ intros Hn Hn'. apply Zodd_bool_iff in Hn'.
+ rewrite (Zquot2_odd_eqn n) at 1. rewrite Hn'. f_equal.
+ destruct n; (now destruct Hn) || easy.
 Qed.
 
+Lemma Zodd_quot2_neg n : n <= 0 -> Zodd n -> n = 2 * Z.quot2 n - 1.
+Proof.
+ intros Hn Hn'. apply Zodd_bool_iff in Hn'.
+ rewrite (Zquot2_odd_eqn n) at 1; rewrite Hn'. unfold Z.sub. f_equal.
+ destruct n; (now destruct Hn) || easy.
+Qed.
 
-Theorem Zeven_ex: forall n, Zeven n -> exists m, n = 2 * m.
+Lemma Zquot2_opp n : Z.quot2 (-n) = - Z.quot2 n.
 Proof.
-  intro n; exists (Zdiv2 n); apply Zeven_div2; auto.
+ now destruct n as [ |[p|p| ]|[p|p| ]].
 Qed.
 
-Theorem Zodd_ex: forall n, Zodd n -> exists m, n = 2 * m + 1.
+Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2.
 Proof.
-  destruct n; intros.
-  inversion H.
-  exists (Zdiv2 (Zpos p)).
-  apply Zodd_div2; simpl; auto; compute; inversion 1.
-  exists (Zdiv2 (Zneg p) - 1).
-  unfold Zminus.
-  rewrite Zmult_plus_distr_r.
-  rewrite <- Zplus_assoc.
-  assert (Zneg p <= 0) by (compute; inversion 1).
-  exact (Zodd_div2_neg _ H0 H).
+ assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2).
+  BeginSubproof.
+   intros m Hm.
+   apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0).
+   now apply Z.lt_le_incl.
+   rewrite Z.sgn_pos by trivial.
+   destruct (Z.odd m); now split.
+   apply Zquot2_odd_eqn.
+  EndSubproof.
+ destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]].
+ - now apply AUX.
+ - now subst.
+ - apply Z.opp_inj. rewrite <- Z.quot_opp_l, <- Zquot2_opp.
+   apply AUX. now destruct n. easy.
 Qed.
 
-Theorem Zeven_2p: forall p, Zeven (2 * p).
+(** More properties of parity *)
+
+Lemma Z_modulo_2 n : {y | n = 2 * y} + {y | n = 2 * y + 1}.
 Proof.
-  destruct p; simpl; auto.
+ destruct (Zeven_odd_dec n) as [Hn|Hn].
+ - left. exists (Z.div2 n). exact (Zeven_div2 n Hn).
+ - right. exists (Z.div2 n). exact (Zodd_div2 n Hn).
 Qed.
 
-Theorem Zodd_2p_plus_1: forall p, Zodd (2 * p + 1).
+Lemma Zsplit2 n :
+ {p : Z * Z | let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}.
 Proof.
-  destruct p; simpl; auto.
-  destruct p; simpl; auto.
+ destruct (Z_modulo_2 n) as [(y,Hy)|(y,Hy)];
+  rewrite Z.mul_comm, <- Zplus_diag_eq_mult_2 in Hy.
+ - exists (y, y). split. assumption. now left.
+ - exists (y, y + 1). split. now rewrite Z.add_assoc. now right.
 Qed.
 
-Theorem Zeven_plus_Zodd: forall a b,
- Zeven a -> Zodd b -> Zodd (a + b).
+Theorem Zeven_ex n : Zeven n -> exists m, n = 2 * m.
 Proof.
-  intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
-  case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto.
-  replace (2 * x + (2 * y + 1)) with (2 * (x + y) + 1); try apply Zodd_2p_plus_1; auto with zarith.
-  rewrite Zmult_plus_distr_r, Zplus_assoc; auto.
+ exists (Z.div2 n); apply Zeven_div2; auto.
 Qed.
 
-Theorem Zeven_plus_Zeven: forall a b,
- Zeven a -> Zeven b -> Zeven (a + b).
+Theorem Zodd_ex n : Zodd n -> exists m, n = 2 * m + 1.
 Proof.
-  intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
-  case Zeven_ex with (1 := H2); intros y H4; try rewrite H4; auto.
-  replace (2 * x + 2 * y) with (2 * (x + y)); try apply Zeven_2p; auto with zarith.
-  apply Zmult_plus_distr_r; auto.
+ exists (Z.div2 n); apply Zodd_div2; auto.
 Qed.
 
-Theorem Zodd_plus_Zeven: forall a b,
- Zodd a -> Zeven b -> Zodd (a + b).
+Theorem Zeven_2p p : Zeven (2 * p).
 Proof.
-  intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto.
+ now destruct p.
 Qed.
 
-Theorem Zodd_plus_Zodd: forall a b,
- Zodd a -> Zodd b -> Zeven (a + b).
+Theorem Zodd_2p_plus_1 p : Zodd (2 * p + 1).
 Proof.
-  intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto.
-  case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto.
-  replace ((2 * x + 1) + (2 * y + 1)) with (2 * (x + y + 1)); try apply Zeven_2p; auto.
-  (* ring part *)
-  do 2 rewrite Zmult_plus_distr_r; auto.
-  repeat rewrite <- Zplus_assoc; f_equal.
-  rewrite (Zplus_comm 1).
-  repeat rewrite <- Zplus_assoc; auto.
+ destruct p as [|p|p]; now try destruct p.
 Qed.
 
-Theorem Zeven_mult_Zeven_l: forall a b,
- Zeven a -> Zeven (a * b).
+Theorem Zeven_plus_Zodd a b : Zeven a -> Zodd b -> Zodd (a + b).
 Proof.
-  intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
-  replace (2 * x * b) with (2 * (x * b)); try apply Zeven_2p; auto with zarith.
-  (* ring part *)
-  apply Zmult_assoc.
+ boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff.
+ intros Ha Hb. now rewrite Z.odd_add, Ha, Hb.
 Qed.
 
-Theorem Zeven_mult_Zeven_r: forall a b,
- Zeven b -> Zeven (a * b).
+Theorem Zeven_plus_Zeven a b : Zeven a -> Zeven b -> Zeven (a + b).
 Proof.
-  intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
-  replace (a * (2 * x)) with (2 * (x * a)); try apply Zeven_2p; auto.
-  (* ring part *)
-  rewrite (Zmult_comm x a).
-  do 2 rewrite Zmult_assoc.
-  rewrite (Zmult_comm 2 a); auto.
+ boolify_even_odd. intros Ha Hb. now rewrite Z.even_add, Ha, Hb.
 Qed.
 
-Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l
-     Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand.
+Theorem Zodd_plus_Zeven a b : Zodd a -> Zeven b -> Zodd (a + b).
+Proof.
+ intros. rewrite Z.add_comm. now apply Zeven_plus_Zodd.
+Qed.
+
+Theorem Zodd_plus_Zodd a b : Zodd a -> Zodd b -> Zeven (a + b).
+Proof.
+ boolify_even_odd. rewrite <- 2 Z.negb_even, 2 Bool.negb_true_iff.
+ intros Ha Hb. now rewrite Z.even_add, Ha, Hb.
+Qed.
+
+Theorem Zeven_mult_Zeven_l a b : Zeven a -> Zeven (a * b).
+Proof.
+ boolify_even_odd. intros Ha. now rewrite Z.even_mul, Ha.
+Qed.
+
+Theorem Zeven_mult_Zeven_r a b : Zeven b -> Zeven (a * b).
+Proof.
+ intros. rewrite Z.mul_comm. now apply Zeven_mult_Zeven_l.
+Qed.
 
-Theorem Zodd_mult_Zodd: forall a b,
- Zodd a -> Zodd b -> Zodd (a * b).
+Theorem Zodd_mult_Zodd 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.
-  case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto.
-  replace ((2 * x + 1) * (2 * y + 1)) with (2 * (2 * x * y + x + y) + 1); try apply Zodd_2p_plus_1; auto.
-  (* 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; apply Zmult_comm.
+ boolify_even_odd. intros Ha Hb. now rewrite Z.odd_mul, Ha, Hb.
 Qed.
 
 (* for compatibility *)
diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v
index 86fe0ef9..ebf3d024 100644
--- a/theories/ZArith/Zgcd_alt.v
+++ b/theories/ZArith/Zgcd_alt.v
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zgcd_alt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *)
+(** * Zgcd_alt : an alternate version of Zgcd, based on Euclid's algorithm *)
 
 (**
 Author: Pierre Letouzey
@@ -17,7 +15,7 @@ Author: Pierre Letouzey
 (** The alternate [Zgcd_alt] given here used to be the main [Zgcd]
     function (see file [Znumtheory]), but this main [Zgcd] is now
     based on a modern binary-efficient algorithm. This earlier
-    version, based on Euler's algorithm of iterated modulo, is kept
+    version, based on Euclid's algorithm of iterated modulo, is kept
     here due to both its intrinsic interest and its use as reference
     point when proving gcd on Int31 numbers *)
 
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index c2348967..6a14d693 100644
--- a/theories/ZArith/Zhints.v
+++ b/theories/ZArith/Zhints.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zhints.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** This file centralizes the lemmas about [Z], classifying them
     according to the way they can be used in automatic search  *)
 
@@ -100,440 +98,3 @@ Hint Resolve
   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   *)
-
-(** ** 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`
-Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
-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`
->>
-*)
-
-(** 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)`
-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`
-Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
-Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
-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)`
->>
-*)
-
-(** ** 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`
->>
-*)
-
-(** Lemmas ending by Zgt *)
-(**
-<<
-Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
-not_Zle: (x,y:Z)~`x <= y`->`x > y`
-Zlt_gt: (m,n:Z)`m < n`->`n > m`
-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`
-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`
-Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
-Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p`
-Zge_le: (m,n:Z)`m >= n`->`n <= m`
-Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
-Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
-Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
-Zle_refl: (n,m:Z)`n = m`->`n <= m`
->>
-*)
-
-(** ** Irreversible simplification involving several comparaisons *)
-(**    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`
->>
-*)
-
-(** ** 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)`
->>
-*)
-
-(**********************************************************************)
-(** *                Useful Bottom-up lemmas                          *)
-
-(** ** 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`
-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`
->>
-*)
-
-(** 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`
->>
-*)
-
-(** Lemmas ending by Zle *)
-(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
-Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
-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`
->>
-*)
-
-(** ** Other unclearly simplifying lemmas *)
-
-(** Lemmas ending by Zeq *)
-(**
-<<
-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                                               *)
-
-(* 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`
->>
-*)
-
-
-(**********************************************************************)
-(** *               Unclear or too specific lemmas                    *)
-(** Not to be used ?                                                  *)
-
-(** ** Irreversible and too specific (not enough regular) *)
-
-(** Lemmas ending by Zle *)
-(**
-<<
-Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
-Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
-OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
-OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
->>
-*)
-
-(** ** Expansion and too specific ? *)
-
-(** Lemmas ending by Zge *)
-(**
-<<
-Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
->>
-*)
-
-(** Lemmas ending by Zgt *)
-(**
-<<
-Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
-Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
->>
-*)
-
-(** Lemmas ending by Zle *)
-(**
-<<
-Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
-Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
->>
-*)
-
-(** ** Reversible but too specific ? *)
-
-(** Lemmas ending by Zlt *)
-(**
-<<
-Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
->>
-*)
-
-(**********************************************************************)
-(** *               Lemmas to be used as rewrite rules                *)
-(** but can also be used as hints                                     *)
-
-(** Left-to-right simplification lemmas (a symbol disappears) *)
-
-(**
-<<
-Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
-Zmin_n_n: (n:Z)`(Zmin n n) = n`
-Zmult_1_n: (n:Z)`1*n = n`
-Zmult_n_1: (n:Z)`n*1 = n`
-Zminus_plus: (n,m:Z)`n+m-n = m`
-Zle_plus_minus: (n,m:Z)`n+(m-n) = m`
-Zopp_Zopp: (x:Z)`(-(-x)) = x`
-Zero_left: (x:Z)`0+x = x`
-Zero_right: (x:Z)`x+0 = x`
-Zplus_inverse_r: (x:Z)`x+(-x) = 0`
-Zplus_inverse_l: (x:Z)`(-x)+x = 0`
-Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y`
-Zmult_one: (x:Z)`1*x = x`
-Zero_mult_left: (x:Z)`0*x = 0`
-Zero_mult_right: (x:Z)`x*0 = 0`
-Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
->>
-*)
-
-(** Right-to-left simplification lemmas (a symbol disappears) *)
-
-(**
-<<
-Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
-Zs_pred: (n:Z)`n = (Zs (Zpred n))`
-Zplus_n_O: (n:Z)`n = n+0`
-Zmult_n_O: (n:Z)`0 = n*0`
-Zminus_n_O: (n:Z)`n = n-0`
-Zminus_n_n: (n:Z)`0 = n-n`
-Zred_factor6: (x:Z)`x = x+0`
-Zred_factor0: (x:Z)`x = x*1`
->>
-*)
-
-(** Unclear orientation (no symbol disappears) *)
-
-(**
-<<
-Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
-Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
-Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
-Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p`
-Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)`
-Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)`
-Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)`
-Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)`
-Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m`
-Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p`
-Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p`
-Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)`
-Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p`
-Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)`
-Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m`
-Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z`
-Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p`
-Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)`
-Zplus_sym: (x,y:Z)`x+y = y+x`
-Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z`
-Zmult_sym: (x,y:Z)`x*y = y*x`
-Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z`
-Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))`
-Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))`
-Zopp_one: (x:Z)`(-x) = x*(-1)`
-Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)`
-Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)`
-Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y`
-Zred_factor1: (x:Z)`x+x = x*2`
-Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)`
-Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
-Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
-Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
-Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
->>
-*)
-
-(** nat <-> Z *)
-(**
-<<
-inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
-inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
-inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
-inj_minus1:
- (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
-inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
->>
-*)
-
-(** Too specific ? *)
-(**
-<<
-Zred_factor5: (x,y:Z)`x*0+y = y`
->>
-*)
-
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
index 59e76830..30948ca7 100644
--- a/theories/ZArith/Zlogarithm.v
+++ b/theories/ZArith/Zlogarithm.v
@@ -1,17 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zlogarithm.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (**********************************************************************)
-(** The integer logarithms with base 2.
 
-    There are three logarithms,
+(** The integer logarithms with base 2. *)
+
+(** THIS FILE IS DEPRECATED.
+    Please rather use [Z.log2] (or [Z.log2_up]), which
+    are defined in [BinIntDef], and whose properties can
+    be found in [BinInt.Z]. *)
+
+(*  There are three logarithms defined here,
     depending on the rounding of the real 2-based logarithm:
     - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)]
       i.e. [Log_inf x] is the biggest integer that is smaller than [Log x]
@@ -20,11 +24,8 @@
     - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)]
       i.e. [Log_nearest x] is the integer nearest from [Log x] *)
 
-Require Import ZArith_base.
-Require Import Omega.
-Require Import Zcomplements.
-Require Import Zpower.
-Open Local Scope Z_scope.
+Require Import ZArith_base Omega Zcomplements Zpower.
+Local Open Scope Z_scope.
 
 Section Log_pos. (* Log of positive integers *)
 
@@ -32,9 +33,9 @@ Section Log_pos. (* Log of positive integers *)
 
   Fixpoint log_inf (p:positive) : Z :=
     match p with
-      | xH => 0	(* 1 *)
-      | xO q => Zsucc (log_inf q)	(* 2n *)
-      | xI q => Zsucc (log_inf q)	(* 2n+1 *)
+      | xH => 0 (* 1 *)
+      | xO q => Zsucc (log_inf q)       (* 2n *)
+      | xI q => Zsucc (log_inf q)       (* 2n+1 *)
     end.
 
   Fixpoint log_sup (p:positive) : Z :=
@@ -46,6 +47,27 @@ Section Log_pos. (* Log of positive integers *)
 
   Hint Unfold log_inf log_sup.
 
+  Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p).
+  Proof.
+   induction p; simpl; now rewrite <- ?Z.succ_Zpos, ?IHp.
+  Qed.
+
+  Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p.
+  Proof.
+   unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf.
+  Qed.
+
+  Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p.
+  Proof.
+   induction p; simpl.
+   - change (Zpos p~1) with (2*(Zpos p)+1).
+     rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy.
+     unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc.
+   - change (Zpos p~0) with (2*Zpos p).
+     now rewrite Z.log2_up_double, IHp.
+   - reflexivity.
+  Qed.
+
   (** Then we give the specifications of [log_inf] and [log_sup]
     and prove their validity *)
 
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
index cb2fcf26..999564f0 100644
--- a/theories/ZArith/Zmax.v
+++ b/theories/ZArith/Zmax.v
@@ -1,106 +1,111 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmax.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
+(** THIS FILE IS DEPRECATED. *)
 
-Require Export BinInt Zorder Zminmax.
+Require Export BinInt Zcompare Zorder.
 
-Open Local Scope Z_scope.
-
-(** [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. *)
+Local Open Scope Z_scope.
 
+(** Definition [Zmax] is now [BinInt.Z.max]. *)
 
 (** * Characterization of maximum on binary integer numbers *)
 
 Definition Zmax_case := Z.max_case.
 Definition Zmax_case_strong := Z.max_case_strong.
 
-Lemma Zmax_spec : forall x y,
-  x >= y /\ Zmax x y = x  \/ x < y /\ Zmax x y = y.
+Lemma Zmax_spec x y :
+  x >= y /\ Z.max x y = x  \/ x < y /\ Z.max x y = y.
 Proof.
- intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto.
+ Z.swap_greater. destruct (Z.max_spec x y); 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_left n m : n>=m -> Z.max n m = n.
+Proof. Z.swap_greater. apply Zmax_l. Qed.
 
-Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r.
+Lemma Zmax_right : forall n m, n<=m -> Z.max n m = m. Proof Zmax_r.
 
 (** * Least upper bound properties of max *)
 
-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.
+Lemma Zle_max_l : forall n m, n <= Z.max n m. Proof Z.le_max_l.
+Lemma Zle_max_r : forall n m, m <= Z.max n m. Proof Z.le_max_r.
 
-Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p
- := Z.max_lub.
+Lemma Zmax_lub : forall n m p, n <= p -> m <= p -> Z.max n m <= p.
+Proof Z.max_lub.
 
-Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p
- := Z.max_lub_lt.
+Lemma Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Z.max n m < p.
+Proof Z.max_lub_lt.
 
 
 (** * Compatibility with order *)
 
-Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p
- := Z.max_le_compat_r.
+Lemma Zle_max_compat_r : forall n m p, n <= m -> Z.max n p <= Z.max m p.
+Proof Z.max_le_compat_r.
 
-Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m
- := Z.max_le_compat_l.
+Lemma Zle_max_compat_l : forall n m p, n <= m -> Z.max p n <= Z.max p m.
+Proof Z.max_le_compat_l.
 
 
 (** * 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.
+Lemma Zmax_idempotent : forall n, Z.max n n = n. Proof Z.max_id.
+Lemma Zmax_comm : forall n m, Z.max n m = Z.max m n. Proof Z.max_comm.
+Lemma Zmax_assoc : forall n m p, Z.max n (Z.max m p) = Z.max (Z.max n m) p.
+Proof Z.max_assoc.
 
 (** * Additional properties of max *)
 
-Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}.
-Proof. exact Z.max_dec. Qed.
+Lemma Zmax_irreducible_dec : forall n m, {Z.max n m = n} + {Z.max n m = m}.
+Proof Z.max_dec.
 
-Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m
- := Z.max_le.
+Lemma Zmax_le_prime : forall n m p, p <= Z.max n m -> p <= n \/ p <= m.
+Proof Z.max_le.
 
 
 (** * Operations preserving max *)
 
-Definition Zsucc_max_distr :
-  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m)
- := Z.succ_max_distr.
+Lemma Zsucc_max_distr :
+  forall n m, Z.succ (Z.max n m) = Z.max (Z.succ n) (Z.succ m).
+Proof Z.succ_max_distr.
 
-Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m
- := Z.plus_max_distr_l.
+Lemma Zplus_max_distr_l : forall n m p, Z.max (p + n) (p + m) = p + Z.max n m.
+Proof Z.add_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.
+Lemma Zplus_max_distr_r : forall n m p, Z.max (n + p) (m + p) = Z.max n m + p.
+Proof Z.add_max_distr_r.
 
 (** * Maximum and Zpos *)
 
-Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q)
- := Z.pos_max.
+Lemma Zpos_max p q : Zpos (Pos.max p q) = Z.max (Zpos p) (Zpos q).
+Proof.
+ unfold Zmax, Pmax. simpl.
+ case Pos.compare_spec; auto; congruence.
+Qed.
 
-Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p
- := Z.pos_max_1.
+Lemma Zpos_max_1 p : Z.max 1 (Zpos p) = Zpos p.
+Proof.
+ now destruct p.
+Qed.
 
-(** * Characterization of Pminus in term of Zminus and Zmax *)
+(** * Characterization of Pos.sub in term of Z.sub and Z.max *)
 
-Definition Zpos_minus :
- forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q)
- := Zpos_minus.
+Lemma Zpos_minus p q : Zpos (p - q) = Z.max 1 (Zpos p - Zpos q).
+Proof.
+  simpl. rewrite Z.pos_sub_spec. case Pos.compare_spec; intros H.
+  subst; now rewrite Pos.sub_diag.
+  now rewrite Pos.sub_lt.
+  symmetry. apply Zpos_max_1.
+Qed.
 
 (* 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).
+Notation Zmax1 := Z.le_max_l (only parsing).
+Notation Zmax2 := Z.le_max_r (only parsing).
+Notation Zmax_irreducible_inf := Z.max_dec (only parsing).
+Notation Zmax_le_prime_inf := Z.max_le (only parsing).
 (* end hide *)
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index 7b9ad469..2c5003a6 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -1,90 +1,95 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmin.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
+(** THIS FILE IS DEPRECATED. *)
 
-Require Import BinInt Zorder Zminmax.
+Require Import BinInt Zcompare Zorder.
 
-Open Local Scope Z_scope.
-
-(** [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. *)
+Local Open Scope Z_scope.
 
+(** Definition [Zmin] is now [BinInt.Z.min]. *)
 
 (** * Characterization of the minimum on binary integer numbers *)
 
 Definition Zmin_case := Z.min_case.
 Definition Zmin_case_strong := Z.min_case_strong.
 
-Lemma Zmin_spec : forall x y,
-  x <= y /\ Zmin x y = x  \/  x > y /\ Zmin x y = y.
+Lemma Zmin_spec x y :
+  x <= y /\ Z.min x y = x  \/  x > y /\ Z.min x y = y.
 Proof.
- intros x y. rewrite Zgt_iff_lt, Z.min_comm. destruct (Z.min_spec y x); auto.
+ Z.swap_greater. rewrite Z.min_comm. destruct (Z.min_spec y x); auto.
 Qed.
 
 (** * Greatest lower bound properties of min *)
 
-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_l : forall n m, Z.min n m <= n. Proof Z.le_min_l.
+Lemma Zle_min_r : forall n m, Z.min n m <= m. Proof Z.le_min_r.
 
-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, p <= n -> p <= m -> p <= Z.min n m.
+Proof Z.min_glb.
+Lemma Zmin_glb_lt : forall n m p, p < n -> p < m -> p < Z.min n m.
+Proof Z.min_glb_lt.
 
 (** * Compatibility with order *)
 
-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 Zle_min_compat_r : forall n m p, n <= m -> Z.min n p <= Z.min m p.
+Proof Z.min_le_compat_r.
+Lemma Zle_min_compat_l : forall n m p, n <= m -> Z.min p n <= Z.min p m.
+Proof Z.min_le_compat_l.
 
 (** * 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).
-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.
+Lemma Zmin_idempotent : forall n, Z.min n n = n. Proof Z.min_id.
+Notation Zmin_n_n := Z.min_id (only parsing).
+Lemma Zmin_comm : forall n m, Z.min n m = Z.min m n. Proof Z.min_comm.
+Lemma Zmin_assoc : forall n m p, Z.min n (Z.min m p) = Z.min (Z.min n m) p.
+Proof Z.min_assoc.
 
 (** * Additional properties of min *)
 
-Lemma Zmin_irreducible_inf : forall n m, {Zmin n m = n} + {Zmin n m = m}.
-Proof. exact Z.min_dec. Qed.
+Lemma Zmin_irreducible_inf : forall n m, {Z.min n m = n} + {Z.min n m = m}.
+Proof Z.min_dec.
 
-Lemma Zmin_irreducible : forall n m, Zmin n m = n \/ Zmin n m = m.
-Proof. intros; destruct (Z.min_dec n m); auto. Qed.
+Lemma Zmin_irreducible n m : Z.min n m = n \/ Z.min n m = m.
+Proof. destruct (Z.min_dec n m); auto. Qed.
 
 Notation Zmin_or := Zmin_irreducible (only parsing).
 
-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.
+Lemma Zmin_le_prime_inf n m p : Z.min n m <= p -> {n <= p} + {m <= p}.
+Proof. apply Zmin_case; auto. Qed.
 
 (** * Operations preserving min *)
 
-Definition Zsucc_min_distr :
- forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m)
- := Z.succ_min_distr.
+Lemma Zsucc_min_distr :
+ forall n m, Z.succ (Z.min n m) = Z.min (Z.succ n) (Z.succ m).
+Proof Z.succ_min_distr.
 
 Notation Zmin_SS := Z.succ_min_distr (only parsing).
 
-Definition Zplus_min_distr_r :
- forall n m p, Zmin (n + p) (m + p) = Zmin n m + p
- := Z.plus_min_distr_r.
+Lemma Zplus_min_distr_r :
+ forall n m p, Z.min (n + p) (m + p) = Z.min n m + p.
+Proof Z.add_min_distr_r.
 
-Notation Zmin_plus := Z.plus_min_distr_r (only parsing).
+Notation Zmin_plus := Z.add_min_distr_r (only parsing).
 
 (** * Minimum and Zpos *)
 
-Definition Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q)
- := Z.pos_min.
+Lemma Zpos_min p q : Zpos (Pos.min p q) = Z.min (Zpos p) (Zpos q).
+Proof.
+ unfold Z.min, Pos.min; simpl. destruct Pos.compare; auto.
+Qed.
+
+Lemma Zpos_min_1 p : Z.min 1 (Zpos p) = 1.
+Proof.
+ now destruct p.
+Qed.
+
+
 
 
 
diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v
index 5aebcc55..8908175f 100644
--- a/theories/ZArith/Zminmax.v
+++ b/theories/ZArith/Zminmax.v
@@ -1,194 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Import Orders BinInt Zcompare Zorder ZOrderedType
- GenericMinMax.
-
-(** * Maximum and Minimum of two [Z] numbers *)
-
-Local Open Scope Z_scope.
-
-Unboxed Definition Zmax (n m:Z) :=
-  match n ?= m with
-    | Eq | Gt => n
-    | Lt => m
-  end.
-
-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 max_monotone.
- intros x y. apply Zplus_le_compat_l.
-Qed.
-
-Lemma plus_max_distr_r : forall n m p, Zmax (n + p) (m + p) = Zmax n m + p.
-Proof.
- intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p).
- apply plus_max_distr_l.
-Qed.
-
-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 plus_min_distr_r : forall n m p, Zmin (n + p) (m + p) = Zmin n m + p.
-Proof.
- intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p).
- apply plus_min_distr_l.
-Qed.
-
-Lemma succ_max_distr : forall n m, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m).
-Proof.
- unfold Zsucc. intros. symmetry. apply plus_max_distr_r.
-Qed.
-
-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 pred_max_distr : forall n m, Zpred (Zmax n m) = Zmax (Zpred n) (Zpred m).
-Proof.
- unfold Zpred. intros. symmetry. apply plus_max_distr_r.
-Qed.
-
-Lemma pred_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
-Proof.
- unfold Zpred. intros. symmetry. apply plus_min_distr_r.
-Qed.
-
-(** 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 minus_max_distr_l : forall n m p, Zmax (p - n) (p - m) = p - Zmin n m.
-Proof.
- 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.
+Require Import Orders BinInt Zcompare Zorder.
 
+(** THIS FILE IS DEPRECATED. *)
 
 (*begin hide*)
 (* Compatibility with names of the old Zminmax file *)
@@ -199,4 +19,4 @@ 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
+(*end hide*)
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index a8872bd5..ff844ec2 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zmisc.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import Wf_nat.
 Require Import BinInt.
 Require Import Zcompare.
@@ -20,72 +18,11 @@ Open Local Scope Z_scope.
 
 (** [n]th iteration of the function [f] *)
 
-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)
-    | xI n' => f (iter_pos n' A f (iter_pos n' A f x))
-  end.
-
-Definition iter (n:Z) (A:Type) (f:A -> A) (x:A) :=
-  match n with
-    | Z0 => x
-    | Zpos p => iter_pos p A f x
-    | Zneg p => x
-  end.
-
-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.
-  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 (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 (ZL6 p); symmetry  in |- *; apply iter_nat_plus
-      | simpl in |- *; auto with arith ].
-Qed.
+Notation iter := @Z.iter (only parsing).
 
 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.
+  iter n A f x = iter_nat (Z.abs_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 _; unfold Z.iter, Z.abs_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.
-  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)).
-  rewrite (iter_nat_of_P (n + m) A f x).
-  rewrite (nat_of_P_plus_morphism n m).
-  apply iter_nat_plus.
-Qed.
-
-(** 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.
-  simple induction n; intros;
-    [ trivial with arith
-      | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H;
-	trivial with arith ].
-Qed.
-
-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.
-  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 9585b6f6..e3843990 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -1,286 +1,997 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
 Require Export Arith_base.
-Require Import BinPos.
-Require Import BinInt.
-Require Import Zcompare.
-Require Import Zorder.
-Require Import Decidable.
-Require Import Peano_dec.
-Require Import Min Max Zmin Zmax.
-Require Export Compare_dec.
+Require Import BinPos BinInt BinNat Pnat Nnat.
+
+Local Open Scope Z_scope.
+
+(** * Chains of conversions *)
+
+(** When combining successive conversions, we have the following
+    commutative diagram:
+<<
+      ---> Nat ----
+     |      ^      |
+     |      |      v
+    Pos ---------> Z
+     |      |      ^
+     |      v      |
+      ----> N -----
+>>
+*)
+
+Lemma nat_N_Z n : Z.of_N (N.of_nat n) = Z.of_nat n.
+Proof.
+ now destruct n.
+Qed.
 
-Open Local Scope Z_scope.
+Lemma N_nat_Z n : Z.of_nat (N.to_nat n) = Z.of_N n.
+Proof.
+ destruct n; trivial. simpl.
+ destruct (Pos2Nat.is_succ p) as (m,H).
+ rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
+Qed.
 
-Definition neq (x y:nat) := x <> y.
+Lemma positive_nat_Z p : Z.of_nat (Pos.to_nat p) = Zpos p.
+Proof.
+ destruct (Pos2Nat.is_succ p) as (n,H).
+ rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
+Qed.
+
+Lemma positive_N_Z p : Z.of_N (Npos p) = Zpos p.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma positive_N_nat p : N.to_nat (Npos p) = Pos.to_nat p.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma positive_nat_N p : N.of_nat (Pos.to_nat p) = Npos p.
+Proof.
+ destruct (Pos2Nat.is_succ p) as (n,H).
+ rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
+Qed.
 
-(************************************************)
-(** Properties of the injection from nat into Z *)
+Lemma Z_N_nat n : N.to_nat (Z.to_N n) = Z.to_nat n.
+Proof.
+ now destruct n.
+Qed.
 
-(** Injection and successor *)
+Lemma Z_nat_N n : N.of_nat (Z.to_nat n) = Z.to_N n.
+Proof.
+ destruct n; simpl; trivial. apply positive_nat_N.
+Qed.
 
-Theorem inj_0 : Z_of_nat 0 = 0%Z.
+Lemma Zabs_N_nat n : N.to_nat (Z.abs_N n) = Z.abs_nat n.
 Proof.
-  reflexivity.
+ now destruct n.
 Qed.
 
-Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
+Lemma Zabs_nat_N n : N.of_nat (Z.abs_nat n) = Z.abs_N n.
 Proof.
-  intro y; induction y as [| n H];
-    [ unfold Zsucc in |- *; simpl in |- *; trivial with arith
-      | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *;
-	rewrite Zpos_succ_morphism; trivial with arith ].
+ destruct n; simpl; trivial; apply positive_nat_N.
 Qed.
 
-(** Injection and equality. *)
 
-Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
+(** * Conversions between [Z] and [N] *)
+
+Module N2Z.
+
+(** [Z.of_N] is a bijection between [N] and non-negative [Z],
+    with [Z.to_N] (or [Z.abs_N]) as reciprocal.
+    See [Z2N.id] below for the dual equation. *)
+
+Lemma id n : Z.to_N (Z.of_N n) = n.
 Proof.
-  intros x y H; rewrite H; trivial with arith.
+ now destruct n.
 Qed.
 
-Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
+(** [Z.of_N] is hence injective *)
+
+Lemma inj n m : Z.of_N n = Z.of_N m -> n = m.
 Proof.
-  unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2;
-    case x; case y; intros;
-      [ auto with arith
-	| discriminate H0
-	| discriminate H0
-	| simpl in H0; injection H0;
-	  do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ;
-	    intros E; rewrite E; auto with arith ].
+ destruct n, m; simpl; congruence.
 Qed.
 
-Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m.
+Lemma inj_iff n m : Z.of_N n = Z.of_N m <-> n = m.
 Proof.
-  intros x y H.
-  destruct (eq_nat_dec x y) as [H'|H']; auto.
-  exfalso.
-  exact (inj_neq _ _ H' H).
+ split. apply inj. intros; now f_equal.
 Qed.
 
-Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m.
+(** [Z.of_N] produce non-negative integers *)
+
+Lemma is_nonneg n : 0 <= Z.of_N n.
 Proof.
- split; [apply inj_eq | apply inj_eq_rev].
+ now destruct n.
 Qed.
 
+(** [Z.of_N], basic equations *)
+
+Lemma inj_0 : Z.of_N 0 = 0.
+Proof.
+ reflexivity.
+Qed.
 
-(** Injection and order relations: *)
+Lemma inj_pos p : Z.of_N (Npos p) = Zpos p.
+Proof.
+ reflexivity.
+Qed.
 
-(** One way ... *)
+(** [Z.of_N] and usual operations. *)
 
-Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
+Lemma inj_compare n m : (Z.of_N n ?= Z.of_N m) = (n ?= m)%N.
 Proof.
-  intros x y; intros H; elim H;
-    [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x));
-      intros H1 H2; rewrite H2; [ discriminate | trivial with arith ]
-      | intros m H1 H2; apply Zle_trans with (Z_of_nat m);
-	[ assumption | rewrite inj_S; apply Zle_succ ] ].
+ now destruct n, m.
 Qed.
 
-Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
+Lemma inj_le n m : (n<=m)%N <-> Z.of_N n <= Z.of_N m.
 Proof.
-  intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le;
-    exact H.
+ unfold Z.le. now rewrite inj_compare.
 Qed.
 
-Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
+Lemma inj_lt n m : (n<m)%N <-> Z.of_N n < Z.of_N m.
 Proof.
-  intros x y H; apply Zle_ge; apply inj_le; apply H.
+ unfold Z.lt. now rewrite inj_compare.
 Qed.
 
-Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
+Lemma inj_ge n m : (n>=m)%N <-> Z.of_N n >= Z.of_N m.
 Proof.
-  intros x y H; apply Zlt_gt; apply inj_lt; exact H.
+ unfold Z.ge. now rewrite inj_compare.
 Qed.
 
-(** The other way ... *)
+Lemma inj_gt n m : (n>m)%N <-> Z.of_N n > Z.of_N m.
+Proof.
+ unfold Z.gt. now rewrite inj_compare.
+Qed.
 
-Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat.
+Lemma inj_abs_N z : Z.of_N (Z.abs_N z) = Z.abs z.
 Proof.
-  intros x y H.
-  destruct (le_lt_dec x y) as [H0|H0]; auto.
-  exfalso.
-  assert (H1:=inj_lt _ _ H0).
-  red in H; red in H1.
-  rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
+ now destruct z.
 Qed.
 
-Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
+Lemma inj_add n m : Z.of_N (n+m) = Z.of_N n + Z.of_N m.
 Proof.
-  intros x y H.
-  destruct (le_lt_dec y x) as [H0|H0]; auto.
-  exfalso.
-  assert (H1:=inj_le _ _ H0).
-  red in H; red in H1.
-  rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
+ now destruct n, m.
 Qed.
 
-Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat.
+Lemma inj_mul n m : Z.of_N (n*m) = Z.of_N n * Z.of_N m.
 Proof.
-  intros x y H.
-  destruct (le_lt_dec y x) as [H0|H0]; auto.
-  exfalso.
-  assert (H1:=inj_gt _ _ H0).
-  red in H; red in H1.
-  rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
+ now destruct n, m.
 Qed.
 
-Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat.
+Lemma inj_sub_max n m : Z.of_N (n-m) = Z.max 0 (Z.of_N n - Z.of_N m).
 Proof.
-  intros x y H.
-  destruct (le_lt_dec x y) as [H0|H0]; auto.
-  exfalso.
-  assert (H1:=inj_ge _ _ H0).
-  red in H; red in H1.
-  rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
+ destruct n as [|n], m as [|m]; simpl; trivial.
+ rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub.
+ now destruct (Pos.sub_mask n m).
 Qed.
 
-(* Both ways ... *)
+Lemma inj_sub n m : (m<=n)%N -> Z.of_N (n-m) = Z.of_N n - Z.of_N m.
+Proof.
+ intros H. rewrite inj_sub_max.
+ unfold N.le in H.
+ rewrite N.compare_antisym, <- inj_compare, Z.compare_sub in H.
+ destruct (Z.of_N n - Z.of_N m); trivial; now destruct H.
+Qed.
 
-Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m.
+Lemma inj_succ n : Z.of_N (N.succ n) = Z.succ (Z.of_N n).
 Proof.
- split; [apply inj_le | apply inj_le_rev].
+ destruct n. trivial. simpl. now rewrite Pos.add_1_r.
 Qed.
 
-Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m.
+Lemma inj_pred_max n : Z.of_N (N.pred n) = Z.max 0 (Z.pred (Z.of_N n)).
 Proof.
- split; [apply inj_lt | apply inj_lt_rev].
+ unfold Z.pred. now rewrite N.pred_sub, inj_sub_max.
 Qed.
 
-Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m.
+Lemma inj_pred n : (0<n)%N -> Z.of_N (N.pred n) = Z.pred (Z.of_N n).
 Proof.
- split; [apply inj_ge | apply inj_ge_rev].
+ intros H. unfold Z.pred. rewrite N.pred_sub, inj_sub; trivial.
+ now apply N.le_succ_l in H.
 Qed.
 
-Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m.
+Lemma inj_min n m : Z.of_N (N.min n m) = Z.min (Z.of_N n) (Z.of_N m).
 Proof.
- split; [apply inj_gt | apply inj_gt_rev].
+ unfold Z.min, N.min. rewrite inj_compare. now case N.compare.
 Qed.
 
-(** Injection and usual operations *)
+Lemma inj_max n m : Z.of_N (N.max n m) = Z.max (Z.of_N n) (Z.of_N m).
+Proof.
+ unfold Z.max, N.max. rewrite inj_compare.
+ case N.compare_spec; intros; subst; trivial.
+Qed.
 
-Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
+Lemma inj_div n m : Z.of_N (n/m) = Z.of_N n / Z.of_N m.
 Proof.
-  intro x; induction x as [| n H]; intro y; destruct y as [| m];
-    [ simpl in |- *; trivial with arith
-      | simpl in |- *; trivial with arith
-      | simpl in |- *; rewrite <- plus_n_O; trivial with arith
-      | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *;
-	rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l;
-	  trivial with arith ].
+ destruct m as [|m]. now destruct n.
+ apply Z.div_unique_pos with (Z.of_N (n mod (Npos m))).
+ split. apply is_nonneg. apply inj_lt. now apply N.mod_lt.
+ rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod.
 Qed.
 
-Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
+Lemma inj_mod n m : (m<>0)%N -> Z.of_N (n mod m) = (Z.of_N n) mod (Z.of_N m).
 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;
-	  trivial with arith ].
+ intros Hm.
+ apply Z.mod_unique_pos with (Z.of_N (n / m)).
+ split. apply is_nonneg. apply inj_lt. now apply N.mod_lt.
+ rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod.
 Qed.
 
-Theorem inj_minus1 :
-  forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
+Lemma inj_quot n m : Z.of_N (n/m) = Z.of_N n ÷ Z.of_N m.
 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;
-        trivial with arith.
+ destruct m.
+ - now destruct n.
+ - rewrite Z.quot_div_nonneg, inj_div; trivial. apply is_nonneg. easy.
 Qed.
 
-Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
+Lemma inj_rem n m : Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m).
 Proof.
-  intros x y H; rewrite not_le_minus_0;
-    [ trivial with arith | apply gt_not_le; assumption ].
+ destruct m.
+ - now destruct n.
+ - rewrite Z.rem_mod_nonneg, inj_mod; trivial. easy. apply is_nonneg. easy.
 Qed.
 
-Theorem inj_minus : forall n m:nat,
- Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m).
+Lemma inj_div2 n : Z.of_N (N.div2 n) = Z.div2 (Z.of_N n).
 Proof.
- intros.
- rewrite Zmax_comm.
- unfold Zmax.
- destruct (le_lt_dec m n) as [H|H].
+ destruct n as [|p]; trivial. now destruct p.
+Qed.
 
- rewrite (inj_minus1 _ _ H).
- assert (H':=Zle_minus_le_0 _ _ (inj_le _ _ H)).
- unfold Zle in H'.
- rewrite <- Zcompare_antisym in H'.
- destruct Zcompare; simpl in *; intuition.
+Lemma inj_quot2 n : Z.of_N (N.div2 n) = Z.quot2 (Z.of_N n).
+Proof.
+ destruct n as [|p]; trivial. now destruct p.
+Qed.
 
- rewrite (inj_minus2 _ _ H).
- assert (H':=Zplus_lt_compat_r _ _ (- Z_of_nat m) (inj_lt _ _ H)).
- rewrite Zplus_opp_r in H'.
- unfold Zminus; rewrite H'; auto.
+Lemma inj_pow n m : Z.of_N (n^m) = (Z.of_N n)^(Z.of_N m).
+Proof.
+ symmetry. destruct n, m; trivial. now apply Z.pow_0_l. apply Z.pow_Zpos.
 Qed.
 
-Theorem inj_min : forall n m:nat,
-  Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m).
+End N2Z.
+
+Module Z2N.
+
+(** [Z.to_N] is a bijection between non-negative [Z] and [N],
+    with [Pos.of_N] as reciprocal.
+    See [N2Z.id] above for the dual equation. *)
+
+Lemma id n : 0<=n -> Z.of_N (Z.to_N n) = n.
 Proof.
- induction n; destruct m; try (compute; auto; fail).
- simpl min.
- do 3 rewrite inj_S.
- rewrite <- Zsucc_min_distr; f_equal; auto.
+ destruct n; (now destruct 1) || trivial.
 Qed.
 
-Theorem inj_max : forall n m:nat,
-  Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m).
+(** [Z.to_N] is hence injective for non-negative integers. *)
+
+Lemma inj n m : 0<=n -> 0<=m -> Z.to_N n = Z.to_N m -> n = m.
 Proof.
- induction n; destruct m; try (compute; auto; fail).
- simpl max.
- do 3 rewrite inj_S.
- rewrite <- Zsucc_max_distr; f_equal; auto.
+ intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
 Qed.
 
-(** Composition of injections **)
+Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_N n = Z.to_N m <-> n = m).
+Proof.
+ intros. split. now apply inj. intros; now subst.
+Qed.
+
+(** [Z.to_N], basic equations *)
+
+Lemma inj_0 : Z.to_N 0 = 0%N.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_pos n : Z.to_N (Zpos n) = Npos n.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_neg n : Z.to_N (Zneg n) = 0%N.
+Proof.
+ reflexivity.
+Qed.
+
+(** [Z.to_N] and operations *)
+
+Lemma inj_add n m : 0<=n -> 0<=m -> Z.to_N (n+m) = (Z.to_N n + Z.to_N m)%N.
+Proof.
+ destruct n, m; trivial; (now destruct 1) || (now destruct 2).
+Qed.
+
+Lemma inj_mul n m : 0<=n -> 0<=m -> Z.to_N (n*m) = (Z.to_N n * Z.to_N m)%N.
+Proof.
+ destruct n, m; trivial; (now destruct 1) || (now destruct 2).
+Qed.
+
+Lemma inj_succ n : 0<=n -> Z.to_N (Z.succ n) = N.succ (Z.to_N n).
+Proof.
+ unfold Z.succ. intros. rewrite inj_add by easy. apply N.add_1_r.
+Qed.
+
+Lemma inj_sub n m : 0<=m -> Z.to_N (n - m) = (Z.to_N n - Z.to_N m)%N.
+Proof.
+ destruct n as [|n|n], m as [|m|m]; trivial; try (now destruct 1).
+ intros _. simpl.
+ rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub.
+ now destruct (Pos.sub_mask n m).
+Qed.
+
+Lemma inj_pred n : Z.to_N (Z.pred n) = N.pred (Z.to_N n).
+Proof.
+ unfold Z.pred. rewrite <- N.sub_1_r. now apply (inj_sub n 1).
+Qed.
+
+Lemma inj_compare n m : 0<=n -> 0<=m ->
+ (Z.to_N n ?= Z.to_N m)%N = (n ?= m).
+Proof.
+ intros Hn Hm. now rewrite <- N2Z.inj_compare, !id.
+Qed.
+
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_N n <= Z.to_N m)%N).
+Proof.
+ intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare.
+Qed.
+
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_N n < Z.to_N m)%N).
+Proof.
+ intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare.
+Qed.
+
+Lemma inj_min n m : Z.to_N (Z.min n m) = N.min (Z.to_N n) (Z.to_N m).
+Proof.
+ destruct n, m; simpl; trivial; unfold Z.min, N.min; simpl;
+  now case Pos.compare.
+Qed.
+
+Lemma inj_max n m : Z.to_N (Z.max n m) = N.max (Z.to_N n) (Z.to_N m).
+Proof.
+ destruct n, m; simpl; trivial; unfold Z.max, N.max; simpl.
+  case Pos.compare_spec; intros; subst; trivial.
+  now case Pos.compare.
+Qed.
+
+Lemma inj_div n m : 0<=n -> 0<=m -> Z.to_N (n/m) = (Z.to_N n / Z.to_N m)%N.
+Proof.
+ destruct n, m; trivial; intros Hn Hm;
+ (now destruct Hn) || (now destruct Hm) || clear.
+ simpl. rewrite <- (N2Z.id (_ / _)). f_equal. now rewrite N2Z.inj_div.
+Qed.
+
+Lemma inj_mod n m : 0<=n -> 0<m ->
+ Z.to_N (n mod m) = ((Z.to_N n) mod (Z.to_N m))%N.
+Proof.
+ destruct n, m; trivial; intros Hn Hm;
+ (now destruct Hn) || (now destruct Hm) || clear.
+ simpl. rewrite <- (N2Z.id (_ mod _)). f_equal. now rewrite N2Z.inj_mod.
+Qed.
 
-Theorem Zpos_eq_Z_of_nat_o_nat_of_P :
-  forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
+Lemma inj_quot n m : 0<=n -> 0<=m -> Z.to_N (n÷m) = (Z.to_N n / Z.to_N m)%N.
 Proof.
-  intros x; elim x; simpl in |- *; auto.
-  intros p H; rewrite ZL6.
-  apply f_equal with (f := Zpos).
-  apply nat_of_P_inj.
-  rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *;
-    simpl in |- *.
-  rewrite ZL6; auto.
-  intros p H; unfold nat_of_P in |- *; simpl in |- *.
-  rewrite ZL6; simpl in |- *.
-  rewrite inj_plus; repeat rewrite <- H.
-  rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity.
+ destruct m.
+ - now destruct n.
+ - intros. now rewrite Z.quot_div_nonneg, inj_div.
+ - now destruct 2.
 Qed.
 
-(** Misc *)
+Lemma inj_rem n m :0<=n -> 0<=m ->
+ Z.to_N (Z.rem n m) = ((Z.to_N n) mod (Z.to_N m))%N.
+Proof.
+ destruct m.
+ - now destruct n.
+ - intros. now rewrite Z.rem_mod_nonneg, inj_mod.
+ - now destruct 2.
+Qed.
+
+Lemma inj_div2 n : Z.to_N (Z.div2 n) = N.div2 (Z.to_N n).
+Proof.
+ destruct n as [|p|p]; trivial. now destruct p.
+Qed.
+
+Lemma inj_quot2 n : Z.to_N (Z.quot2 n) = N.div2 (Z.to_N n).
+Proof.
+ destruct n as [|p|p]; trivial; now destruct p.
+Qed.
+
+Lemma inj_pow n m : 0<=n -> 0<=m -> Z.to_N (n^m) = ((Z.to_N n)^(Z.to_N m))%N.
+Proof.
+ destruct m.
+ - trivial.
+ - intros. now rewrite <- (N2Z.id (_ ^ _)), N2Z.inj_pow, id.
+ - now destruct 2.
+Qed.
+
+End Z2N.
+
+Module Zabs2N.
+
+(** Results about [Z.abs_N], converting absolute values of [Z] integers
+    to [N]. *)
+
+Lemma abs_N_spec n : Z.abs_N n = Z.to_N (Z.abs n).
+Proof.
+ now destruct n.
+Qed.
+
+Lemma abs_N_nonneg n : 0<=n -> Z.abs_N n = Z.to_N n.
+Proof.
+ destruct n; trivial; now destruct 1.
+Qed.
+
+Lemma id_abs n : Z.of_N (Z.abs_N n) = Z.abs n.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma id n : Z.abs_N (Z.of_N n) = n.
+Proof.
+ now destruct n.
+Qed.
+
+(** [Z.abs_N], basic equations *)
+
+Lemma inj_0 : Z.abs_N 0 = 0%N.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_pos p : Z.abs_N (Zpos p) = Npos p.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_neg p : Z.abs_N (Zneg p) = Npos p.
+Proof.
+ reflexivity.
+Qed.
+
+(** [Z.abs_N] and usual operations, with non-negative integers *)
+
+Lemma inj_opp n : Z.abs_N (-n) = Z.abs_N n.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma inj_succ n : 0<=n -> Z.abs_N (Z.succ n) = N.succ (Z.abs_N n).
+Proof.
+ intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_succ.
+ now apply Z.le_le_succ_r.
+Qed.
+
+Lemma inj_add n m : 0<=n -> 0<=m -> Z.abs_N (n+m) = (Z.abs_N n + Z.abs_N m)%N.
+Proof.
+ intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_add.
+ now apply Z.add_nonneg_nonneg.
+Qed.
+
+Lemma inj_mul n m : Z.abs_N (n*m) = (Z.abs_N n * Z.abs_N m)%N.
+Proof.
+ now destruct n, m.
+Qed.
+
+Lemma inj_sub n m : 0<=m<=n -> Z.abs_N (n-m) = (Z.abs_N n - Z.abs_N m)%N.
+Proof.
+ intros (Hn,H). rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_sub.
+ Z.order.
+ now apply Z.le_0_sub.
+Qed.
+
+Lemma inj_pred n : 0<n -> Z.abs_N (Z.pred n) = N.pred (Z.abs_N n).
+Proof.
+ intros. rewrite !abs_N_nonneg. now apply Z2N.inj_pred.
+ Z.order.
+ apply Z.lt_succ_r. now rewrite Z.succ_pred.
+Qed.
+
+Lemma inj_compare n m : 0<=n -> 0<=m ->
+ (Z.abs_N n ?= Z.abs_N m)%N = (n ?= m).
+Proof.
+ intros. rewrite !abs_N_nonneg by trivial. now apply Z2N.inj_compare.
+Qed.
+
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_N n <= Z.abs_N m)%N).
+Proof.
+ intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare.
+Qed.
+
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_N n < Z.abs_N m)%N).
+Proof.
+ intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare.
+Qed.
+
+Lemma inj_min n m : 0<=n -> 0<=m ->
+ Z.abs_N (Z.min n m) = N.min (Z.abs_N n) (Z.abs_N m).
+Proof.
+ intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_min.
+ now apply Z.min_glb.
+Qed.
+
+Lemma inj_max n m : 0<=n -> 0<=m ->
+ Z.abs_N (Z.max n m) = N.max (Z.abs_N n) (Z.abs_N m).
+Proof.
+ intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_max.
+ transitivity n; trivial. apply Z.le_max_l.
+Qed.
+
+Lemma inj_quot n m : Z.abs_N (n÷m) = ((Z.abs_N n) / (Z.abs_N m))%N.
+Proof.
+ assert (forall p q, Z.abs_N (Zpos p ÷ Zpos q) = (Npos p / Npos q)%N).
+  intros. rewrite abs_N_nonneg. now apply Z2N.inj_quot. now apply Z.quot_pos.
+ destruct n, m; trivial; simpl.
+ - trivial.
+ - now rewrite <- Z.opp_Zpos, Z.quot_opp_r, inj_opp.
+ - now rewrite <- Z.opp_Zpos, Z.quot_opp_l, inj_opp.
+ - now rewrite <- 2 Z.opp_Zpos, Z.quot_opp_opp.
+Qed.
+
+Lemma inj_rem n m : Z.abs_N (Z.rem n m) = ((Z.abs_N n) mod (Z.abs_N m))%N.
+Proof.
+ assert
+  (forall p q, Z.abs_N (Z.rem (Zpos p) (Zpos q)) = ((Npos p) mod (Npos q))%N).
+  intros. rewrite abs_N_nonneg. now apply Z2N.inj_rem. now apply Z.rem_nonneg.
+ destruct n, m; trivial; simpl.
+ - trivial.
+ - now rewrite <- Z.opp_Zpos, Z.rem_opp_r.
+ - now rewrite <- Z.opp_Zpos, Z.rem_opp_l, inj_opp.
+ - now rewrite <- 2 Z.opp_Zpos, Z.rem_opp_opp, inj_opp.
+Qed.
+
+Lemma inj_pow n m : 0<=m -> Z.abs_N (n^m) = ((Z.abs_N n)^(Z.abs_N m))%N.
+Proof.
+ intros Hm. rewrite abs_N_spec, Z.abs_pow, Z2N.inj_pow, <- abs_N_spec; trivial.
+ f_equal. symmetry; now apply abs_N_nonneg. apply Z.abs_nonneg.
+Qed.
+
+(** [Z.abs_N] and usual operations, statements with [Z.abs] *)
+
+Lemma inj_succ_abs n : Z.abs_N (Z.succ (Z.abs n)) = N.succ (Z.abs_N n).
+Proof.
+ destruct n; simpl; trivial; now rewrite Pos.add_1_r.
+Qed.
+
+Lemma inj_add_abs n m :
+ Z.abs_N (Z.abs n + Z.abs m) = (Z.abs_N n + Z.abs_N m)%N.
+Proof.
+ now destruct n, m.
+Qed.
+
+Lemma inj_mul_abs n m :
+ Z.abs_N (Z.abs n * Z.abs m) = (Z.abs_N n * Z.abs_N m)%N.
+Proof.
+ now destruct n, m.
+Qed.
+
+End Zabs2N.
+
+
+(** * Conversions between [Z] and [nat] *)
+
+Module Nat2Z.
+
+(** [Z.of_nat], basic equations *)
 
-Theorem intro_Z :
-  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+Lemma inj_0 : Z.of_nat 0 = 0.
 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 |- *;
-          discriminate ].
+ reflexivity.
 Qed.
 
-Lemma Zpos_P_of_succ_nat : forall n:nat,
- Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
+Lemma inj_succ n : Z.of_nat (S n) = Z.succ (Z.of_nat n).
+Proof.
+ destruct n. trivial. simpl. symmetry. apply Z.succ_Zpos.
+Qed.
+
+(** [Z.of_N] produce non-negative integers *)
+
+Lemma is_nonneg n : 0 <= Z.of_nat n.
+Proof.
+ now induction n.
+Qed.
+
+(** [Z.of_nat] is a bijection between [nat] and non-negative [Z],
+    with [Z.to_nat] (or [Z.abs_nat]) as reciprocal.
+    See [Z2Nat.id] below for the dual equation. *)
+
+Lemma id n : Z.to_nat (Z.of_nat n) = n.
+Proof.
+ now rewrite <- nat_N_Z, <- Z_N_nat, N2Z.id, Nat2N.id.
+Qed.
+
+(** [Z.of_nat] is hence injective *)
+
+Lemma inj n m : Z.of_nat n = Z.of_nat m -> n = m.
+Proof.
+ intros H. now rewrite <- (id n), <- (id m), H.
+Qed.
+
+Lemma inj_iff n m : Z.of_nat n = Z.of_nat m <-> n = m.
+Proof.
+ split. apply inj. intros; now f_equal.
+Qed.
+
+(** [Z.of_nat] and usual operations *)
+
+Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = nat_compare n m.
+Proof.
+ now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare.
+Qed.
+
+Lemma inj_le n m : (n<=m)%nat <-> Z.of_nat n <= Z.of_nat m.
+Proof.
+ unfold Z.le. now rewrite inj_compare, nat_compare_le.
+Qed.
+
+Lemma inj_lt n m : (n<m)%nat <-> Z.of_nat n < Z.of_nat m.
+Proof.
+ unfold Z.lt. now rewrite inj_compare, nat_compare_lt.
+Qed.
+
+Lemma inj_ge n m : (n>=m)%nat <-> Z.of_nat n >= Z.of_nat m.
+Proof.
+ unfold Z.ge. now rewrite inj_compare, nat_compare_ge.
+Qed.
+
+Lemma inj_gt n m : (n>m)%nat <-> Z.of_nat n > Z.of_nat m.
+Proof.
+ unfold Z.gt. now rewrite inj_compare, nat_compare_gt.
+Qed.
+
+Lemma inj_abs_nat z : Z.of_nat (Z.abs_nat z) = Z.abs z.
+Proof.
+ destruct z; simpl; trivial;
+  destruct (Pos2Nat.is_succ p) as (n,H); rewrite H; simpl; f_equal;
+   now apply SuccNat2Pos.inv.
+Qed.
+
+Lemma inj_add n m : Z.of_nat (n+m) = Z.of_nat n + Z.of_nat m.
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_add, N2Z.inj_add.
+Qed.
+
+Lemma inj_mul n m : Z.of_nat (n*m) = Z.of_nat n * Z.of_nat m.
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_mul, N2Z.inj_mul.
+Qed.
+
+Lemma inj_sub_max n m : Z.of_nat (n-m) = Z.max 0 (Z.of_nat n - Z.of_nat m).
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub_max.
+Qed.
+
+Lemma inj_sub n m : (m<=n)%nat -> Z.of_nat (n-m) = Z.of_nat n - Z.of_nat m.
+Proof.
+ rewrite nat_compare_le, Nat2N.inj_compare. intros.
+ now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub.
+Qed.
+
+Lemma inj_pred_max n : Z.of_nat (pred n) = Z.max 0 (Z.pred (Z.of_nat n)).
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max.
+Qed.
+
+Lemma inj_pred n : (0<n)%nat -> Z.of_nat (pred n) = Z.pred (Z.of_nat n).
+Proof.
+ rewrite nat_compare_lt, Nat2N.inj_compare. intros.
+ now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred.
+Qed.
+
+Lemma inj_min n m : Z.of_nat (min n m) = Z.min (Z.of_nat n) (Z.of_nat m).
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min.
+Qed.
+
+Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m).
+Proof.
+ now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max.
+Qed.
+
+End Nat2Z.
+
+Module Z2Nat.
+
+(** [Z.to_nat] is a bijection between non-negative [Z] and [nat],
+    with [Pos.of_nat] as reciprocal.
+    See [nat2Z.id] above for the dual equation. *)
+
+Lemma id n : 0<=n -> Z.of_nat (Z.to_nat n) = n.
+Proof.
+ intros. now rewrite <- Z_N_nat, <- nat_N_Z, N2Nat.id, Z2N.id.
+Qed.
+
+(** [Z.to_nat] is hence injective for non-negative integers. *)
+
+Lemma inj n m : 0<=n -> 0<=m -> Z.to_nat n = Z.to_nat m -> n = m.
+Proof.
+ intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
+Qed.
+
+Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_nat n = Z.to_nat m <-> n = m).
+Proof.
+ intros. split. now apply inj. intros; now subst.
+Qed.
+
+(** [Z.to_nat], basic equations *)
+
+Lemma inj_0 : Z.to_nat 0 = O.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_pos n : Z.to_nat (Zpos n) = Pos.to_nat n.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_neg n : Z.to_nat (Zneg n) = O.
+Proof.
+ reflexivity.
+Qed.
+
+(** [Z.to_nat] and operations *)
+
+Lemma inj_add n m : 0<=n -> 0<=m ->
+ Z.to_nat (n+m) = (Z.to_nat n + Z.to_nat m)%nat.
+Proof.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_add, N2Nat.inj_add.
+Qed.
+
+Lemma inj_mul n m : 0<=n -> 0<=m ->
+ Z.to_nat (n*m) = (Z.to_nat n * Z.to_nat m)%nat.
+Proof.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_mul, N2Nat.inj_mul.
+Qed.
+
+Lemma inj_succ n : 0<=n -> Z.to_nat (Z.succ n) = S (Z.to_nat n).
+Proof.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_succ, N2Nat.inj_succ.
+Qed.
+
+Lemma inj_sub n m : 0<=m -> Z.to_nat (n - m) = (Z.to_nat n - Z.to_nat m)%nat.
+Proof.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub.
+Qed.
+
+Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n).
+Proof.
+ now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred.
+Qed.
+
+Lemma inj_compare n m : 0<=n -> 0<=m ->
+ nat_compare (Z.to_nat n) (Z.to_nat m) = (n ?= m).
+Proof.
+ intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id.
+Qed.
+
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_nat n <= Z.to_nat m)%nat).
+Proof.
+ intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
+Qed.
+
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_nat n < Z.to_nat m)%nat).
+Proof.
+ intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
+Qed.
+
+Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat m).
+Proof.
+ now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min.
+Qed.
+
+Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat m).
+Proof.
+ now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max.
+Qed.
+
+End Z2Nat.
+
+Module Zabs2Nat.
+
+(** Results about [Z.abs_nat], converting absolute values of [Z] integers
+    to [nat]. *)
+
+Lemma abs_nat_spec n : Z.abs_nat n = Z.to_nat (Z.abs n).
+Proof.
+ now destruct n.
+Qed.
+
+Lemma abs_nat_nonneg n : 0<=n -> Z.abs_nat n = Z.to_nat n.
+Proof.
+ destruct n; trivial; now destruct 1.
+Qed.
+
+Lemma id_abs n : Z.of_nat (Z.abs_nat n) = Z.abs n.
+Proof.
+ rewrite <-Zabs_N_nat, N_nat_Z. apply Zabs2N.id_abs.
+Qed.
+
+Lemma id n : Z.abs_nat (Z.of_nat n) = n.
+Proof.
+ now rewrite <-Zabs_N_nat, <-nat_N_Z, Zabs2N.id, Nat2N.id.
+Qed.
+
+(** [Z.abs_nat], basic equations *)
+
+Lemma inj_0 : Z.abs_nat 0 = 0%nat.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_pos p : Z.abs_nat (Zpos p) = Pos.to_nat p.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_neg p : Z.abs_nat (Zneg p) = Pos.to_nat p.
+Proof.
+ reflexivity.
+Qed.
+
+(** [Z.abs_nat] and usual operations, with non-negative integers *)
+
+Lemma inj_succ n : 0<=n -> Z.abs_nat (Z.succ n) = S (Z.abs_nat n).
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ, N2Nat.inj_succ.
+Qed.
+
+Lemma inj_add n m : 0<=n -> 0<=m ->
+ Z.abs_nat (n+m) = (Z.abs_nat n + Z.abs_nat m)%nat.
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_add, N2Nat.inj_add.
+Qed.
+
+Lemma inj_mul n m : Z.abs_nat (n*m) = (Z.abs_nat n * Z.abs_nat m)%nat.
+Proof.
+ destruct n, m; simpl; trivial using Pos2Nat.inj_mul.
+Qed.
+
+Lemma inj_sub n m : 0<=m<=n ->
+ Z.abs_nat (n-m) = (Z.abs_nat n - Z.abs_nat m)%nat.
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub.
+Qed.
+
+Lemma inj_pred n : 0<n -> Z.abs_nat (Z.pred n) = pred (Z.abs_nat n).
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred.
+Qed.
+
+Lemma inj_compare n m : 0<=n -> 0<=m ->
+ nat_compare (Z.abs_nat n) (Z.abs_nat m) = (n ?= m).
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare.
+Qed.
+
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_nat n <= Z.abs_nat m)%nat).
+Proof.
+ intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
+Qed.
+
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_nat n < Z.abs_nat m)%nat).
+Proof.
+ intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
+Qed.
+
+Lemma inj_min n m : 0<=n -> 0<=m ->
+ Z.abs_nat (Z.min n m) = min (Z.abs_nat n) (Z.abs_nat m).
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min.
+Qed.
+
+Lemma inj_max n m : 0<=n -> 0<=m ->
+ Z.abs_nat (Z.max n m) = max (Z.abs_nat n) (Z.abs_nat m).
+Proof.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max.
+Qed.
+
+(** [Z.abs_nat] and usual operations, statements with [Z.abs] *)
+
+Lemma inj_succ_abs n : Z.abs_nat (Z.succ (Z.abs n)) = S (Z.abs_nat n).
+Proof.
+ now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ_abs, N2Nat.inj_succ.
+Qed.
+
+Lemma inj_add_abs n m :
+ Z.abs_nat (Z.abs n + Z.abs m) = (Z.abs_nat n + Z.abs_nat m)%nat.
+Proof.
+ now rewrite <- !Zabs_N_nat, Zabs2N.inj_add_abs, N2Nat.inj_add.
+Qed.
+
+Lemma inj_mul_abs n m :
+ Z.abs_nat (Z.abs n * Z.abs m) = (Z.abs_nat n * Z.abs_nat m)%nat.
+Proof.
+ now rewrite <- !Zabs_N_nat, Zabs2N.inj_mul_abs, N2Nat.inj_mul.
+Qed.
+
+End Zabs2Nat.
+
+
+(** Compatibility *)
+
+Definition neq (x y:nat) := x <> y.
+
+Lemma inj_neq n m : neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
+Proof. intros H H'. now apply H, Nat2Z.inj. Qed.
+
+Lemma Zpos_P_of_succ_nat n : Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
+Proof (Nat2Z.inj_succ n).
+
+(** For these one, used in omega, a Definition is necessary *)
+
+Definition inj_eq := (f_equal Z.of_nat).
+Definition inj_le n m := proj1 (Nat2Z.inj_le n m).
+Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m).
+Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m).
+Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m).
+
+(** For the others, a Notation is fine *)
+
+Notation inj_0 := Nat2Z.inj_0 (only parsing).
+Notation inj_S := Nat2Z.inj_succ (only parsing).
+Notation inj_compare := Nat2Z.inj_compare (only parsing).
+Notation inj_eq_rev := Nat2Z.inj (only parsing).
+Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (only parsing).
+Notation inj_le_iff := Nat2Z.inj_le (only parsing).
+Notation inj_lt_iff := Nat2Z.inj_lt (only parsing).
+Notation inj_ge_iff := Nat2Z.inj_ge (only parsing).
+Notation inj_gt_iff := Nat2Z.inj_gt (only parsing).
+Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (only parsing).
+Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (only parsing).
+Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (only parsing).
+Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (only parsing).
+Notation inj_plus := Nat2Z.inj_add (only parsing).
+Notation inj_mult := Nat2Z.inj_mul (only parsing).
+Notation inj_minus1 := Nat2Z.inj_sub (only parsing).
+Notation inj_minus := Nat2Z.inj_sub_max (only parsing).
+Notation inj_min := Nat2Z.inj_min (only parsing).
+Notation inj_max := Nat2Z.inj_max (only parsing).
+
+Notation Z_of_nat_of_P := positive_nat_Z (only parsing).
+Notation Zpos_eq_Z_of_nat_o_nat_of_P :=
+  (fun p => sym_eq (positive_nat_Z p)) (only parsing).
+
+Notation Z_of_nat_of_N := N_nat_Z (only parsing).
+Notation Z_of_N_of_nat := nat_N_Z (only parsing).
+
+Notation Z_of_N_eq := (f_equal Z.of_N) (only parsing).
+Notation Z_of_N_eq_rev := N2Z.inj (only parsing).
+Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (only parsing).
+Notation Z_of_N_compare := N2Z.inj_compare (only parsing).
+Notation Z_of_N_le_iff := N2Z.inj_le (only parsing).
+Notation Z_of_N_lt_iff := N2Z.inj_lt (only parsing).
+Notation Z_of_N_ge_iff := N2Z.inj_ge (only parsing).
+Notation Z_of_N_gt_iff := N2Z.inj_gt (only parsing).
+Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (only parsing).
+Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (only parsing).
+Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (only parsing).
+Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (only parsing).
+Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (only parsing).
+Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (only parsing).
+Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (only parsing).
+Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (only parsing).
+Notation Z_of_N_pos := N2Z.inj_pos (only parsing).
+Notation Z_of_N_abs := N2Z.inj_abs_N (only parsing).
+Notation Z_of_N_le_0 := N2Z.is_nonneg (only parsing).
+Notation Z_of_N_plus := N2Z.inj_add (only parsing).
+Notation Z_of_N_mult := N2Z.inj_mul (only parsing).
+Notation Z_of_N_minus := N2Z.inj_sub_max (only parsing).
+Notation Z_of_N_succ := N2Z.inj_succ (only parsing).
+Notation Z_of_N_min := N2Z.inj_min (only parsing).
+Notation Z_of_N_max := N2Z.inj_max (only parsing).
+Notation Zabs_of_N := Zabs2N.id (only parsing).
+Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (only parsing).
+Notation Zabs_N_succ := Zabs2N.inj_succ (only parsing).
+Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (only parsing).
+Notation Zabs_N_plus := Zabs2N.inj_add (only parsing).
+Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (only parsing).
+Notation Zabs_N_mult := Zabs2N.inj_mul (only parsing).
+
+Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
 Proof.
-  intros.
-  unfold Z_of_nat.
-  destruct n.
-  simpl; auto.
-  simpl (P_of_succ_nat (S n)).
-  apply Zpos_succ_morphism.
+ intros. rewrite not_le_minus_0; auto with arith.
 Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index 26ff4251..6eb1a709 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -1,19 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znumtheory.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 Require Import ZArith_base.
 Require Import ZArithRing.
 Require Import Zcomplements.
 Require Import Zdiv.
 Require Import Wf_nat.
-Open Local Scope Z_scope.
+
+(** For compatibility reasons, this Open Scope isn't local as it should *)
+
+Open Scope Z_scope.
 
 (** This file contains some notions of number theory upon Z numbers:
      - a divisibility predicate [Zdivide]
@@ -21,308 +22,173 @@ Open Local Scope Z_scope.
      - Euclid algorithm [euclid]
      - a relatively prime predicate [rel_prime]
      - a prime predicate [prime]
-     - an efficient [Zgcd] function
+     - properties of the efficient [Z.gcd] function
 *)
 
-(** * Divisibility *)
+Notation Zgcd := Z.gcd (only parsing).
+Notation Zggcd := Z.ggcd (only parsing).
+Notation Zggcd_gcd := Z.ggcd_gcd (only parsing).
+Notation Zggcd_correct_divisors := Z.ggcd_correct_divisors (only parsing).
+Notation Zgcd_divide_l := Z.gcd_divide_l (only parsing).
+Notation Zgcd_divide_r := Z.gcd_divide_r (only parsing).
+Notation Zgcd_greatest := Z.gcd_greatest (only parsing).
+Notation Zgcd_nonneg := Z.gcd_nonneg (only parsing).
+Notation Zggcd_opp := Z.ggcd_opp (only parsing).
 
-Inductive Zdivide (a b:Z) : Prop :=
-    Zdivide_intro : forall q:Z, b = q * a -> Zdivide a b.
+(** The former specialized inductive predicate [Zdivide] is now
+    a generic existential predicate. *)
 
-(** Syntax for divisibility *)
+Notation Zdivide := Z.divide (only parsing).
 
-Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope.
+(** Its former constructor is now a pseudo-constructor. *)
 
-(** Results concerning divisibility*)
+Definition Zdivide_intro a b q (H:b=q*a) : Z.divide a b := ex_intro _ q H.
 
-Lemma Zdivide_refl : forall a:Z, (a | a).
-Proof.
-  intros; apply Zdivide_intro with 1; ring.
-Qed.
-
-Lemma Zone_divide : forall a:Z, (1 | a).
-Proof.
-  intros; apply Zdivide_intro with a; ring.
-Qed.
-
-Lemma Zdivide_0 : forall a:Z, (a | 0).
-Proof.
-  intros; apply Zdivide_intro with 0; ring.
-Qed.
-
-Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith.
-
-Lemma Zmult_divide_compat_l : forall a b c:Z, (a | b) -> (c * a | c * b).
-Proof.
-  simple induction 1; intros; apply Zdivide_intro with q.
-  rewrite H0; ring.
-Qed.
-
-Lemma Zmult_divide_compat_r : forall a b c:Z, (a | b) -> (a * c | b * c).
-Proof.
-  intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c).
-  apply Zmult_divide_compat_l; trivial.
-Qed.
-
-Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.
-
-Lemma Zdivide_plus_r : forall a b c:Z, (a | b) -> (a | c) -> (a | b + c).
-Proof.
-  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
-  apply Zdivide_intro with (q + q').
-  rewrite Hq; rewrite Hq'; ring.
-Qed.
-
-Lemma Zdivide_opp_r : forall a b:Z, (a | b) -> (a | - b).
-Proof.
-  simple induction 1; intros; apply Zdivide_intro with (- q).
-  rewrite H0; ring.
-Qed.
-
-Lemma Zdivide_opp_r_rev : forall a b:Z, (a | - b) -> (a | b).
-Proof.
-  intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring.
-Qed.
+(** Results concerning divisibility*)
 
-Lemma Zdivide_opp_l : forall a b:Z, (a | b) -> (- a | b).
-Proof.
-  simple induction 1; intros; apply Zdivide_intro with (- q).
-  rewrite H0; ring.
-Qed.
+Notation Zdivide_refl := Z.divide_refl (only parsing).
+Notation Zone_divide := Z.divide_1_l (only parsing).
+Notation Zdivide_0 := Z.divide_0_r (only parsing).
+Notation Zmult_divide_compat_l := Z.mul_divide_mono_l (only parsing).
+Notation Zmult_divide_compat_r := Z.mul_divide_mono_r (only parsing).
+Notation Zdivide_plus_r := Z.divide_add_r (only parsing).
+Notation Zdivide_minus_l := Z.divide_sub_r (only parsing).
+Notation Zdivide_mult_l := Z.divide_mul_l (only parsing).
+Notation Zdivide_mult_r := Z.divide_mul_r (only parsing).
+Notation Zdivide_factor_r := Z.divide_factor_l (only parsing).
+Notation Zdivide_factor_l := Z.divide_factor_r (only parsing).
 
-Lemma Zdivide_opp_l_rev : forall a b:Z, (- a | b) -> (a | b).
-Proof.
-  intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring.
-Qed.
+Lemma Zdivide_opp_r a b : (a | b) -> (a | - b).
+Proof. apply Z.divide_opp_r. Qed.
 
-Lemma Zdivide_minus_l : forall a b c:Z, (a | b) -> (a | c) -> (a | b - c).
-Proof.
-  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
-  apply Zdivide_intro with (q - q').
-  rewrite Hq; rewrite Hq'; ring.
-Qed.
+Lemma Zdivide_opp_r_rev a b : (a | - b) -> (a | b).
+Proof. apply Z.divide_opp_r. Qed.
 
-Lemma Zdivide_mult_l : forall a b c:Z, (a | b) -> (a | b * c).
-Proof.
-  simple induction 1; intros q Hq; apply Zdivide_intro with (q * c).
-  rewrite Hq; ring.
-Qed.
+Lemma Zdivide_opp_l a b : (a | b) -> (- a | b).
+Proof. apply Z.divide_opp_l. Qed.
 
-Lemma Zdivide_mult_r : forall a b c:Z, (a | c) -> (a | b * c).
-Proof.
-  simple induction 1; intros q Hq; apply Zdivide_intro with (q * b).
-  rewrite Hq; ring.
-Qed.
+Lemma Zdivide_opp_l_rev a b : (- a | b) -> (a | b).
+Proof. apply Z.divide_opp_l. Qed.
 
-Lemma Zdivide_factor_r : forall a b:Z, (a | a * b).
-Proof.
-  intros; apply Zdivide_intro with b; ring.
-Qed.
+Theorem Zdivide_Zabs_l a b : (Z.abs a | b) -> (a | b).
+Proof. apply Z.divide_abs_l. Qed.
 
-Lemma Zdivide_factor_l : forall a b:Z, (a | b * a).
-Proof.
-  intros; apply Zdivide_intro with b; ring.
-Qed.
+Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b).
+Proof. apply Z.divide_abs_l. Qed.
 
+Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith.
+Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.
 Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
   Zdivide_opp_l_rev Zdivide_minus_l Zdivide_mult_l Zdivide_mult_r
   Zdivide_factor_r Zdivide_factor_l: zarith.
 
 (** Auxiliary result. *)
 
-Lemma Zmult_one : forall x y:Z, x >= 0 -> x * y = 1 -> x = 1.
+Lemma Zmult_one x y : x >= 0 -> x * y = 1 -> x = 1.
 Proof.
-  intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg].
-  assumption.
-  rewrite Hneg in H; simpl in H.
-  contradiction (Zle_not_lt 0 (-1)).
-    apply Zge_le; assumption.
-    apply Zorder.Zlt_neg_0.
+ Z.swap_greater. apply Z.eq_mul_1_nonneg.
 Qed.
 
 (** Only [1] and [-1] divide [1]. *)
 
-Lemma Zdivide_1 : forall x:Z, (x | 1) -> x = 1 \/ x = -1.
-Proof.
-  simple induction 1; intros.
-  elim (Z_lt_ge_dec 0 x); [ left | right ].
-  apply Zmult_one with q; auto with zarith; rewrite H0; ring.
-  assert (- x = 1); auto with zarith.
-  apply Zmult_one with (- q); auto with zarith; rewrite H0; ring.
-Qed.
+Notation Zdivide_1 := Z.divide_1_r (only parsing).
 
 (** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)
 
-Lemma Zdivide_antisym : forall a b:Z, (a | b) -> (b | a) -> a = b \/ a = - b.
-Proof.
-  simple induction 1; intros.
-  inversion H1.
-  rewrite H0 in H2; clear H H1.
-  case (Z_zerop a); intro.
-  left; rewrite H0; rewrite e; ring.
-  assert (Hqq0 : q0 * q = 1).
-  apply Zmult_reg_l with a.
-  assumption.
-  ring_simplify.
-  pattern a at 2 in |- *; rewrite H2; ring.
-  assert (q | 1).
-  rewrite <- Hqq0; auto with zarith.
-  elim (Zdivide_1 q H); intros.
-  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.
-  rewrite H2; rewrite H1; ring.
-Qed.
+Notation Zdivide_antisym := Z.divide_antisym (only parsing).
+Notation Zdivide_trans := Z.divide_trans (only parsing).
 
 (** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)
 
-Lemma Zdivide_bounds : forall a b:Z, (a | b) -> b <> 0 -> Zabs a <= Zabs b.
+Lemma Zdivide_bounds a b : (a | b) -> b <> 0 -> Z.abs a <= Z.abs b.
 Proof.
-  simple induction 1; intros.
-  assert (Zabs b = Zabs q * Zabs a).
-  subst; apply Zabs_Zmult.
-  rewrite H2.
-  assert (H3 := Zabs_pos q).
-  assert (H4 := Zabs_pos a).
-  assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith.
-  apply Zmult_ge_compat; auto with zarith.
-  elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ].
-  assert (Zabs q = 0).
-  omega.
-  assert (q = 0).
-  rewrite <- (Zabs_Zsgn q).
-  rewrite H5; auto with zarith.
-  subst q; omega.
+ intros H Hb.
+ rewrite <- Z.divide_abs_l, <- Z.divide_abs_r in H.
+ apply Z.abs_pos in Hb.
+ now apply Z.divide_pos_le.
 Qed.
 
 (** [Zdivide] can be expressed using [Zmod]. *)
 
 Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a).
 Proof.
- 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.
+ apply Z.mod_divide.
 Qed.
 
 Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0.
 Proof.
-  intros a b (c,->); apply Z_mod_mult.
+ intros a b (c,->); apply Z_mod_mult.
 Qed.
 
 (** [Zdivide] is hence decidable *)
 
-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.
-  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.
-  (* a=0 *)
-  case (Z_eq_dec b 0); intro.
-  left; subst; auto with zarith.
-  right; subst; intro H0; inversion H0; omega.
-  (* a>0 *)
-  intro H; case (Z_eq_dec (b mod a) 0).
-  left; apply Zmod_divide; auto with zarith.
-  intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
-Qed.
-
-Theorem Zdivide_Zdiv_eq: forall a b : Z,
- 0 < a -> (a | b) ->  b = a * (b / a).
+Lemma Zdivide_dec a b : {(a | b)} + {~ (a | b)}.
 Proof.
-  intros a b Hb Hc.
-  pattern b at 1; rewrite (Z_div_mod_eq b a); auto with zarith.
-  rewrite (Zdivide_mod b a); auto with zarith.
-Qed.
-
-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.
-  inversion H2 as [z Hz].
-  rewrite Hz; rewrite Zmult_assoc.
-  repeat rewrite Z_div_mult; auto with zarith.
-Qed.
+ destruct (Z.eq_dec a 0) as [Ha|Ha].
+  destruct (Z.eq_dec b 0) as [Hb|Hb].
+   left; subst; apply Z.divide_0_r.
+   right. subst. contradict Hb. now apply Z.divide_0_l.
+  destruct (Z.eq_dec (b mod a) 0).
+   left. now apply Z.mod_divide.
+   right. now rewrite <- Z.mod_divide.
+Defined.
 
-Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) ->  (a | b).
+Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) ->  b = a * (b / a).
 Proof.
-  intros a b [x H]; subst b.
-  pattern (Zabs a); apply Zabs_intro.
-  exists (- x); ring.
-  exists x; ring.
+ intros Ha H.
+ rewrite (Z.div_mod b a) at 1; auto with zarith.
+ rewrite Zdivide_mod; auto with zarith.
 Qed.
 
-Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) ->  (Zabs a | b).
+Theorem Zdivide_Zdiv_eq_2 a b c :
+ 0 < a -> (a | b) -> (c * b) / a = c * (b / a).
 Proof.
-  intros a b [x H]; subst b.
-  pattern (Zabs a); apply Zabs_intro.
-  exists (- x);  ring.
-  exists x; ring.
+ intros. apply Z.divide_div_mul_exact; auto with zarith.
 Qed.
 
 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.
-  case (Zle_lt_or_eq 0 a); auto with zarith; intros H3.
-  case (Zle_lt_or_eq 0 q); auto with zarith.
-  apply (Zmult_le_0_reg_r a); auto with zarith.
-  intros H4; apply Zle_trans with (1 * a); auto with zarith.
-  intros H4; subst q; omega.
+ intros. now apply Z.divide_pos_le.
 Qed.
 
-Theorem Zdivide_Zdiv_lt_pos: forall a b : Z,
+Theorem Zdivide_Zdiv_lt_pos a b :
  1 < a -> 0 < b -> (a | b) ->  0 < b / a < b .
 Proof.
-  intros a b H1 H2 H3; split.
-  apply Zmult_lt_reg_r with a; auto with zarith.
-  rewrite (Zmult_comm (Zdiv b a)); rewrite <- Zdivide_Zdiv_eq; auto with zarith.
-  apply Zmult_lt_reg_r with a; auto with zarith.
-  repeat rewrite (fun x => Zmult_comm x a); auto with zarith.
+  intros H1 H2 H3; split.
+  apply Z.mul_pos_cancel_l with a; auto with zarith.
   rewrite <- Zdivide_Zdiv_eq; auto with zarith.
-  pattern b at 1; replace b with (1 * b); auto with zarith.
-  apply Zmult_lt_compat_r; auto with zarith.
+  now apply Z.div_lt.
 Qed.
 
-Lemma Zmod_div_mod: forall n m a, 0 < n -> 0 < m ->
- (n | m) -> a mod n = (a mod m) mod n.
+Lemma Zmod_div_mod n m a:
+ 0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n.
 Proof.
-  intros n m a H1 H2 H3.
-  pattern a at 1; rewrite (Z_div_mod_eq a m); auto with zarith.
-  case H3; intros q Hq; pattern m at 1; rewrite Hq.
-  rewrite (Zmult_comm q).
-  rewrite Zplus_mod; auto with zarith.
-  rewrite <- Zmult_assoc; rewrite Zmult_mod; auto with zarith.
-  rewrite Z_mod_same; try rewrite Zmult_0_l; auto with zarith.
-  rewrite (Zmod_small 0); auto with zarith.
-  rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith.
+  intros H1 H2 (p,Hp).
+  rewrite (Z.div_mod a m) at 1; auto with zarith.
+  rewrite Hp at 1.
+  rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith.
 Qed.
 
-Lemma Zmod_divide_minus: forall a b c : Z, 0 < b ->
- a mod b = c -> (b | a - c).
+Lemma Zmod_divide_minus a b c:
+ 0 < b -> a mod b = c -> (b | a - c).
 Proof.
-  intros a b c H H1; apply Zmod_divide; auto with zarith.
+  intros H H1. apply Z.mod_divide; auto with zarith.
   rewrite Zminus_mod; auto with zarith.
-  rewrite H1; pattern c at 1; rewrite <- (Zmod_small c b); auto with zarith.
-  rewrite Zminus_diag; apply Zmod_small; auto with zarith.
-  subst; apply Z_mod_lt; auto with zarith.
+  rewrite H1. rewrite <- (Z.mod_small c b) at 1.
+  rewrite Z.sub_diag, Z.mod_0_l; auto with zarith.
+  subst. now apply Z.mod_pos_bound.
 Qed.
 
-Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b ->
- (b | a - c) -> a mod b = c.
+Lemma Zdivide_mod_minus a b c:
+ 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.
+  intros (H1, H2) H3.
+  assert (0 < b) by Z.order.
   replace a with ((a - c) + c); auto with zarith.
-  rewrite Zplus_mod; auto with zarith.
-  rewrite (Zdivide_mod (a -c) b); try rewrite Zplus_0_l; auto with zarith.
-  rewrite Zmod_mod; try apply Zmod_small; auto with zarith.
+  rewrite Z.add_mod; auto with zarith.
+  rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith.
+  rewrite Z.mod_mod; try apply Zmod_small; auto with zarith.
 Qed.
 
 (** * Greatest common divisor (gcd). *)
@@ -338,12 +204,12 @@ Inductive Zis_gcd (a b d:Z) : Prop :=
 
 (** Trivial properties of [gcd] *)
 
-Lemma Zis_gcd_sym : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a d.
+Lemma Zis_gcd_sym : forall a b d, Zis_gcd a b d -> Zis_gcd b a d.
 Proof.
-  simple induction 1; constructor; intuition.
+  induction 1; constructor; intuition.
 Qed.
 
-Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 a.
+Lemma Zis_gcd_0 : forall a, Zis_gcd a 0 a.
 Proof.
   constructor; auto with zarith.
 Qed.
@@ -358,19 +224,18 @@ Proof.
   constructor; auto with zarith.
 Qed.
 
-Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d.
+Lemma Zis_gcd_minus : forall a b d, Zis_gcd a (- b) d -> Zis_gcd b a d.
 Proof.
-  simple induction 1; constructor; intuition.
+  induction 1; constructor; intuition.
 Qed.
 
-Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d).
+Lemma Zis_gcd_opp : forall a b d, Zis_gcd a b d -> Zis_gcd b a (- d).
 Proof.
-  simple induction 1; constructor; intuition.
+  induction 1; constructor; intuition.
 Qed.
 
-Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a).
+Lemma Zis_gcd_0_abs a : Zis_gcd 0 a (Z.abs a).
 Proof.
-  intros a.
   apply Zabs_ind.
   intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
   intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
@@ -429,7 +294,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(u3,v3)=gcd(a,b)].
       *)
 
   Lemma euclid_rec :
@@ -519,14 +384,15 @@ Qed.
 Lemma Zis_gcd_mult :
   forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
 Proof.
-  intros a b c d; simple induction 1; constructor; intuition.
-  elim (Zis_gcd_bezout a b d H). intros.
-  elim H3; intros.
-  elim H4; intros.
-  apply Zdivide_intro with (u * q + v * q0).
-  rewrite <- H5.
+  intros a b c d; simple induction 1. constructor; auto with zarith.
+  intros x Ha Hb.
+  elim (Zis_gcd_bezout a b d H). intros u v Huv.
+  elim Ha; intros a' Ha'.
+  elim Hb; intros b' Hb'.
+  apply Zdivide_intro with (u * a' + v * b').
+  rewrite <- Huv.
   replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
-  rewrite H6; rewrite H7; ring.
+  rewrite Ha'; rewrite Hb'; ring.
   ring.
 Qed.
 
@@ -625,14 +491,14 @@ Proof.
   exists a'; auto with zarith.
   exists b'; auto with zarith.
   intros x (xa,H5) (xb,H6).
-  destruct (H4 (x*g)).
+  destruct (H4 (x*g)) as (x',Hx').
   exists xa; rewrite Zmult_assoc; rewrite <- H5; auto.
   exists xb; rewrite Zmult_assoc; rewrite <- H6; auto.
-  replace g with (1*g) in H7; auto with zarith.
-  do 2 rewrite Zmult_assoc in H7.
-  generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros.
-  rewrite Zmult_1_r in H7.
-  exists q; auto with zarith.
+  replace g with (1*g) in Hx'; auto with zarith.
+  do 2 rewrite Zmult_assoc in Hx'.
+  apply Zmult_reg_r in Hx'; trivial.
+  rewrite Zmult_1_r in Hx'.
+  exists x'; auto with zarith.
 Qed.
 
 Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a.
@@ -875,249 +741,62 @@ Proof.
   contradict Hp; auto with zarith.
 Qed.
 
+(** we now prove that [Z.gcd] is indeed a gcd in
+   the sense of [Zis_gcd]. *)
 
-(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose
-  here a binary version of [Zgcd], faster and executable within Coq.
-
-   Algorithm:
-
-   gcd 0 b = b
-   gcd a 0 = a
-   gcd (2a) (2b) = 2(gcd a b)
-   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
-*)
+Notation Zgcd_is_pos := Z.gcd_nonneg (only parsing).
 
-Open Scope positive_scope.
-
-Fixpoint Pgcdn (n: nat) (a b : positive) : positive :=
-  match n with
-    | O => 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
-	    | Eq => a
-	    | Lt => Pgcdn  n (b'-a') a
-	    | Gt => Pgcdn n (a'-b') b
-          end
-      end
-  end.
-
-Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b.
-
-Close Scope positive_scope.
-
-Definition Zgcd (a b : Z) : Z :=
-  match a,b with
-    | Z0, _ => Zabs b
-    | _, Z0 => Zabs a
-    | Zpos a, Zpos b => Zpos (Pgcd a b)
-    | Zpos a, Zneg b => Zpos (Pgcd a b)
-    | Zneg a, Zpos b => Zpos (Pgcd a b)
-    | Zneg a, Zneg b => Zpos (Pgcd a b)
-  end.
-
-Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
+Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b).
 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.
-Proof.
-  intros.
-  destruct H.
-  constructor; auto.
-  destruct H as (e,H2); exists (2*e); auto with zarith.
-  rewrite Zpos_xO; rewrite H2; ring.
-  intros.
-  apply H1; auto.
-  rewrite Zpos_xO in H2.
-  rewrite Zpos_xI in H3.
-  apply Gauss with 2; auto.
-  apply bezout_rel_prime.
-  destruct H3 as (bb, H3).
-  apply Bezout_intro with bb (-Zpos b).
-  omega.
-Qed.
-
-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.
-  destruct n.
-  simpl.
-  destruct a; simpl in *; try inversion H0.
-  destruct a.
-  destruct b; simpl.
-  case_eq (Pcompare a b Eq); intros.
-  (* a = xI, b = xI, compare = Eq *)
-  rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl.
-  (* a = xI, b = xI, compare = Lt *)
-  apply Zis_gcd_sym.
-  apply Zis_gcd_for_euclid with 1.
-  apply Zis_gcd_sym.
-  replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))).
-  apply Zis_gcd_even_odd.
-  apply H; auto.
-  simpl in *.
-  assert (Psize (b-a) <= Psize b)%nat.
-  apply Psize_monotone.
-  change (Zpos (b-a) < Zpos b).
-  rewrite (Zpos_minus_morphism _ _ H1).
-  assert (0 < Zpos a) by (compute; auto).
-  omega.
-  omega.
-  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
-  rewrite Zpos_minus_morphism; auto.
-  omega.
-  (* a = xI, b = xI, compare = Gt *)
-  apply Zis_gcd_for_euclid with 1.
-  replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))).
-  apply Zis_gcd_sym.
-  apply Zis_gcd_even_odd.
-  apply H; auto.
-  simpl in *.
-  assert (Psize (a-b) <= Psize a)%nat.
-  apply Psize_monotone.
-  change (Zpos (a-b) < Zpos a).
-  rewrite (Zpos_minus_morphism b a).
-  assert (0 < Zpos b) by (compute; auto).
-  omega.
-  rewrite ZC4; rewrite H1; auto.
-  omega.
-  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
-  rewrite Zpos_minus_morphism; auto.
-  omega.
-  rewrite ZC4; rewrite H1; auto.
-  (* a = xI, b = xO *)
-  apply Zis_gcd_sym.
-  apply Zis_gcd_even_odd.
-  apply Zis_gcd_sym.
-  apply H; auto.
-  simpl in *; omega.
-  (* a = xI, b = xH *)
-  apply Zis_gcd_1.
-  destruct b; simpl.
-  (* a = xO, b = xI *)
-  apply Zis_gcd_even_odd.
-  apply H; auto.
-  simpl in *; omega.
-  (* a = xO, b = xO *)
-  rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)).
-  apply Zis_gcd_mult.
-  apply H; auto.
-  simpl in *; omega.
-  (* a = xO, b = xH *)
-  apply Zis_gcd_1.
-  (* a = xH *)
-  simpl; apply Zis_gcd_sym; apply Zis_gcd_1.
-Qed.
-
-Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)).
-Proof.
-  unfold Pgcd; intros.
-  apply Pgcdn_correct; auto.
-Qed.
-
-Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b).
-Proof.
-  destruct a.
-  intros.
-  simpl.
-  apply Zis_gcd_0_abs.
-  destruct b; simpl.
-  apply Zis_gcd_0.
-  apply Pgcd_correct.
-  apply Zis_gcd_sym.
-  apply Zis_gcd_minus; simpl.
-  apply Pgcd_correct.
-  destruct b; simpl.
-  apply Zis_gcd_minus; simpl.
-  apply Zis_gcd_sym.
-  apply Zis_gcd_0.
-  apply Zis_gcd_minus; simpl.
-  apply Zis_gcd_sym.
-  apply Pgcd_correct.
-  apply Zis_gcd_sym.
-  apply Zis_gcd_minus; simpl.
-  apply Zis_gcd_minus; simpl.
-  apply Zis_gcd_sym.
-  apply Pgcd_correct.
+ constructor.
+ apply Z.gcd_divide_l.
+ apply Z.gcd_divide_r.
+ apply Z.gcd_greatest.
 Qed.
 
 Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}.
 Proof.
-  intros x y; exists (Zgcd x y).
-  split; [apply Zgcd_is_gcd  | apply Zgcd_is_pos].
+  intros x y; exists (Z.gcd x y).
+  split; [apply Zgcd_is_gcd  | apply Z.gcd_nonneg].
 Qed.
 
 Theorem Zdivide_Zgcd: forall p q r : Z,
- (p | q) -> (p | r) -> (p | Zgcd q r).
+ (p | q) -> (p | r) -> (p | Z.gcd q r).
 Proof.
-  intros p q r H1 H2.
-  assert (H3: (Zis_gcd q r (Zgcd q r))).
-  apply Zgcd_is_gcd.
-  inversion_clear H3; auto.
+ intros. now apply Z.gcd_greatest.
 Qed.
 
 Theorem Zis_gcd_gcd: forall a b c : Z,
- 0 <= c ->  Zis_gcd a b c -> Zgcd a b = c.
+ 0 <= c ->  Zis_gcd a b c -> Z.gcd a b = c.
 Proof.
   intros a b c H1 H2.
   case (Zis_gcd_uniqueness_apart_sign a b c (Zgcd a b)); auto.
   apply Zgcd_is_gcd; auto.
-  case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; subst; auto.
-  intros H3; subst.
-  generalize (Zgcd_is_pos a b); auto with zarith.
-  case (Zgcd a b); simpl; auto; intros; discriminate.
-Qed.
-
-Theorem Zgcd_inv_0_l: forall x y, Zgcd x y = 0 -> x = 0.
-Proof.
-  intros x y H.
-  assert (F1: Zdivide 0 x).
-   rewrite <- H.
-   generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto.
-  inversion F1 as [z H1].
-  rewrite H1; ring.
+  Z.le_elim H1.
+  generalize (Z.gcd_nonneg a b); auto with zarith.
+  subst. now case (Z.gcd a b).
 Qed.
 
-Theorem Zgcd_inv_0_r: forall x y, Zgcd x y = 0 -> y = 0.
-Proof.
-  intros x y H.
-  assert (F1: Zdivide 0 y).
-   rewrite <- H.
-   generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto.
-  inversion F1 as [z H1].
-  rewrite H1; ring.
-Qed.
+Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (only parsing).
+Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (only parsing).
 
 Theorem Zgcd_div_swap0 : forall a b : Z,
- 0 < Zgcd a b ->
+ 0 < Z.gcd a b ->
  0 < b ->
- (a / Zgcd a b) * b = a * (b/Zgcd a b).
+ (a / Z.gcd a b) * b = a * (b/Z.gcd a b).
 Proof.
   intros a b Hg Hb.
   assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
-  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
+  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto.
   repeat rewrite Zmult_assoc; f_equal.
   rewrite Zmult_comm.
   rewrite <- Zdivide_Zdiv_eq; auto.
 Qed.
 
 Theorem Zgcd_div_swap : forall a b c : Z,
- 0 < Zgcd a b ->
+ 0 < Z.gcd a b ->
  0 < b ->
- (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b).
+ (c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b).
 Proof.
   intros a b c Hg Hb.
   assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
@@ -1129,44 +808,21 @@ Proof.
   rewrite <- Zdivide_Zdiv_eq; auto.
 Qed.
 
-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.
+Notation Zgcd_comm := Z.gcd_comm (only parsing).
 
-Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b.
+Lemma Zgcd_ass a b c : Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c).
 Proof.
-  destruct a; simpl; auto.
+ symmetry. apply Z.gcd_assoc.
 Qed.
 
-Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a.
-Proof.
-  destruct a; simpl; auto.
-Qed.
+Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing).
+Notation Zgcd_0 := Z.gcd_0_r (only parsing).
+Notation Zgcd_1 := Z.gcd_1_r (only parsing).
 
-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.
+ Z.gcd a b = 1 <-> rel_prime a b.
 Proof.
   unfold rel_prime; split; intro H.
   rewrite <- H; apply Zgcd_is_gcd.
@@ -1249,167 +905,3 @@ Proof.
   absurd (n = 0); auto with zarith.
   case Hr1; auto with zarith.
 Qed.
-
-(** A Generalized Gcd that also computes Bezout coefficients.
-   The algorithm is the same as for Zgcd. *)
-
-Open Scope positive_scope.
-
-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))
-	| a, xH => (1,(a,1))
-	| 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
-           (g,(aa, xO bb))
-	| 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
-	     | Eq => (a,(1,1))
-	     | 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
-		(g,(bb+xO ab, bb))
-	   end
-      end
-  end.
-
-Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b.
-
-Open Scope Z_scope.
-
-Definition Zggcd (a b : Z) : Z*(Z*Z) :=
-  match a,b with
-    | 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 g, (Zpos aa, Zpos bb))
-    | 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
-       (Zpos g, (Zneg aa, Zpos bb))
-    | Zneg a, Zneg b =>
-       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,
-  fst (Pggcdn n a b) = Pgcdn n a b.
-Proof.
-  induction n.
-  simpl; auto.
-  destruct a; destruct b; simpl; auto.
-  destruct (Pcompare a b Eq); simpl; auto.
-  rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto.
-  rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto.
-  rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto.
-  rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto.
-  rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto.
-Qed.
-
-Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b.
-Proof.
-  intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b).
-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 (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
-  (a=g*aa) /\ (b=g*bb).
-Proof.
-  induction n.
-  simpl; auto.
-  destruct a; destruct b; simpl; auto.
-  case_eq (Pcompare a b Eq); intros.
-  (* Eq *)
-  rewrite Pmult_comm; simpl; auto.
-  rewrite (Pcompare_Eq_eq _ _ H); auto.
-  (* Lt *)
-  generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl.
-  intros (H0,H1); split; auto.
-  rewrite Pmult_plus_distr_l.
-  rewrite Pmult_xO_permute_r.
-  rewrite <- H1; rewrite <- H0.
-  simpl; f_equal; symmetry.
-  apply Pplus_minus; auto.
-  rewrite ZC4; rewrite H; auto.
-  (* Gt *)
-  generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl.
-  intros (H0,H1); split; auto.
-  rewrite Pmult_plus_distr_l.
-  rewrite Pmult_xO_permute_r.
-  rewrite <- H1; rewrite <- H0.
-  simpl; f_equal; symmetry.
-  apply Pplus_minus; auto.
-  (* 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.
-  generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl.
-  intros (H0,H1); split; auto.
-  rewrite Pmult_xO_permute_r; rewrite H0; auto.
-  generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl.
-  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
-  (a=g*aa) /\ (b=g*bb).
-Proof.
-  intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b).
-Qed.
-
-Close Scope positive_scope.
-
-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 1; subst; auto.
-Qed.
-
-Theorem Zggcd_opp: forall x y,
-  Zggcd (-x) y = let (p1,p) := Zggcd x y in
-                 let (p2,p3) := p in
-                 (p1,(-p2,p3)).
-Proof.
-intros [|x|x] [|y|y]; unfold Zggcd, Zopp; auto.
-case Pggcd; intros p1 (p2, p3); auto.
-case Pggcd; intros p1 (p2, p3); auto.
-case Pggcd; intros p1 (p2, p3); auto.
-case Pggcd; intros p1 (p2, p3); auto.
-Qed.
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 91c16929..a8cd69bb 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -1,337 +1,200 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zorder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(** Binary Integers : results about order predicates *)
+(** Initial author : Pierre Crégut (CNET, Lannion, France) *)
 
-Require Import BinPos.
-Require Import BinInt.
-Require Import Arith_base.
-Require Import Decidable.
-Require Import Zcompare.
+(** THIS FILE IS DEPRECATED.
+    It is now almost entirely made of compatibility formulations
+    for results already present in BinInt.Z. *)
 
-Open Local Scope Z_scope.
+Require Import BinPos BinInt Decidable Zcompare.
+Require Import Arith_base. (* Useless now, for compatibility only *)
 
-Implicit Types x y z : Z.
+Local Open Scope Z_scope.
 
 (*********************************************************)
 (** Properties of the order relations on binary integers *)
 
 (** * Trichotomy *)
 
-Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}.
+Theorem Ztrichotomy_inf n m : {n < m} + {n = m} + {n > m}.
 Proof.
-  unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
-  set (x := m ?= n) in H at 2 |- *.
-  destruct x;
-    [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
-    reflexivity.
-Qed.
+  unfold ">", "<". generalize (Z.compare_eq n m).
+  destruct (n ?= m); [ left; right | left; left | right]; auto.
+Defined.
 
-Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m.
+Theorem Ztrichotomy n m : n < m \/ n = m \/ n > m.
 Proof.
-  intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt];
-    [ left | right; left | right; right ]; assumption.
+  Z.swap_greater. apply Z.lt_trichotomy.
 Qed.
 
 (**********************************************************************)
 (** * Decidability of equality and order on Z *)
 
-Theorem dec_eq : forall n m:Z, decidable (n = m).
-Proof.
-  intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
-    intros H1 H2; elim (Dcompare (x ?= y));
-      [ tauto
-	| intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
-	  intros H5; discriminate H5 ].
-Qed.
-
-Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
-Proof.
-  intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
-  intros H1 H2; elim (Dcompare (x ?= y));
-    [ right; rewrite H1; auto
-      | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
-	[ elim H; intros HR; rewrite HR; discriminate | auto ] ].
-Qed.
-
-Theorem dec_Zle : forall n m:Z, decidable (n <= m).
-Proof.
-  intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
-    [ left; discriminate
-      | left; discriminate
-      | right; unfold not in |- *; intros H; apply H; trivial with arith ].
-Qed.
+Notation dec_eq := Z.eq_decidable (only parsing).
+Notation dec_Zle := Z.le_decidable (only parsing).
+Notation dec_Zlt := Z.lt_decidable (only parsing).
 
-Theorem dec_Zgt : forall n m:Z, decidable (n > m).
+Theorem dec_Zne n m : decidable (Zne n m).
 Proof.
-  intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
-    [ right; discriminate | right; discriminate | auto with arith ].
+  destruct (Z.eq_decidable n m); [right|left]; subst; auto.
 Qed.
 
-Theorem dec_Zge : forall n m:Z, decidable (n >= m).
+Theorem dec_Zgt n m : decidable (n > m).
 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 ].
+  destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto.
 Qed.
 
-Theorem dec_Zlt : forall n m:Z, decidable (n < m).
+Theorem dec_Zge n m : decidable (n >= m).
 Proof.
-  intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
-    [ right; discriminate | auto with arith | right; discriminate ].
+  destruct (Z.le_decidable m n); [left|right]; Z.swap_greater; auto.
 Qed.
 
-Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n.
+Theorem not_Zeq n m : n <> m -> n < m \/ m < n.
 Proof.
-  intros x y; elim (Dcompare (x ?= y));
-    [ intros H1 H2; absurd (x = y);
-      [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
-      | unfold Zlt in |- *; intros H; elim H; intros H1;
-	[ auto with arith
-	  | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
+  apply Z.lt_gt_cases.
 Qed.
 
 (** * Relating strict and large orders *)
 
-Lemma Zgt_lt : forall n m:Z, n > m -> m < n.
-Proof.
-  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
-    auto with arith.
-Qed.
-
-Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
-Proof.
-  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
-    auto with arith.
-Qed.
+Notation Zgt_lt := Z.gt_lt (only parsing).
+Notation Zlt_gt := Z.lt_gt (only parsing).
+Notation Zge_le := Z.ge_le (only parsing).
+Notation Zle_ge := Z.le_ge (only parsing).
+Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing).
+Notation Zge_iff_le := Z.ge_le_iff (only parsing).
 
-Lemma Zge_le : forall n m:Z, n >= m -> m <= n.
+Lemma Zle_not_lt n m : n <= m -> ~ m < n.
 Proof.
-  intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
-    intros H1 H2; apply H1; apply Zgt_lt; assumption.
+ apply Z.le_ngt.
 Qed.
 
-Lemma Zle_ge : forall n m:Z, n <= m -> m >= n.
+Lemma Zlt_not_le n m : n < m -> ~ m <= n.
 Proof.
-  intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
-    intros H1 H2; apply H1; apply Zlt_gt; assumption.
+ apply Z.lt_nge.
 Qed.
 
-Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
+Lemma Zle_not_gt n m : n <= m -> ~ n > m.
 Proof.
   trivial.
 Qed.
 
-Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
+Lemma Zgt_not_le n m : n > m -> ~ n <= m.
 Proof.
-  intros n m H1 H2; apply H2; assumption.
+  Z.swap_greater. apply Z.lt_nge.
 Qed.
 
-Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
+Lemma Znot_ge_lt n m : ~ n >= m -> n < m.
 Proof.
-  intros n m H1 H2.
-  assert (H3 := Zlt_gt _ _ H2).
-  apply Zle_not_gt with n m; assumption.
+  Z.swap_greater. apply Z.nle_gt.
 Qed.
 
-Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n.
-Proof.
-  intros n m H1 H2.
-  apply Zle_not_lt with m n; assumption.
-Qed.
-
-Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m.
-Proof.
-  unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
-    [ exact (dec_Zlt x y) | assumption ].
-Qed.
-
-Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
-Proof.
-  unfold Zlt, Zge in |- *; auto with arith.
-Qed.
-
-Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
+Lemma Znot_lt_ge n m : ~ n < m -> n >= m.
 Proof.
   trivial.
 Qed.
 
-Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m.
+Lemma Znot_gt_le n m: ~ n > m -> n <= m.
 Proof.
-  unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
-    [ exact (dec_Zgt x y) | assumption ].
+  trivial.
 Qed.
 
-Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n.
+Lemma Znot_le_gt n m : ~ n <= m -> n > m.
 Proof.
-  intros x y; intros. split. intro. apply Zge_le. assumption.
-  intro. apply Zle_ge. assumption.
+  Z.swap_greater. apply Z.nle_gt.
 Qed.
 
-Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n.
+Lemma not_Zne n m : ~ Zne n m -> n = m.
 Proof.
-  intros x y. split. intro. apply Zgt_lt. assumption.
-  intro. apply Zlt_gt. assumption.
+  intros H.
+  destruct (Z.eq_decidable n m); [assumption|now elim H].
 Qed.
 
 (** * Equivalence and order properties *)
 
 (** Reflexivity *)
 
-Lemma Zle_refl : forall n:Z, n <= n.
-Proof.
-  intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
-Qed.
+Notation Zle_refl := Z.le_refl (only parsing).
+Notation Zeq_le := Z.eq_le_incl (only parsing).
 
-Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
-Proof.
-  intros; rewrite H; apply Zle_refl.
-Qed.
-
-Hint Resolve Zle_refl: zarith.
+Hint Resolve Z.le_refl: zarith.
 
 (** Antisymmetry *)
 
-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]].
-  absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
-  assumption.
-  absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
-Qed.
+Notation Zle_antisym := Z.le_antisymm (only parsing).
 
 (** Asymmetry *)
 
-Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n.
-Proof.
-  unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
-    intros H1 H2; rewrite H1; [ discriminate | assumption ].
-Qed.
+Notation Zlt_asym := Z.lt_asymm (only parsing).
 
-Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n.
+Lemma Zgt_asym n m : n > m -> ~ m > n.
 Proof.
-  intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
-  assert (H3 : n > m). apply Zlt_gt; assumption.
-  apply Zgt_asym with m n; assumption.
+  Z.swap_greater. apply Z.lt_asymm.
 Qed.
 
 (** Irreflexivity *)
 
-Lemma Zgt_irrefl : forall n:Z, ~ n > n.
-Proof.
-  intros n H; apply (Zgt_asym n n H H).
-Qed.
-
-Lemma Zlt_irrefl : forall n:Z, ~ n < n.
-Proof.
-  intros n H; apply (Zlt_asym n n H H).
-Qed.
+Notation Zlt_irrefl := Z.lt_irrefl (only parsing).
+Notation Zlt_not_eq := Z.lt_neq (only parsing).
 
-Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
+Lemma Zgt_irrefl n : ~ n > n.
 Proof.
-  unfold not in |- *; intros x y H H0.
-  rewrite H0 in H.
-  apply (Zlt_irrefl _ H).
+  Z.swap_greater. apply Z.lt_irrefl.
 Qed.
 
 (** Large = strict or equal *)
 
-Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m.
-Proof.
-  intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
-Qed.
-
-Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
-Proof.
-  intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
-    [ left; assumption
-      | right; assumption
-      | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
-Qed.
+Notation Zlt_le_weak := Z.lt_le_incl (only parsing).
+Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (only parsing).
 
-Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
+Lemma Zle_lt_or_eq 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.
+  apply Z.lt_eq_cases.
 Qed.
 
 (** Dichotomy *)
 
-Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
-Proof.
-  intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
-    [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
-      apply Zgt_asym with m n; assumption
-      | left; rewrite Heq; apply Zle_refl
-      | right; apply Zgt_lt; assumption ].
-Qed.
+Notation Zle_or_lt := Z.le_gt_cases (only parsing).
 
 (** Transitivity of strict orders *)
 
-Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
-Proof.
-  exact Zcompare_Gt_trans.
-Qed.
+Notation Zlt_trans := Z.lt_trans (only parsing).
 
-Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
-Proof.
-  exact Zcompare_Lt_trans.
-Qed.
+Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
+Proof Zcompare_Gt_trans.
 
 (** Mixed transitivity *)
 
-Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p.
-Proof.
-  intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
-    [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
-      | rewrite <- Heq; assumption ].
-Qed.
+Notation Zlt_le_trans := Z.lt_le_trans (only parsing).
+Notation Zle_lt_trans := Z.le_lt_trans (only parsing).
 
-Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p.
+Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p.
 Proof.
-  intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
-    [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
-      | rewrite Heq; assumption ].
+  Z.swap_greater. Z.order.
 Qed.
 
-Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p.
-  intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
-    [ assumption | apply Zlt_gt; assumption ].
-Qed.
-
-Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p.
+Lemma Zgt_le_trans n m p : n > m -> p <= m -> n > p.
 Proof.
-  intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
-    [ apply Zlt_gt; assumption | assumption ].
+  Z.swap_greater. Z.order.
 Qed.
 
 (** Transitivity of large orders *)
 
-Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p.
-Proof.
-  intros n m p H1 H2; apply Znot_gt_le.
-  intro Hgt; apply Zle_not_gt with n m. assumption.
-  exact (Zgt_le_trans n p m Hgt H2).
-Qed.
+Notation Zle_trans := Z.le_trans (only parsing).
 
-Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p.
+Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p.
 Proof.
-  intros n m p H1 H2.
-  apply Zle_ge.
-  apply Zle_trans with m; apply Zge_le; trivial.
+  Z.swap_greater. Z.order.
 Qed.
 
-Hint Resolve Zle_trans: zarith.
-
+Hint Resolve Z.le_trans: zarith.
 
 (** * Compatibility of order and operations on Z *)
 
@@ -339,700 +202,448 @@ Hint Resolve Zle_trans: zarith.
 
 (** Compatibility of successor wrt to order *)
 
-Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n.
+Lemma Zsucc_le_compat n m : m <= n -> Z.succ m <= Z.succ n.
 Proof.
-  unfold Zle, not in |- *; intros m n H1 H2; apply H1;
-    rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
-      exact H2.
+  apply Z.succ_le_mono.
 Qed.
 
-Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n.
+Lemma Zsucc_lt_compat n m : n < m -> Z.succ n < Z.succ m.
 Proof.
-  unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
-    auto with arith.
+  apply Z.succ_lt_mono.
 Qed.
 
-Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m.
+Lemma Zsucc_gt_compat n m : m > n -> Z.succ m > Z.succ n.
 Proof.
-  intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
+  Z.swap_greater. apply Z.succ_lt_mono.
 Qed.
 
 Hint Resolve Zsucc_le_compat: zarith.
 
 (** Simplification of successor wrt to order *)
 
-Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n.
+Lemma Zsucc_gt_reg n m : Z.succ m > Z.succ n -> m > n.
 Proof.
-  unfold Zsucc, Zgt in |- *; intros n p;
-    do 2 rewrite (fun m:Z => Zplus_comm m 1);
-      rewrite (Zcompare_plus_compat p n 1); trivial with arith.
+  Z.swap_greater. apply Z.succ_lt_mono.
 Qed.
 
-Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n.
+Lemma Zsucc_le_reg n m : Z.succ m <= Z.succ n -> m <= n.
 Proof.
-  unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
-    do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
-      assumption.
+  apply Z.succ_le_mono.
 Qed.
 
-Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m.
+Lemma Zsucc_lt_reg n m : Z.succ n < Z.succ m -> n < m.
 Proof.
-  intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
+  apply Z.succ_lt_mono.
 Qed.
 
 (** Special base instances of order *)
 
-Lemma Zgt_succ : forall n:Z, Zsucc n > n.
-Proof.
-  exact Zcompare_succ_Gt.
-Qed.
-
-Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
-Proof.
-  intros n; apply Zgt_not_le; apply Zgt_succ.
-Qed.
+Notation Zlt_succ := Z.lt_succ_diag_r (only parsing).
+Notation Zlt_pred := Z.lt_pred_l (only parsing).
 
-Lemma Zlt_succ : forall n:Z, n < Zsucc n.
+Lemma Zgt_succ n : Z.succ n > n.
 Proof.
-  intro n; apply Zgt_lt; apply Zgt_succ.
+  Z.swap_greater. apply Z.lt_succ_diag_r.
 Qed.
 
-Lemma Zlt_pred : forall n:Z, Zpred n < n.
+Lemma Znot_le_succ n : ~ Z.succ n <= n.
 Proof.
-  intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
+  apply Z.lt_nge, Z.lt_succ_diag_r.
 Qed.
 
 (** Relating strict and large order using successor or predecessor *)
 
-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;
-      apply H1;
-	[ assumption
-	  | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
-Qed.
+Notation Zlt_succ_r := Z.lt_succ_r (only parsing).
+Notation Zle_succ_l := Z.le_succ_l (only parsing).
 
-Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
+Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m.
 Proof.
-  intros n p H; apply Zgt_le_trans with p.
-  apply Zgt_succ.
-  assumption.
+  Z.swap_greater. apply Z.le_succ_l.
 Qed.
 
-Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
+Lemma Zle_gt_succ n m : n <= m -> Z.succ m > n.
 Proof.
-  intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption.
+  Z.swap_greater. apply Z.lt_succ_r.
 Qed.
 
-Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
+Lemma Zle_lt_succ n m : n <= m -> n < Z.succ m.
 Proof.
-  intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
+  apply Z.lt_succ_r.
 Qed.
 
-Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m.
+Lemma Zlt_le_succ n m : n < m -> Z.succ n <= m.
 Proof.
-  intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
+  apply Z.le_succ_l.
 Qed.
 
-Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m.
+Lemma Zgt_succ_le n m : Z.succ m > n -> n <= m.
 Proof.
-  intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
+  Z.swap_greater. apply Z.lt_succ_r.
 Qed.
 
-Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
+Lemma Zlt_succ_le n m : n < Z.succ m -> n <= m.
 Proof.
-  intros n m H; apply Zle_gt_trans with (m := Zsucc n);
-    [ assumption | apply Zgt_succ ].
+  apply Z.lt_succ_r.
 Qed.
 
-Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m.
+Lemma Zle_succ_gt n m : Z.succ n <= m -> m > n.
 Proof.
-  split; [apply Zlt_succ_le | apply Zle_lt_succ].
+  Z.swap_greater. apply Z.le_succ_l.
 Qed.
 
 (** Weakening order *)
 
-Lemma Zle_succ : forall n:Z, n <= Zsucc n.
-Proof.
-  intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
-    apply Zgt_succ.
-Qed.
-
-Hint Resolve Zle_succ: zarith.
-
-Lemma Zle_pred : forall n:Z, Zpred n <= n.
-Proof.
-  intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
-Qed.
-
-Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m.
-  intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
-    [ apply Zgt_succ | apply Zlt_gt; assumption ].
-Qed.
+Notation Zle_succ := Z.le_succ_diag_r (only parsing).
+Notation Zle_pred := Z.le_pred_l (only parsing).
+Notation Zlt_lt_succ := Z.lt_lt_succ_r (only parsing).
+Notation Zle_le_succ := Z.le_le_succ_r (only parsing).
 
-Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m.
+Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m.
 Proof.
-  intros x y H.
-  apply Zle_trans with y; trivial with zarith.
-Qed.
-
-Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m.
-Proof.
-  intros n m H; apply Zle_trans with (m := Zsucc n);
-    [ apply Zle_succ | assumption ].
+  intros. now apply Z.lt_le_incl, Z.le_succ_l.
 Qed.
 
+Hint Resolve Z.le_succ_diag_r: zarith.
 Hint Resolve Zle_le_succ: zarith.
 
 (** Relating order wrt successor and order wrt predecessor *)
 
-Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
+Lemma Zgt_succ_pred n m : m > Z.succ n -> Z.pred m > n.
 Proof.
-  unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
-    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 |- *;
-	  assumption.
+  Z.swap_greater. apply Z.lt_succ_lt_pred.
 Qed.
 
-Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m.
+Lemma Zlt_succ_pred n m : Z.succ n < m -> n < Z.pred m.
 Proof.
-  intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
+  apply Z.lt_succ_lt_pred.
 Qed.
 
 (** Relating strict order and large order on positive *)
 
-Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n.
+Lemma Zlt_0_le_0_pred n : 0 < n -> 0 <= Z.pred n.
 Proof.
-  intros x H.
-  rewrite (Zsucc_pred x) in H.
-  apply Zgt_succ_le.
-  apply Zlt_gt.
-  assumption.
+  apply Z.lt_le_pred.
 Qed.
 
-Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n.
+Lemma Zgt_0_le_0_pred n : n > 0 -> 0 <= Z.pred n.
 Proof.
-  intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
+  Z.swap_greater. apply Z.lt_le_pred.
 Qed.
 
-
 (** Special cases of ordered integers *)
 
-Lemma Zlt_0_1 : 0 < 1.
-Proof.
-  change (0 < Zsucc 0) in |- *. apply Zlt_succ.
-Qed.
-
-Lemma Zle_0_1 : 0 <= 1.
-Proof.
-  change (0 <= Zsucc 0) in |- *. apply Zle_succ.
-Qed.
+Notation Zlt_0_1 := Z.lt_0_1 (only parsing).
+Notation Zle_0_1 := Z.le_0_1 (only parsing).
 
 Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
 Proof.
-  intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
+  easy.
 Qed.
 
 Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
 Proof.
-  unfold Zgt in |- *; trivial.
+  easy.
 Qed.
 
 (* weaker but useful (in [Zpower] for instance) *)
 Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
 Proof.
-  intro; unfold Zle in |- *; discriminate.
+ easy.
 Qed.
 
 Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
 Proof.
-  unfold Zlt in |- *; trivial.
+ easy.
 Qed.
 
-Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n.
+Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n.
 Proof.
-  simple induction n; simpl in |- *; intros;
-    [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
+  induction n; simpl; intros. apply Z.le_refl. easy.
 Qed.
 
 Hint Immediate Zeq_le: zarith.
 
-(** Transitivity using successor *)
-
-Lemma Zgt_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p.
-Proof.
-  intros n m p H1 H2; apply Zle_gt_trans with (m := m);
-    [ apply Zgt_succ_le; assumption | assumption ].
-Qed.
-
 (** Derived lemma *)
 
-Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n.
+Lemma Zgt_succ_gt_or_eq n m : Z.succ n > m -> n > m \/ m = n.
 Proof.
-  intros n m H.
-  assert (Hle : m <= n).
-  apply Zgt_succ_le; assumption.
-  destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
-  left; apply Zlt_gt; assumption.
-  right; assumption.
+  Z.swap_greater. intros. now apply Z.lt_eq_cases, Z.lt_succ_r.
 Qed.
 
 (** ** Addition *)
 (** Compatibility of addition wrt to order *)
 
-Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
-Proof.
-  unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
-    assumption.
-Qed.
-
-Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
-Proof.
-  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
-    apply Zplus_gt_compat_l; trivial.
-Qed.
-
-Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
-Proof.
-  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
-    rewrite <- (Zcompare_plus_compat n m p); assumption.
-Qed.
+Notation Zplus_lt_le_compat := Z.add_lt_le_mono (only parsing).
+Notation Zplus_le_lt_compat := Z.add_le_lt_mono (only parsing).
+Notation Zplus_le_compat := Z.add_le_mono (only parsing).
+Notation Zplus_lt_compat := Z.add_lt_mono (only parsing).
 
-Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
+Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m.
 Proof.
-  intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
-    exact (Zplus_le_compat_l a b c).
+  Z.swap_greater. apply Z.add_lt_mono_l.
 Qed.
 
-Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
+Lemma Zplus_gt_compat_r n m p : n > m -> n + p > m + p.
 Proof.
-  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
-    trivial with arith.
+  Z.swap_greater. apply Z.add_lt_mono_r.
 Qed.
 
-Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
+Lemma Zplus_le_compat_l n m p : n <= m -> p + n <= p + m.
 Proof.
-  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
-    apply Zplus_lt_compat_l; trivial.
+  apply Z.add_le_mono_l.
 Qed.
 
-Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
+Lemma Zplus_le_compat_r n m p : n <= m -> n + p <= m + p.
 Proof.
-  intros a b c d H0 H1.
-  apply Zlt_le_trans with (b + c).
-  apply Zplus_lt_compat_r; trivial.
-  apply Zplus_le_compat_l; trivial.
+  apply Z.add_le_mono_r.
 Qed.
 
-Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
+Lemma Zplus_lt_compat_l n m p : n < m -> p + n < p + m.
 Proof.
-  intros a b c d H0 H1.
-  apply Zle_lt_trans with (b + c).
-  apply Zplus_le_compat_r; trivial.
-  apply Zplus_lt_compat_l; trivial.
+  apply Z.add_lt_mono_l.
 Qed.
 
-Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
+Lemma Zplus_lt_compat_r n m p : n < m -> n + p < m + p.
 Proof.
-  intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
-    [ apply Zplus_le_compat_l; assumption
-      | apply Zplus_le_compat_r; assumption ].
-Qed.
-
-
-Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
-  intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
+  apply Z.add_lt_mono_r.
 Qed.
 
-
 (** Compatibility of addition wrt to being positive *)
 
-Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
-Proof.
-  intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
-Qed.
+Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (only parsing).
 
 (** Simplification of addition wrt to order *)
 
-Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
+Lemma Zplus_le_reg_l n m p : p + n <= p + m -> n <= m.
 Proof.
-  unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
-    assumption.
+ apply Z.add_le_mono_l.
 Qed.
 
-Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
+Lemma Zplus_le_reg_r n m p : n + p <= m + p -> n <= m.
 Proof.
-  intros n m p H; apply Zplus_gt_reg_l with p.
-  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+ apply Z.add_le_mono_r.
 Qed.
 
-Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
+Lemma Zplus_lt_reg_l n m p : p + n < p + m -> n < m.
 Proof.
-  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
-    rewrite (Zcompare_plus_compat n m p); assumption.
+ apply Z.add_lt_mono_l.
 Qed.
 
-Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
+Lemma Zplus_lt_reg_r n m p : n + p < m + p -> n < m.
 Proof.
-  intros n m p H; apply Zplus_le_reg_l with p.
-  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+ apply Z.add_lt_mono_r.
 Qed.
 
-Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
+Lemma Zplus_gt_reg_l n m p : p + n > p + m -> n > m.
 Proof.
-  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
-    trivial with arith.
+ Z.swap_greater. apply Z.add_lt_mono_l.
 Qed.
 
-Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
+Lemma Zplus_gt_reg_r n m p : n + p > m + p -> n > m.
 Proof.
-  intros n m p H; apply Zplus_lt_reg_l with p.
-  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+ Z.swap_greater. apply Z.add_lt_mono_r.
 Qed.
 
 (** ** 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.
+Lemma Zmult_le_compat_r n m p : n <= m -> 0 <= p -> n * p <= m * p.
 Proof.
-  intros a b c H H0; destruct c.
-  do 2 rewrite Zmult_0_r; assumption.
-  rewrite (Zmult_comm a); rewrite (Zmult_comm b).
-  unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
-  unfold Zle in H0; contradiction H0; reflexivity.
+ intros. now apply Z.mul_le_mono_nonneg_r.
 Qed.
 
-Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m.
+Lemma Zmult_le_compat_l n m p : n <= m -> 0 <= p -> p * n <= p * m.
 Proof.
-  intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
-  apply Zmult_le_compat_r; trivial.
+ intros. now apply Z.mul_le_mono_nonneg_l.
 Qed.
 
-Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p.
+Lemma Zmult_lt_compat_r n m p : 0 < p -> n < m -> n * p < m * p.
 Proof.
-  intros x y z H H0; destruct z.
-  contradiction (Zlt_irrefl 0).
-  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
-  unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
-  discriminate H.
+ apply Z.mul_lt_mono_pos_r.
 Qed.
 
-Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p.
+Lemma Zmult_gt_compat_r n m p : p > 0 -> n > m -> n * p > m * p.
 Proof.
-  intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
-    assumption.
+ Z.swap_greater. apply Z.mul_lt_mono_pos_r.
 Qed.
 
-Lemma Zmult_gt_0_lt_compat_r :
-  forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
+Lemma Zmult_gt_0_lt_compat_r n m p : p > 0 -> n < m -> n * p < m * p.
 Proof.
-  intros x y z; intros; apply Zmult_lt_compat_r;
-    [ apply Zgt_lt; assumption | assumption ].
+ Z.swap_greater. apply Z.mul_lt_mono_pos_r.
 Qed.
 
-Lemma Zmult_gt_0_le_compat_r :
-  forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
+Lemma Zmult_gt_0_le_compat_r n m p : p > 0 -> n <= m -> n * p <= m * p.
 Proof.
-  intros x y z Hz Hxy.
-  elim (Zle_lt_or_eq x y Hxy).
-  intros; apply Zlt_le_weak.
-  apply Zmult_gt_0_lt_compat_r; trivial.
-  intros; apply Zeq_le.
-  rewrite H; trivial.
+ Z.swap_greater. apply Z.mul_le_mono_pos_r.
 Qed.
 
-Lemma Zmult_lt_0_le_compat_r :
-  forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
+Lemma Zmult_lt_0_le_compat_r n m p : 0 < p -> n <= m -> n * p <= m * p.
 Proof.
-  intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
-    assumption.
+ apply Z.mul_le_mono_pos_r.
 Qed.
 
-Lemma Zmult_gt_0_lt_compat_l :
-  forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
+Lemma Zmult_gt_0_lt_compat_l n m p : p > 0 -> n < m -> p * n < p * m.
 Proof.
-  intros x y z; intros.
-  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
-    apply Zmult_gt_0_lt_compat_r; assumption.
+ Z.swap_greater. apply Z.mul_lt_mono_pos_l.
 Qed.
 
-Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m.
+Lemma Zmult_lt_compat_l n m p : 0 < p -> n < m -> p * n < p * m.
 Proof.
-  intros x y z; intros.
-  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
-    apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
+ apply Z.mul_lt_mono_pos_l.
 Qed.
 
-Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m.
+Lemma Zmult_gt_compat_l n m p : p > 0 -> n > m -> p * n > p * m.
 Proof.
-  intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
-    apply Zmult_gt_compat_r; assumption.
+ Z.swap_greater. apply Z.mul_lt_mono_pos_l.
 Qed.
 
-Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p.
+Lemma Zmult_ge_compat_r n m p : n >= m -> p >= 0 -> n * p >= m * p.
 Proof.
-  intros a b c H1 H2; apply Zle_ge.
-  apply Zmult_le_compat_r; apply Zge_le; trivial.
+ Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_r.
 Qed.
 
-Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m.
+Lemma Zmult_ge_compat_l n m p : n >= m -> p >= 0 -> p * n >= p * m.
 Proof.
-  intros a b c H1 H2; apply Zle_ge.
-  apply Zmult_le_compat_l; apply Zge_le; trivial.
+ Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_l.
 Qed.
 
-Lemma Zmult_ge_compat :
-  forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
+Lemma Zmult_ge_compat n m p q :
+  n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
 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 Zmult_ge_compat_r; trivial.
+ Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg.
 Qed.
 
-Lemma Zmult_le_compat :
-  forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
+Lemma Zmult_le_compat n m p q :
+  n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
 Proof.
-  intros a b c d H0 H1 H2 H3.
-  apply Zle_trans with (c * b).
-  apply Zmult_le_compat_r; assumption.
-  apply Zmult_le_compat_l.
-  assumption.
-  apply Zle_trans with a; assumption.
+ intros. now apply Z.mul_le_mono_nonneg.
 Qed.
 
 (** Simplification of multiplication by a positive wrt to being positive *)
 
-Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m.
+Lemma Zmult_gt_0_lt_reg_r n m p : p > 0 -> n * p < m * p -> n < m.
 Proof.
-  intros x y z; intros; destruct z.
-  contradiction (Zgt_irrefl 0).
-  rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0.
-  unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
-  discriminate H.
+ Z.swap_greater. apply Z.mul_lt_mono_pos_r.
 Qed.
 
-Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m.
+Lemma Zmult_lt_reg_r n m p : 0 < p -> n * p < m * p -> n < m.
 Proof.
-  intros a b c H0 H1.
-  apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
+ apply Z.mul_lt_mono_pos_r.
 Qed.
 
-Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m.
+Lemma Zmult_le_reg_r n m p : p > 0 -> n * p <= m * p -> n <= m.
 Proof.
-  intros x y z Hz Hxy.
-  elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
-  intros; apply Zlt_le_weak.
-  apply Zmult_gt_0_lt_reg_r with z; trivial.
-  intros; apply Zeq_le.
-  apply Zmult_reg_r with z.
-  intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
-  assumption.
+ Z.swap_greater. apply Z.mul_le_mono_pos_r.
 Qed.
 
-Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m.
+Lemma Zmult_lt_0_le_reg_r n m p : 0 < p -> n * p <= m * p -> n <= m.
 Proof.
-  intros x y z; intros; apply Zmult_le_reg_r with z.
-  try apply Zlt_gt; assumption.
-  assumption.
+ apply Z.mul_le_mono_pos_r.
 Qed.
 
-
-Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m.
+Lemma Zmult_ge_reg_r n m p : p > 0 -> n * p >= m * p -> n >= m.
 Proof.
-  intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
-  apply Zge_le; trivial.
+ Z.swap_greater. apply Z.mul_le_mono_pos_r.
 Qed.
 
-Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m.
+Lemma Zmult_gt_reg_r n m p : p > 0 -> n * p > m * p -> n > m.
 Proof.
-  intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
-  apply Zgt_lt; trivial.
+ Z.swap_greater. apply Z.mul_lt_mono_pos_r.
 Qed.
 
-
-(** Compatibility of multiplication by a positive wrt to being positive *)
-
-Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m.
+Lemma Zmult_lt_compat n m p q :
+  0 <= n < p -> 0 <= m < q -> n * m < p * q.
 Proof.
-  intros x y; case x.
-  intros; rewrite Zmult_0_l; trivial.
-  intros p H1; unfold Zle in |- *.
-  pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
-  rewrite Zcompare_mult_compat; trivial.
-  intros p H1 H2; absurd (0 > Zneg p); trivial.
-  unfold Zgt in |- *; simpl in |- *; auto with zarith.
+ intros (Hn,Hnp) (Hm,Hmq). now apply Z.mul_lt_mono_nonneg.
 Qed.
 
-Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0.
+Lemma Zmult_lt_compat2 n m p q :
+  0 < n <= p -> 0 < m < q -> n * m < p * q.
 Proof.
-  intros x y; case x.
-  intros H; discriminate H.
-  intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
-    rewrite <- (Zmult_0_r (Zpos p)).
-  rewrite Zcompare_mult_compat; trivial.
-  intros p H; discriminate H.
+  intros (Hn, Hnp) (Hm,Hmq).
+  apply Z.le_lt_trans with (p * m).
+   apply Z.mul_le_mono_pos_r; trivial.
+   apply Z.mul_lt_mono_pos_l; Z.order.
 Qed.
 
-Lemma Zmult_lt_0_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m.
+(** Compatibility of multiplication by a positive wrt to being positive *)
+
+Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (only parsing).
+Notation Zmult_lt_0_compat := Z.mul_pos_pos (only parsing).
+Notation Zmult_lt_O_compat := Z.mul_pos_pos (only parsing).
+
+Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0.
 Proof.
-  intros a b apos bpos.
-  apply Zgt_lt.
-  apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
+ Z.swap_greater. apply Z.mul_pos_pos.
 Qed.
 
-(** For compatibility *)
-Notation Zmult_lt_O_compat := Zmult_lt_0_compat (only parsing).
+(* To remove someday ... *)
 
-Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n.
+Lemma Zmult_gt_0_le_0_compat n m : n > 0 -> 0 <= m -> 0 <= m * n.
 Proof.
-  intros x y H1 H2; apply Zmult_le_0_compat; trivial.
-  apply Zlt_le_weak; apply Zgt_lt; trivial.
+ Z.swap_greater. intros. apply Z.mul_nonneg_nonneg. trivial.
+  now apply Z.lt_le_incl.
 Qed.
 
 (** Simplification of multiplication by a positive wrt to being positive *)
 
-Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m.
+Lemma Zmult_le_0_reg_r n m : n > 0 -> 0 <= m * n -> 0 <= m.
 Proof.
-  intros x y; case x;
-    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
-      | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
-	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
-	  rewrite Zcompare_mult_compat; auto with arith
-      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+ Z.swap_greater. apply Z.mul_nonneg_cancel_r.
 Qed.
 
-Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m.
+Lemma Zmult_lt_0_reg_r n m : 0 < n -> 0 < m * n -> 0 < m.
 Proof.
-  intros x y; case x;
-    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
-      | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
-	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
-	  rewrite Zcompare_mult_compat; auto with arith
-      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+ apply Z.mul_pos_cancel_r.
 Qed.
 
-Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m.
+Lemma Zmult_gt_0_lt_0_reg_r n m : n > 0 -> 0 < m * n -> 0 < m.
 Proof.
-  intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
-    assumption.
+ Z.swap_greater. apply Z.mul_pos_cancel_r.
 Qed.
 
-Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0.
+Lemma Zmult_gt_0_reg_l n m : n > 0 -> n * m > 0 -> m > 0.
 Proof.
-  intros x y; case x.
-  intros H; discriminate H.
-  intros p H1; unfold Zgt in |- *.
-  pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
-  rewrite Zcompare_mult_compat; trivial.
-  intros p H; discriminate H.
+ Z.swap_greater. apply Z.mul_pos_cancel_l.
 Qed.
 
 (** ** Square *)
 (** Simplification of square wrt order *)
 
-Lemma Zgt_square_simpl :
-  forall n m:Z, n >= 0 -> n * n > m * m -> n > m.
+Lemma Zlt_square_simpl n m : 0 <= n -> m * m < n * n -> m < n.
 Proof.
-  intros n m H0 H1.
-  case (dec_Zlt m n).
-  intro; apply Zlt_gt; trivial.
-  intros H2; cut (m >= n).
-  intros H.
-  elim Zgt_not_le with (1 := H1).
-  apply Zge_le.
-  apply Zmult_ge_compat; auto.
-  apply Znot_lt_ge; trivial.
+ apply Z.square_lt_simpl_nonneg.
 Qed.
 
-Lemma Zlt_square_simpl :
-  forall n m:Z, 0 <= n -> m * m < n * n -> m < n.
+Lemma Zgt_square_simpl n m : n >= 0 -> n * n > m * m -> n > m.
 Proof.
-  intros x y H0 H1.
-  apply Zgt_lt.
-  apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
+ Z.swap_greater. apply Z.square_lt_simpl_nonneg.
 Qed.
 
 (** * Equivalence between inequalities *)
 
-Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p.
-Proof.
-  intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
-  rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
-  intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
-  apply Zplus_le_compat_r. assumption.
-Qed.
-
-Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p.
-Proof.
-  intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
-  rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
-  assumption.
-  intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
-  rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
-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.
-  assumption.
-  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;
-	assumption.
-Qed.
-
-Lemma Zlt_0_minus_lt : forall n m:Z, 0 < n - m -> m < n.
-Proof.
-  intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
-    rewrite Zplus_comm; exact H.
-Qed.
+Notation Zle_plus_swap := Z.le_add_le_sub_r (only parsing).
+Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (only parsing).
+Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (only parsing).
 
-Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n.
+Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p.
 Proof.
-  intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l;
-    rewrite Zplus_comm; exact H.
+ apply Z.add_move_r.
 Qed.
 
-Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m.
+Lemma Zlt_0_minus_lt n m : 0 < n - m -> m < n.
 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.
+ apply Z.lt_0_sub.
 Qed.
 
-Lemma Zmult_lt_compat:
-  forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q.
+Lemma Zle_0_minus_le n m : 0 <= n - m -> m <= n.
 Proof.
-  intros n m p q (H1, H2) (H3,H4).
-  assert (0<p) by (apply Zle_lt_trans with n; auto).
-  assert (0<q) by (apply Zle_lt_trans with m; auto).
-  case Zle_lt_or_eq with (1 := H1); intros H5; auto with zarith.
-  case Zle_lt_or_eq with (1 := H3); intros H6; auto with zarith.
-  apply Zlt_trans with (n * q).
-  apply Zmult_lt_compat_l; auto.
-  apply Zmult_lt_compat_r; auto with zarith.
-  rewrite <- H6; rewrite Zmult_0_r; apply Zmult_lt_0_compat; auto with zarith.
-  rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith.
+ apply Z.le_0_sub.
 Qed.
 
-Lemma Zmult_lt_compat2:
-  forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q.
+Lemma Zle_minus_le_0 n m : m <= n -> 0 <= n - m.
 Proof.
-  intros n m p q (H1, H2) (H3, H4).
-  apply Zle_lt_trans with (p * m).
-  apply Zmult_le_compat_r; auto.
-  apply Zlt_le_weak; auto.
-  apply Zmult_lt_compat_l; auto.
-  apply Zlt_le_trans with n; auto.
+ apply Z.le_0_sub.
 Qed.
 
 (** For compatibility *)
diff --git a/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v
new file mode 100644
index 00000000..a90eedb4
--- /dev/null
+++ b/theories/ZArith/Zpow_alt.v
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinInt.
+Local Open Scope Z_scope.
+
+(** An alternative power function for Z *)
+
+(** This [Zpower_alt] is extensionnaly equal to [Z.pow],
+    but not convertible with it. The number of
+    multiplications is logarithmic instead of linear, but
+    these multiplications are bigger. Experimentally, it seems
+    that [Zpower_alt] is slightly quicker than [Z.pow] on average,
+    but can be quite slower on powers of 2.
+*)
+
+Definition Zpower_alt n m :=
+  match m with
+    | Z0 => 1
+    | Zpos p => Pos.iter_op Z.mul p n
+    | Zneg p => 0
+  end.
+
+Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope.
+
+Lemma Piter_mul_acc : forall f,
+ (forall x y:Z, (f x)*y = f (x*y)) ->
+ forall p k, Pos.iter p f k = (Pos.iter p f 1)*k.
+Proof.
+ intros f Hf.
+ induction p; simpl; intros.
+ - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Hf, Z.mul_assoc.
+ - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Z.mul_assoc.
+ - now rewrite Hf, Z.mul_1_l.
+Qed.
+
+Lemma Piter_op_square : forall p a,
+ Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a).
+Proof.
+ induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1.
+Qed.
+
+Lemma Zpower_equiv a b : a^^b = a^b.
+Proof.
+ destruct b as [|p|p]; trivial.
+ unfold Zpower_alt, Z.pow, Z.pow_pos.
+ revert a.
+ induction p; simpl; intros.
+ - f_equal.
+   rewrite Piter_mul_acc.
+   now rewrite Piter_op_square, IHp.
+   intros. symmetry; apply Z.mul_assoc.
+ - rewrite Piter_mul_acc.
+   now rewrite Piter_op_square, IHp.
+   intros. symmetry; apply Z.mul_assoc.
+ - now Z.nzsimpl.
+Qed.
+
+Lemma Zpower_alt_0_r n : n^^0 = 1.
+Proof. reflexivity. Qed.
+
+Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b.
+Proof.
+ destruct b as [|b|b]; intros Hb; simpl.
+ - now Z.nzsimpl.
+ - now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc.
+ - now elim Hb.
+Qed.
+
+Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0.
+Proof.
+ now destruct b.
+Qed.
+
+Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q).
+Proof.
+ now rewrite Zpower_equiv, Z.pow_Zpos.
+Qed.
diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v
index 620d6324..6f1ebc06 100644
--- a/theories/ZArith/Zpow_def.v
+++ b/theories/ZArith/Zpow_def.v
@@ -1,27 +1,31 @@
-Require Import ZArith_base.
-Require Import Ring_theory.
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
 
-Open Local Scope Z_scope.
+Require Import BinInt Ring_theory.
+Local Open 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]) *)
-Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1.
+(** * Power functions over [Z] *)
 
-Definition Zpower (x y:Z) :=
-    match y with
-      | Zpos p => Zpower_pos x p
-      | Z0 => 1
-      | Zneg p => 0
-    end.
+(** Nota : this file is mostly deprecated. The definition of [Z.pow]
+    and its usual properties are now provided by module [BinInt.Z]. *)
 
-Lemma Zpower_theory : power_theory 1 Zmult (eq (A:=Z)) Z_of_N Zpower.
+Notation Zpower_pos := Z.pow_pos (only parsing).
+Notation Zpower := Z.pow (only parsing).
+Notation Zpower_0_r := Z.pow_0_r (only parsing).
+Notation Zpower_succ_r := Z.pow_succ_r (only parsing).
+Notation Zpower_neg_r := Z.pow_neg_r (only parsing).
+Notation Zpower_Ppow := Z.pow_Zpos (only parsing).
+
+Lemma Zpower_theory : power_theory 1 Z.mul (@eq Z) Z.of_N Z.pow.
 Proof.
  constructor. intros.
  destruct n;simpl;trivial.
- unfold Zpower_pos.
- assert (forall k, iter_pos p Z (fun x : Z => r * x) k = pow_pos Zmult r p*k).
- induction p;simpl;intros;repeat rewrite IHp;trivial;
-   repeat rewrite Zmult_assoc;trivial.
- rewrite H;rewrite Zmult_1_r;trivial.
+ unfold Z.pow_pos.
+ rewrite <- (Z.mul_1_r (pow_pos _ _ _)). generalize 1.
+ induction p; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial.
 Qed.
-
diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v
index 7879fe42..27e3def4 100644
--- a/theories/ZArith/Zpow_facts.v
+++ b/theories/ZArith/Zpow_facts.v
@@ -1,295 +1,109 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zpow_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import ZArith_base.
-Require Import ZArithRing.
-Require Import Zcomplements.
+Require Import ZArith_base ZArithRing Zcomplements Zdiv Znumtheory.
 Require Export Zpower.
-Require Import Zdiv.
-Require Import Znumtheory.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
-Lemma Zpower_pos_1_r: forall x, Zpower_pos x 1 = x.
-Proof.
-  intros x; unfold Zpower_pos; simpl; auto with zarith.
-Qed.
+(** Properties of the power function over [Z] *)
 
-Lemma Zpower_pos_1_l: forall p, Zpower_pos 1 p = 1.
-Proof.
-  induction p.
-  (* xI *)
-  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
-  repeat rewrite Zpower_pos_is_exp.
-  rewrite Zpower_pos_1_r, IHp; auto.
-  (* xO *)
-  rewrite <- Pplus_diag.
-  repeat rewrite Zpower_pos_is_exp.
-  rewrite IHp; auto.
-  (* xH *)
-  rewrite Zpower_pos_1_r; auto.
-Qed.
+(** Nota: the usual properties of [Z.pow] are now already provided
+    by [BinInt.Z]. Only remain here some compatibility elements,
+    as well as more specific results about power and modulo and/or
+    primality. *)
 
-Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0.
-Proof.
-  induction p.
-  change (xI p) with (1 + (xO p))%positive.
-  rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto.
-  rewrite <- Pplus_diag.
-  rewrite Zpower_pos_is_exp, IHp; auto.
-  rewrite Zpower_pos_1_r; auto.
-Qed.
+Lemma Zpower_pos_1_r x : Z.pow_pos x 1 = x.
+Proof (Z.pow_1_r x).
 
-Lemma Zpower_pos_pos: forall x p,
-  0 < x -> 0 < Zpower_pos x p.
-Proof.
-  induction p; intros.
-  (* xI *)
-  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
-  repeat rewrite Zpower_pos_is_exp.
-  rewrite Zpower_pos_1_r.
-  repeat apply Zmult_lt_0_compat; auto.
-  (* xO *)
-  rewrite <- Pplus_diag.
-  repeat rewrite Zpower_pos_is_exp.
-  repeat apply Zmult_lt_0_compat; auto.
-  (* xH *)
-  rewrite Zpower_pos_1_r; auto.
-Qed.
+Lemma Zpower_pos_1_l p : Z.pow_pos 1 p = 1.
+Proof. now apply (Z.pow_1_l (Zpos p)). Qed.
 
+Lemma Zpower_pos_0_l p : Z.pow_pos 0 p = 0.
+Proof. now apply (Z.pow_0_l (Zpos p)). Qed.
 
-Theorem Zpower_1_r: forall z, z^1 = z.
-Proof.
-  exact Zpower_pos_1_r.
-Qed.
-
-Theorem Zpower_1_l: forall z, 0 <= z -> 1^z = 1.
-Proof.
-  destruct z; simpl; auto.
-  intros; apply Zpower_pos_1_l.
-  intros; compute in H; elim H; auto.
-Qed.
+Lemma Zpower_pos_pos x p : 0 < x -> 0 < Z.pow_pos x p.
+Proof. intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed.
 
-Theorem Zpower_0_l: forall z, z<>0 -> 0^z = 0.
-Proof.
-  destruct z; simpl; auto with zarith.
-  intros; apply Zpower_pos_0_l.
-Qed.
+Notation Zpower_1_r := Z.pow_1_r (only parsing).
+Notation Zpower_1_l := Z.pow_1_l (only parsing).
+Notation Zpower_0_l := Z.pow_0_l' (only parsing).
+Notation Zpower_0_r := Z.pow_0_r (only parsing).
+Notation Zpower_2 := Z.pow_2_r (only parsing).
+Notation Zpower_gt_0 := Z.pow_pos_nonneg (only parsing).
+Notation Zpower_ge_0 := Z.pow_nonneg (only parsing).
+Notation Zpower_Zabs := Z.abs_pow (only parsing).
+Notation Zpower_Zsucc := Z.pow_succ_r (only parsing).
+Notation Zpower_mult := Z.pow_mul_r (only parsing).
+Notation Zpower_le_monotone2 := Z.pow_le_mono_r (only parsing).
 
-Theorem Zpower_0_r: forall z, z^0 = 1.
-Proof.
-  simpl; auto.
-Qed.
-
-Theorem Zpower_2: forall z, z^2 = z * z.
-Proof.
-  intros; ring.
-Qed.
-
-Theorem Zpower_gt_0: forall x y,
-  0 < x -> 0 <= y -> 0 < x^y.
-Proof.
-  destruct y; simpl; auto with zarith.
-  intros; apply Zpower_pos_pos; auto.
-  intros; compute in H0; elim H0; auto.
-Qed.
-
-Theorem Zpower_Zabs: forall a b,  Zabs (a^b) = (Zabs a)^b.
-Proof.
-  intros a b; case (Zle_or_lt 0 b).
-  intros Hb; pattern b; apply natlike_ind; auto with zarith.
-  intros x Hx Hx1; unfold Zsucc.
-  (repeat rewrite Zpower_exp); auto with zarith.
-  rewrite Zabs_Zmult; rewrite Hx1.
-  f_equal; auto.
-  replace (a ^ 1) with a; auto.
-  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
-  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
-  case b; simpl; auto with zarith.
-  intros p Hp; discriminate.
-Qed.
-
-Theorem Zpower_Zsucc: forall p n, 0 <= n -> p^(Zsucc n) = p * p^n.
-Proof.
-  intros p n H.
-  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
-  rewrite Zpower_1_r; apply Zmult_comm.
-Qed.
-
-Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p^(q*r) = (p^q)^r.
-Proof.
-  intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto.
-  intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto.
-  intros r1 H3 H4 H5.
-  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
-  rewrite <- H4; try rewrite Zpower_1_r; try rewrite <- Zpower_exp; try f_equal; auto with zarith.
-  ring.
-  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 a b c :
  0 < a -> 0 <= b <= c -> a^b <= a^c.
-Proof.
-  intros a b c H (H1, H2).
-  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
-  rewrite Zpower_exp; auto with zarith.
-  apply Zmult_le_compat_l; auto with zarith.
-  assert (0 < a ^ (c - b)); auto with zarith.
-  apply Zpower_gt_0; auto with zarith.
-  apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
-Qed.
+Proof. intros. now apply Z.pow_le_mono_r. Qed.
 
-Theorem Zpower_lt_monotone: forall a b c,
+Theorem Zpower_lt_monotone a b c :
  1 < a -> 0 <= b < c -> a^b < a^c.
-Proof.
-  intros a b c H (H1, H2).
-  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
-  rewrite Zpower_exp; auto with zarith.
-  apply Zmult_lt_compat_l; auto with zarith.
-  apply Zpower_gt_0; auto with zarith.
-  assert (0 < a ^ (c - b)); auto with zarith.
-  apply Zpower_gt_0; auto with zarith.
-  apply Zlt_le_trans with (a ^1); auto with zarith.
-  rewrite Zpower_1_r; auto with zarith.
-  apply Zpower_le_monotone; auto with zarith.
-Qed.
-
-Theorem Zpower_gt_1 : forall x y,
-  1 < x -> 0 < y -> 1 < x^y.
-Proof.
-  intros x y H1 H2.
-  replace 1 with (x ^ 0) by apply Zpower_0_r.
-  apply Zpower_lt_monotone; auto with zarith.
-Qed.
+Proof. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed.
 
-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.
-  generalize H1; case x; compute; intros; auto; try discriminate.
-Qed.
-
-Theorem Zpower_le_monotone2:
-   forall a b c, 0 < a -> b <= c -> a^b <= a^c.
-Proof.
-  intros a b c H H2.
-  destruct (Z_le_gt_dec 0 b).
-  apply Zpower_le_monotone; auto.
-  replace (a^b) with 0.
-  destruct (Z_le_gt_dec 0 c).
-  destruct (Zle_lt_or_eq _ _ z0).
-  apply Zlt_le_weak;apply Zpower_gt_0;trivial.
-  rewrite <- H0;simpl;auto with zarith.
-  replace (a^c) with 0. auto with zarith.
-  destruct c;trivial;unfold Zgt in z0;discriminate z0.
-  destruct b;trivial;unfold Zgt in z;discriminate z.
-Qed.
+Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y.
+Proof. apply Z.pow_gt_1. Qed.
 
-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.
-  clear r H1; intros r H1 H2 H3.
-  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
-  rewrite H2; repeat rewrite Zpower_exp; auto with zarith; ring.
-Qed.
+Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r.
+Proof. intros. apply Z.pow_mul_l. Qed.
 
-Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith.
+Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith.
 
-Theorem Zpower_le_monotone3: forall a b c,
+Theorem Zpower_le_monotone3 a b c :
  0 <= c -> 0 <= a <= b -> a^c <= b^c.
-Proof.
-  intros a b c H (H1, H2).
-  generalize H; pattern c; apply natlike_ind; auto.
-  intros x HH HH1 _; unfold Zsucc; repeat rewrite Zpower_exp; auto with zarith.
-  repeat rewrite Zpower_1_r.
-  apply Zle_trans with (a^x * b); auto with zarith.
-Qed.
+Proof. intros. now apply Z.pow_le_mono_l. Qed.
 
-Lemma Zpower_le_monotone_inv: forall a b c,
+Lemma Zpower_le_monotone_inv a b c :
   1 < a -> 0 < b -> a^b <= a^c -> b <= c.
 Proof.
-  intros a b c H H0 H1.
-  destruct (Z_le_gt_dec b c);trivial.
-  assert (2 <= a^b).
-   apply Zle_trans with (2^b).
-   pattern 2 at 1;replace 2 with (2^1);trivial.
-   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 (Zle_lt_or_eq _ _ z0);auto with zarith.
-  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.
+ intros Ha Hb H. apply (Z.pow_le_mono_r_iff a); trivial.
+ apply Z.lt_le_incl; apply (Z.pow_gt_1 a); trivial.
+ apply Z.lt_le_trans with (a^b); trivial. now apply Z.pow_gt_1.
 Qed.
 
-Theorem Zpower_nat_Zpower: forall p q, 0 <= q ->
- p^q = Zpower_nat p (Zabs_nat q).
-Proof.
-  intros p1 q1; case q1; simpl.
-  intros _; exact (refl_equal _).
-  intros p2 _; apply Zpower_pos_nat.
-  intros p2 H1; case H1; auto.
-Qed.
+Notation Zpower_nat_Zpower := Zpower_nat_Zpower (only parsing).
 
-Theorem Zpower2_lt_lin: forall n, 0 <= n -> n < 2^n.
-Proof.
-  intros n; apply (natlike_ind (fun n => n < 2 ^n)); clear n.
-  simpl; auto with zarith.
-  intros n H1 H2; unfold Zsucc.
-  case (Zle_lt_or_eq _ _ H1); clear H1; intros H1.
-  apply Zle_lt_trans with (n + n); auto with zarith.
-  rewrite Zpower_exp; auto with zarith.
-  rewrite Zpower_1_r.
-  assert (tmp: forall p, p * 2 = p + p); intros; try ring;
-  rewrite tmp; auto with zarith.
-  subst n; simpl; unfold Zpower_pos; simpl; auto with zarith.
-Qed.
+Theorem Zpower2_lt_lin n : 0 <= n -> n < 2^n.
+Proof. intros. now apply Z.pow_gt_lin_r. Qed.
 
-Theorem Zpower2_le_lin: forall n, 0 <= n -> n <= 2^n.
-Proof.
-  intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto.
-Qed.
+Theorem Zpower2_le_lin n : 0 <= n -> n <= 2^n.
+Proof. intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed.
 
-Lemma Zpower2_Psize :
-  forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat.
+Lemma Zpower2_Psize n p :
+  Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat.
 Proof.
-  induction n.
-  destruct p; split; intros H; discriminate H || inversion H.
-  destruct p; simpl Psize.
-  rewrite inj_S, Zpower_Zsucc; auto with zarith.
-  rewrite Zpos_xI; specialize IHn with p; omega.
-  rewrite inj_S, Zpower_Zsucc; auto with zarith.
-  rewrite Zpos_xO; specialize IHn with p; omega.
-  split; auto with arith.
-  intros _; apply Zpower_gt_1; auto with zarith.
-  rewrite inj_S; generalize (Zle_0_nat n); omega.
+  revert p; induction n.
+  destruct p; now split.
+  assert (Hn := Nat2Z.is_nonneg n).
+  destruct p; simpl Pos.size_nat.
+  - specialize IHn with p.
+    rewrite Z.pos_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega.
+  - specialize IHn with p.
+    rewrite Z.pos_xO, Nat2Z.inj_succ, Z.pow_succ_r; omega.
+  - split; auto with zarith.
+    intros _. apply Z.pow_gt_1. easy.
+    now rewrite Nat2Z.inj_succ, Z.lt_succ_r.
 Qed.
 
 (** * Zpower and modulo *)
 
-Theorem Zpower_mod: forall p q n, 0 < n ->
- (p^q) mod n = ((p mod n)^q) mod n.
+Theorem Zpower_mod p q n :
+  0 < n -> (p^q) mod n = ((p mod n)^q) mod n.
 Proof.
-  intros p q n Hn; case (Zle_or_lt 0 q); intros H1.
-  generalize H1; pattern q; apply natlike_ind; auto.
-  intros q1 Hq1 Rec _; unfold Zsucc; repeat rewrite Zpower_exp; repeat rewrite Zpower_1_r; auto with zarith.
-  rewrite (fun x => (Zmult_mod x p)); try rewrite Rec; auto with zarith.
-  rewrite (fun x y => (Zmult_mod (x ^y))); try f_equal; auto with zarith.
-  f_equal; auto; apply sym_equal; apply Zmod_mod; auto with zarith.
-  generalize H1; case q; simpl; auto.
-  intros; discriminate.
+  intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1].
+  - pattern q; apply natlike_ind; trivial.
+    clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial.
+    rewrite Z.mul_mod_idemp_l; auto with zarith.
+    rewrite Z.mul_mod, Rec, <- Z.mul_mod; auto with zarith.
+  - rewrite !Z.pow_neg_r; auto with zarith.
 Qed.
 
 (** A direct way to compute Zpower modulo **)
@@ -313,153 +127,113 @@ Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
 
 Definition Zpow_mod a m n :=
   match m with
-   | 0 => 1
+   | 0 => 1 mod n
    | Zpos p => Zpow_mod_pos a p n
    | Zneg p => 0
   end.
 
-Theorem Zpow_mod_pos_correct: forall a m n, 0 < n ->
- Zpow_mod_pos a m n = (Zpower_pos a m) mod n.
+Theorem Zpow_mod_pos_correct a m n :
+ n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n.
 Proof.
-  intros a m; elim m; simpl; auto.
-  intros p Rec n H1; rewrite xI_succ_xO, Pplus_one_succ_r, <-Pplus_diag; auto.
-  repeat rewrite Zpower_pos_is_exp; auto.
-  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.
-  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.
-  case (Zpower_pos a p mod n); auto.
-  unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith.
+  intros Hn. induction m.
+  - rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag.
+    rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r.
+    rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial.
+    rewrite <- IHm, <- Z.mul_mod by trivial.
+    simpl. now destruct (Zpow_mod_pos a m n).
+  - rewrite <- Pos.add_diag at 2.
+    rewrite Zpower_pos_is_exp.
+    rewrite Z.mul_mod by trivial.
+    rewrite <- IHm.
+    simpl. now destruct (Zpow_mod_pos a m n).
+  - now rewrite Zpower_pos_1_r.
 Qed.
 
-Theorem Zpow_mod_correct: forall a m n, 1 < n -> 0 <= m ->
- Zpow_mod a m n = (a ^ m) mod n.
+Theorem Zpow_mod_correct a m n :
+ n <> 0 -> Zpow_mod a m n = (a ^ m) mod n.
 Proof.
-  intros a m n; case m; simpl.
-  intros; apply sym_equal; apply Zmod_small; auto with zarith.
-  intros; apply Zpow_mod_pos_correct; auto with zarith.
-  intros p H H1; case H1; auto.
+  intros Hn. destruct m; simpl.
+  - trivial.
+  - apply Zpow_mod_pos_correct; auto with zarith.
+  - rewrite Z.mod_0_l; auto with zarith.
 Qed.
 
 (* Complements about power and number theory. *)
 
-Lemma Zpower_divide: forall p q, 0 < q -> (p | p ^ q).
+Lemma Zpower_divide p q : 0 < q -> (p | p ^ q).
 Proof.
-  intros p q H; exists (p ^(q - 1)).
-  pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith.
+  exists (p^(q - 1)).
+  rewrite Z.mul_comm, <- Z.pow_succ_r; f_equal; auto with zarith.
 Qed.
 
-Theorem rel_prime_Zpower_r: forall i p q, 0 < i ->
- rel_prime p q -> rel_prime p (q^i).
+Theorem rel_prime_Zpower_r 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.
-  intros H; contradict H; auto with zarith.
-  intros i Hi Rec _; rewrite Zpower_Zsucc; auto.
+  intros Hi Hpq; pattern i; apply natlike_ind; auto with zarith.
+  simpl. apply rel_prime_sym, rel_prime_1.
+  clear i Hi. intros i Hi Rec; rewrite Z.pow_succ_r; auto.
   apply rel_prime_mult; auto.
-  case Zle_lt_or_eq with (1 := Hi); intros Hi1; subst; auto.
-  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 ->
- rel_prime p q -> rel_prime (p^i) (q^j).
+Theorem rel_prime_Zpower 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.
-  intros _ j p q H H1; rewrite Zpower_0_r; apply rel_prime_1.
-  intros n Hn Rec _ j p q Hj Hpq.
-  rewrite Zpower_Zsucc; auto.
-  case Zle_lt_or_eq with (1 := Hj); intros Hj1; subst.
-  apply rel_prime_sym; apply rel_prime_mult; auto.
-  apply rel_prime_sym; apply rel_prime_Zpower_r; auto with arith.
-  apply rel_prime_sym; apply Rec; auto.
-  rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
+ intros Hi Hj H. apply rel_prime_Zpower_r; trivial.
+ apply rel_prime_sym. apply rel_prime_Zpower_r; trivial.
+ now apply rel_prime_sym.
 Qed.
 
-Theorem prime_power_prime: forall p q n, 0 <= n ->
- prime p -> prime q -> (p | q^n)  -> p = q.
+Theorem prime_power_prime 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.
-  rewrite Zpower_0_r; intros.
-  assert (2<=p) by (apply prime_ge_2; auto).
-  assert (p<=1) by (apply Zdivide_le; auto with zarith).
-  omega.
-  intros n1 H H1.
-  unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith.
-  assert (2<=p) by (apply prime_ge_2; auto).
-  assert (2<=q) by (apply prime_ge_2; auto).
-  intros H3; case prime_mult with (2 := H3); auto.
-  intros; apply prime_div_prime; auto.
+  intros Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn.
+  - simpl; intros.
+    assert (2<=p) by (apply prime_ge_2; auto).
+    assert (p<=1) by (apply Z.divide_pos_le; auto with zarith).
+    omega.
+  - intros n Hn Rec.
+    rewrite Z.pow_succ_r by trivial. intros.
+    assert (2<=p) by (apply prime_ge_2; auto).
+    assert (2<=q) by (apply prime_ge_2; auto).
+    destruct prime_mult with (2 := H); auto.
+    apply prime_div_prime; auto.
 Qed.
 
-Theorem Zdivide_power_2: forall x p n, 0 <= n -> 0 <= x -> prime p ->
- (x | p^n) -> exists m, x = p^m.
+Theorem Zdivide_power_2 x p n :
+ 0 <= n -> 0 <= x -> prime p -> (x | p^n) -> exists m, x = p^m.
 Proof.
-  intros x p n Hn Hx; revert p n Hn; generalize Hx.
+  intros Hn Hx; revert p n Hn. generalize Hx.
   pattern x; apply Z_lt_induction; auto.
   clear x Hx; intros x IH Hx p n Hn Hp H.
-  case Zle_lt_or_eq with (1 := Hx); auto; clear Hx; intros Hx; subst.
-  case (Zle_lt_or_eq 1 x); auto with zarith; clear Hx; intros Hx; subst.
+  Z.le_elim Hx; subst.
+  apply Z.le_succ_l in Hx; simpl in Hx.
+  Z.le_elim Hx; subst.
   (* x > 1 *)
-  case (prime_dec x); intros H2.
-  exists 1; rewrite Zpower_1_r; apply prime_power_prime with n; auto.
-  case not_prime_divide with (2 := H2); auto.
-  intros p1 ((H3, H4), (q1, Hq1)); subst.
-  case (IH p1) with p n; auto with zarith.
-  apply Zdivide_trans with (2 := H); exists q1; auto with zarith.
-  intros r1 Hr1.
-  case (IH q1) with p n; auto with zarith.
-  case (Zle_lt_or_eq 0 q1).
-  apply Zmult_le_0_reg_r with p1; auto with zarith.
+  case (prime_dec x); intros Hpr.
+  exists 1; rewrite Z.pow_1_r; apply prime_power_prime with n; auto.
+  case not_prime_divide with (2 := Hpr); auto.
+  intros p1 ((Hp1, Hpq1),(q1,->)).
+  assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; auto with zarith).
+  destruct (IH p1) with p n as (r1,Hr1); auto with zarith.
+  transitivity (q1 * p1); trivial. exists q1; auto with zarith.
+  destruct (IH q1) with p n as (r2,Hr2); auto with zarith.
   split; auto with zarith.
-  pattern q1 at 1; replace q1 with (q1 * 1); auto with zarith.
-  apply Zmult_lt_compat_l; auto with zarith.
-  intros H5; subst; contradict Hx; auto with zarith.
-  apply Zmult_le_0_reg_r with p1; auto with zarith.
-  apply Zdivide_trans with (2 := H); exists p1; auto with zarith.
-  intros r2 Hr2; exists (r2 + r1); subst.
-  apply sym_equal; apply Zpower_exp.
-  generalize Hx; case r2; simpl; auto with zarith.
-  intros; red; simpl; intros; discriminate.
-  generalize H3; case r1; simpl; auto with zarith.
-  intros; red; simpl; intros; discriminate.
+  rewrite <- (Z.mul_1_r q1) at 1.
+  apply Z.mul_lt_mono_pos_l; auto with zarith.
+  transitivity (q1 * p1); trivial. exists p1; auto with zarith.
+  exists (r2 + r1); subst.
+  symmetry. apply Z.pow_add_r.
+  generalize Hq1; case r2; now auto with zarith.
+  generalize Hp1; case r1; now auto with zarith.
   (* x = 1 *)
-  exists 0; rewrite Zpower_0_r; auto.
+  exists 0; rewrite Z.pow_0_r; auto.
   (* x = 0 *)
-  exists n; destruct H; rewrite Zmult_0_r in H; auto.
+  exists n; destruct H; rewrite Z.mul_0_r in H; auto.
 Qed.
 
 (** * Zsquare: a direct definition of [z^2] *)
 
-Fixpoint Psquare (p: positive): positive :=
-  match p with
-   | xH => xH
-   | xO p => xO (xO (Psquare p))
-   | xI p => xI (xO (Pplus (Psquare p) p))
-  end.
-
-Definition Zsquare 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.
-  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.
-  f_equal; auto.
-  symmetry; apply Pplus_diag.
-  symmetry; apply Pmult_xO_permute_r.
-Qed.
-
-Theorem Zsquare_correct: forall p, Zsquare p = p * p.
-Proof.
-  intro p; case p; simpl; auto; intros p1; rewrite Psquare_correct; auto.
-Qed.
+Notation Psquare := Pos.square (only parsing).
+Notation Zsquare := Z.square (only parsing).
+Notation Psquare_correct := Pos.square_spec (only parsing).
+Notation Zsquare_correct := Z.square_spec (only parsing).
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index 038748b5..5052d01a 100644
--- a/theories/ZArith/Zpower.v
+++ b/theories/ZArith/Zpower.v
@@ -1,79 +1,89 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zpower.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-Require Import Wf_nat.
-Require Import ZArith_base.
+Require Import Wf_nat ZArith_base Omega Zcomplements.
 Require Export Zpow_def.
-Require Import Omega.
-Require Import Zcomplements.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
+
+(** * Power functions over [Z] *)
 
-Infix "^" := Zpower : Z_scope.
+(** Nota : this file is mostly deprecated. The definition of [Z.pow]
+    and its usual properties are now provided by module [BinInt.Z].
+    Powers of 2 are also available there (see [Z.shiftl] and [Z.shiftr]).
+    Only remain here:
+     - [Zpower_nat] : a power function with a [nat] exponent
+     - old-style powers of two, such as [two_p]
+     - [Zdiv_rest] : a division + modulo when the divisor is a power of 2
+*)
 
-(** * 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]) *)
 
-Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.
+Definition Zpower_nat (z:Z) (n:nat) := nat_iter n (Z.mul z) 1.
+
+Lemma Zpower_nat_0_r z : Zpower_nat z 0 = 1.
+Proof. reflexivity. Qed.
+
+Lemma Zpower_nat_succ_r n z : Zpower_nat z (S n) = z * (Zpower_nat z n).
+Proof. reflexivity. Qed.
 
 (** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
-    [plus : nat->nat] and [Zmult : Z->Z] *)
+    [plus : nat->nat->nat] and [Z.mul : Z->Z->Z] *)
 
 Lemma Zpower_nat_is_exp :
   forall (n m:nat) (z:Z),
     Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m.
 Proof.
-  intros; elim n;
-   [ simpl in |- *; elim (Zpower_nat z m); auto with zarith
-     | unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H;
-       apply Zmult_assoc ].
+ induction n.
+ - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l.
+ - intros. simpl. now rewrite 2 Zpower_nat_succ_r, IHn, Z.mul_assoc.
+Qed.
+
+(** Conversions between powers of unary and binary integers *)
+
+Lemma Zpower_pos_nat (z : Z) (p : positive) :
+  Z.pow_pos z p = Zpower_nat z (Pos.to_nat p).
+Proof.
+  apply Pos2Nat.inj_iter.
 Qed.
 
-(** This theorem shows that powers of unary and binary integers
-   are the same thing, modulo the function convert : [positive -> nat] *)
+Lemma Zpower_nat_Z (z : Z) (n : nat) :
+  Zpower_nat z n = z ^ (Z.of_nat n).
+Proof.
+ induction n. trivial.
+ rewrite Zpower_nat_succ_r, Nat2Z.inj_succ, Z.pow_succ_r.
+ now f_equal.
+ apply Nat2Z.is_nonneg.
+Qed.
 
-Lemma Zpower_pos_nat :
-  forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p).
+Theorem Zpower_nat_Zpower z n : 0 <= n ->
+ z^n = Zpower_nat z (Z.abs_nat n).
 Proof.
-  intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *;
-    apply iter_nat_of_P.
+ intros. now rewrite Zpower_nat_Z, Zabs2Nat.id_abs, Z.abs_eq.
 Qed.
 
-(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
-   deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
-   for [add : positive->positive] and [Zmult : Z->Z] *)
+(** The function [(Z.pow_pos z)] is a morphism
+   for [Pos.add : positive->positive->positive] and [Z.mul : Z->Z->Z] *)
 
-Lemma Zpower_pos_is_exp :
-  forall (n m:positive) (z:Z),
-    Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m.
+Lemma Zpower_pos_is_exp (n m : positive)(z:Z) :
+  Z.pow_pos z (n + m) = Z.pow_pos z n * Z.pow_pos z m.
 Proof.
-  intros.
-  rewrite (Zpower_pos_nat z n).
-  rewrite (Zpower_pos_nat z m).
-  rewrite (Zpower_pos_nat z (n + m)).
-  rewrite (nat_of_P_plus_morphism n m).
-  apply Zpower_nat_is_exp.
+ now apply (Z.pow_add_r z (Zpos n) (Zpos m)).
 Qed.
 
 Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith.
 Hint Unfold Zpower_pos Zpower_nat: zarith.
 
-Theorem Zpower_exp :
-  forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
+Theorem Zpower_exp x n m :
+  n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
 Proof.
-  destruct n; destruct m; auto with zarith.
-  simpl; intros; apply Zred_factor0.
-  simpl; auto with zarith.
-  intros; compute in H0; elim H0; auto.
-  intros; compute in H; elim H; auto.
+ Z.swap_greater. apply Z.pow_add_r.
 Qed.
 
 Section Powers_of_2.
@@ -81,178 +91,137 @@ Section Powers_of_2.
   (** * 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. *)
-
-  (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
+      calculus is possible. [shift n m] computes [2^n * m], i.e.
+      [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) := nat_iter n xO z.
+  Definition shift_pos (n z:positive) := Pos.iter n xO z.
   Definition shift (n:Z) (z:positive) :=
     match n with
       | Z0 => z
-      | Zpos p => iter_pos p positive xO z
+      | Zpos p => Pos.iter p xO z
       | Zneg p => z
     end.
 
   Definition two_power_nat (n:nat) := Zpos (shift_nat n 1).
   Definition two_power_pos (x:positive) := Zpos (shift_pos x 1).
 
-  Lemma two_power_nat_S :
-    forall n:nat, two_power_nat (S n) = 2 * two_power_nat n.
+  Definition two_p (x:Z) :=
+    match x with
+      | Z0 => 1
+      | Zpos y => two_power_pos y
+      | Zneg y => 0
+    end.
+
+  (** Equivalence with notions defined in BinInt *)
+
+  Lemma shift_nat_equiv n p : shift_nat n p = Pos.shiftl_nat p n.
+  Proof. reflexivity. Qed.
+
+  Lemma shift_pos_equiv n p : shift_pos n p = Pos.shiftl p (Npos n).
+  Proof. reflexivity. Qed.
+
+  Lemma shift_equiv n p : 0<=n -> Zpos (shift n p) = Z.shiftl (Zpos p) n.
   Proof.
-    intro; simpl in |- *; apply refl_equal.
+   destruct n.
+   - trivial.
+   - simpl; intros. now apply Pos.iter_swap_gen.
+   - now destruct 1.
   Qed.
 
-  Lemma shift_nat_plus :
-    forall (n m:nat) (x:positive),
-      shift_nat (n + m) x = shift_nat n (shift_nat m x).
+  Lemma two_power_nat_equiv n : two_power_nat n = 2 ^ (Z.of_nat n).
   Proof.
-    intros; unfold shift_nat in |- *; apply iter_nat_plus.
+   induction n.
+   - trivial.
+   - now rewrite Nat2Z.inj_succ, Z.pow_succ_r, <- IHn by apply Nat2Z.is_nonneg.
   Qed.
 
-  Theorem shift_nat_correct :
-    forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
+  Lemma two_power_pos_equiv p : two_power_pos p = 2 ^ Zpos p.
   Proof.
-    unfold shift_nat in |- *; simple induction n;
-      [ simpl in |- *; trivial with zarith
-	| intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0);
-	  [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity
-	    | auto with zarith ] ].
+   now apply Pos.iter_swap_gen.
   Qed.
 
-  Theorem two_power_nat_correct :
-    forall n:nat, two_power_nat n = Zpower_nat 2 n.
+  Lemma two_p_equiv x : two_p x = 2 ^ x.
   Proof.
-    intro n.
-    unfold two_power_nat in |- *.
-    rewrite (shift_nat_correct n).
-    omega.
+   destruct x; trivial. apply two_power_pos_equiv.
   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.
+  (** Properties of these old versions of powers of two *)
+
+  Lemma two_power_nat_S n : two_power_nat (S n) = 2 * two_power_nat n.
+  Proof. reflexivity. Qed.
+
+  Lemma shift_nat_plus n m x :
+    shift_nat (n + m) x = shift_nat n (shift_nat m x).
   Proof.
-    unfold shift_pos in |- *.
-    unfold shift_nat in |- *.
-    intros; apply iter_nat_of_P.
+   apply iter_nat_plus.
   Qed.
 
-  Lemma two_power_pos_nat :
-    forall p:positive, two_power_pos p = two_power_nat (nat_of_P p).
+  Theorem shift_nat_correct n x :
+    Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
   Proof.
-    intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *.
-    apply f_equal with (f := Zpos).
-    apply shift_pos_nat.
+   induction n.
+   - trivial.
+   - now rewrite Zpower_nat_succ_r, <- Z.mul_assoc, <- IHn.
   Qed.
 
-  (** Then we deduce that [two_power_pos] is also correct *)
+  Theorem two_power_nat_correct n : two_power_nat n = Zpower_nat 2 n.
+  Proof.
+   now rewrite two_power_nat_equiv, Zpower_nat_Z.
+  Qed.
 
-  Theorem shift_pos_correct :
-    forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
+  Lemma shift_pos_nat p x : shift_pos p x = shift_nat (Pos.to_nat p) x.
   Proof.
-    intros.
-    rewrite (shift_pos_nat p x).
-    rewrite (Zpower_pos_nat 2 p).
-    apply shift_nat_correct.
+   apply Pos2Nat.inj_iter.
   Qed.
 
-  Theorem two_power_pos_correct :
-    forall x:positive, two_power_pos x = Zpower_pos 2 x.
+  Lemma two_power_pos_nat p : two_power_pos p = two_power_nat (Pos.to_nat p).
   Proof.
-    intro.
-    rewrite two_power_pos_nat.
-    rewrite Zpower_pos_nat.
-    apply two_power_nat_correct.
+   unfold two_power_pos. now rewrite shift_pos_nat.
   Qed.
 
-  (** Some consequences *)
+  Theorem shift_pos_correct p x :
+    Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
+  Proof.
+   now rewrite shift_pos_nat, Zpower_pos_nat, shift_nat_correct.
+  Qed.
 
-  Theorem two_power_pos_is_exp :
-    forall x y:positive,
-      two_power_pos (x + y) = two_power_pos x * two_power_pos y.
+  Theorem two_power_pos_correct x : two_power_pos x = Z.pow_pos 2 x.
   Proof.
-    intros.
-    rewrite (two_power_pos_correct (x + y)).
-    rewrite (two_power_pos_correct x).
-    rewrite (two_power_pos_correct y).
-    apply Zpower_pos_is_exp.
+   apply two_power_pos_equiv.
   Qed.
 
-  (** 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. *)
+  Theorem two_power_pos_is_exp x y :
+   two_power_pos (x + y) = two_power_pos x * two_power_pos y.
+  Proof.
+    rewrite 3 two_power_pos_equiv. now apply (Z.pow_add_r 2 (Zpos x) (Zpos y)).
+  Qed.
 
-  Definition two_p (x:Z) :=
-    match x with
-      | Z0 => 1
-      | Zpos y => two_power_pos y
-      | Zneg y => 0
-    end.
+  Lemma two_p_correct x : two_p x = 2^x.
+  Proof (two_p_equiv x).
 
-  Theorem two_p_is_exp :
-    forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
+  Theorem two_p_is_exp x y :
+    0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
   Proof.
-    simple induction x;
-      [ simple induction y; simpl in |- *; auto with zarith
-	| simple induction y;
-	  [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1);
-	    rewrite (Zmult_1_l (two_power_pos p)); auto with zarith
-	    | unfold Zplus in |- *; unfold two_p in |- *; intros;
-	      apply two_power_pos_is_exp
-	    | intros; unfold Zle in H0; unfold Zcompare in H0;
-	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ]
-	| simple induction y;
-	  [ simpl in |- *; auto with zarith
-	    | intros; unfold Zle in H; unfold Zcompare in H;
-	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith
-	    | intros; unfold Zle in H; unfold Zcompare in H;
-	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ].
+    rewrite !two_p_equiv. apply Z.pow_add_r.
   Qed.
 
-  Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0.
+  Lemma two_p_gt_ZERO x : 0 <= x -> two_p x > 0.
   Proof.
-    simple induction x; intros;
-      [ simpl in |- *; omega
-	| simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0
-	| absurd (0 <= Zneg p);
-	  [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *;
-	    do 2 unfold not in |- *; auto with zarith
-	    | assumption ] ].
+   Z.swap_greater. rewrite two_p_equiv. now apply Z.pow_pos_nonneg.
   Qed.
 
-  Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
+  Lemma two_p_S x : 0 <= x -> two_p (Z.succ x) = 2 * two_p x.
   Proof.
-    intros; unfold Zsucc in |- *.
-    rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
-    apply Zmult_comm.
+   rewrite !two_p_equiv. now apply Z.pow_succ_r.
   Qed.
 
-  Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x.
+  Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x.
   Proof.
-    intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x);
-      [ simpl in |- *; unfold Zlt in |- *; auto with zarith
-	| intros; elim (Zle_lt_or_eq 0 x0 H0);
-	  [ intros;
-	    replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0)));
-	      [ rewrite (two_p_S (Zpred x0));
-		[ rewrite (two_p_S x0); [ omega | assumption ]
-		  | apply Zorder.Zlt_0_le_0_pred; assumption ]
-		| rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0);
-		  trivial with zarith ]
-	    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
-	      auto with zarith ]
-	| assumption ].
+   rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto with zarith.
   Qed.
 
-  Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
-    intros; omega. Qed.
-
-  End Powers_of_2.
+End Powers_of_2.
 
 Hint Resolve two_p_gt_ZERO: zarith.
 Hint Immediate two_p_pred two_p_S: zarith.
@@ -261,100 +230,88 @@ Section power_div_with_rest.
 
   (** * Division by a power of two. *)
 
-  (** To [n:Z] and [p:positive], [q],[r] are associated such that
-      [n = 2^p.q + r] and [0 <= r < 2^p] *)
+  (** To [x:Z] and [p:positive], [q],[r] are associated such that
+      [x = 2^p.q + r] and [0 <= r < 2^p] *)
 
-  (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
+  (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<=r<d /\ 0<=r'<d'] *)
   Definition Zdiv_rest_aux (qrd:Z * Z * Z) :=
-    let (qr, d) := qrd in
-      let (q, r) := qr in
-	(match q with
-	   | Z0 => (0, r)
-	   | Zpos xH => (0, d + r)
-	   | Zpos (xI n) => (Zpos n, d + r)
-	   | Zpos (xO n) => (Zpos n, r)
-	   | Zneg xH => (-1, d + r)
-	   | Zneg (xI n) => (Zneg n - 1, d + r)
-	   | Zneg (xO n) => (Zneg n, r)
-	 end, 2 * d).
+    let '(q,r,d) := qrd in
+      (match q with
+	 | Z0 => (0, r)
+	 | Zpos xH => (0, d + r)
+	 | Zpos (xI n) => (Zpos n, d + r)
+	 | Zpos (xO n) => (Zpos n, r)
+	 | Zneg xH => (-1, d + r)
+	 | Zneg (xI n) => (Zneg n - 1, d + r)
+	 | Zneg (xO n) => (Zneg n, r)
+       end, 2 * d).
 
   Definition Zdiv_rest (x:Z) (p:positive) :=
-    let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr.
+    let (qr, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in qr.
 
-  Lemma Zdiv_rest_correct1 :
-    forall (x:Z) (p:positive),
-      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
+  Lemma Zdiv_rest_correct1 (x:Z) (p:positive) :
+    let (_, d) := Pos.iter 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);
-	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));
-		destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
-		  assumption ].
+   rewrite Pos2Nat.inj_iter, two_power_pos_nat.
+   induction (Pos.to_nat p); simpl; trivial.
+   destruct (nat_iter n Zdiv_rest_aux (x,0,1)) as ((q,r),d).
+   unfold Zdiv_rest_aux. rewrite two_power_nat_S; now f_equal.
   Qed.
 
-  Lemma Zdiv_rest_correct2 :
-    forall (x:Z) (p:positive),
-      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in
-	let (q, r) := qr in x = q * d + r /\ 0 <= r < d.
+  Lemma Zdiv_rest_correct2 (x:Z) (p:positive) :
+    let '(q,r,d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in
+    x = q * d + r /\ 0 <= r < d.
   Proof.
-    intros;
-      apply iter_pos_invariant with
-	(f := Zdiv_rest_aux)
-	(Inv := fun qrd:Z * Z * Z =>
-          let (qr, d) := qrd in
-            let (q, r) := qr in x = q * d + r /\ 0 <= r < d);
-	[ intro x0; elim x0; intro y0; elim y0; intros q r d;
-	  unfold Zdiv_rest_aux in |- *; elim q;
-	    [ omega
-	      | destruct p0;
-		[ rewrite BinInt.Zpos_xI; intro; elim H; intros; split;
-		  [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l;
-		    rewrite Zmult_1_l; rewrite Zmult_assoc;
-		      rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal
-		    | omega ]
-		  | rewrite BinInt.Zpos_xO; intro; elim H; intros; split;
-		    [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2);
-		      apply refl_equal
-		      | omega ]
-		  | omega ]
-	      | destruct p0;
-		[ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros;
-		  split;
-		    [ rewrite H0; rewrite Zplus_assoc;
-		      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);
-			      omega
-		      | omega ]
-		  | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
-		    split;
-		      [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2);
-			apply refl_equal
-			| omega ]
-		  | omega ] ]
-	  | omega ].
+   apply Pos.iter_invariant; [|omega].
+   intros ((q,r),d) (H,H'). unfold Zdiv_rest_aux.
+   destruct q as [ |[q|q| ]|[q|q| ]]; try omega.
+   - rewrite Z.pos_xI, Z.mul_add_distr_r in H.
+     rewrite Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Z.pos_xO in H.
+     rewrite Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Z.neg_xI, Z.mul_sub_distr_r in H.
+     rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Z.neg_xO in H.
+     rewrite Z.mul_shuffle3, Z.mul_assoc. omega.
   Qed.
 
+  (** Old-style rich specification by proof of existence *)
+
   Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set :=
     Zdiv_rest_proof :
     forall q r:Z,
       x = q * two_power_pos p + r ->
       0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p.
 
-  Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p.
+  Lemma Zdiv_rest_correct (x:Z) (p:positive) : Zdiv_rest_proofs x p.
   Proof.
-    intros x p.
     generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
-    elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)).
-    simple induction a.
-    intros.
-    elim H; intros H1 H2; clear H.
-    rewrite H0 in H1; rewrite H0 in H2; elim H2; intros;
-      apply Zdiv_rest_proof with (q := a0) (r := b); assumption.
+    destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d).
+    intros (H1,(H2,H3)) ->. now exists q r.
+  Qed.
+
+  (** Direct correctness of [Zdiv_rest] *)
+
+  Lemma Zdiv_rest_ok x p :
+    let (q,r) := Zdiv_rest x p in
+    x = q * 2^(Zpos p) + r /\ 0 <= r < 2^(Zpos p).
+  Proof.
+   unfold Zdiv_rest.
+   generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
+   destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d).
+   intros H ->. now rewrite two_power_pos_equiv in H.
+  Qed.
+
+  (** Equivalence with [Z.shiftr] *)
+
+  Lemma Zdiv_rest_shiftr x p :
+   fst (Zdiv_rest x p) = Z.shiftr x (Zpos p).
+  Proof.
+   generalize (Zdiv_rest_ok x p). destruct (Zdiv_rest x p) as (q,r).
+   intros (H,H'). simpl.
+   rewrite Z.shiftr_div_pow2 by easy.
+   apply Z.div_unique_pos with r; trivial. now rewrite Z.mul_comm.
   Qed.
 
 End power_div_with_rest.
diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v
new file mode 100644
index 00000000..9a95669f
--- /dev/null
+++ b/theories/ZArith/Zquot.v
@@ -0,0 +1,536 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Nnat ZArith_base ROmega ZArithRing Zdiv Morphisms.
+
+Local Open Scope Z_scope.
+
+(** This file provides results about the Round-Toward-Zero Euclidean
+  division [Zquotrem], whose projections are [Zquot] and [Zrem].
+  Definition of this division can be found in file [BinIntDef].
+
+  This division and the one defined in Zdiv agree only on positive
+  numbers. Otherwise, Zdiv performs Round-Toward-Bottom (a.k.a Floor).
+
+  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.
+*)
+
+(** * Relation between division on N and on Z. *)
+
+Lemma Ndiv_Zquot : forall a b:N,
+  Z_of_N (a/b) = (Z_of_N a ÷ Z_of_N b).
+Proof.
+  intros.
+  destruct a; destruct b; simpl; auto.
+  unfold N.div, Z.quot; simpl. destruct N.pos_div_eucl; auto.
+Qed.
+
+Lemma Nmod_Zrem : forall a b:N,
+  Z.of_N (a mod b) = Z.rem (Z.of_N a) (Z.of_N b).
+Proof.
+  intros.
+  destruct a; destruct b; simpl; auto.
+  unfold N.modulo, Z.rem; simpl; destruct N.pos_div_eucl; auto.
+Qed.
+
+(** * Characterization of this euclidean division. *)
+
+(** 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].
+*)
+
+Notation Z_quot_rem_eq := Z.quot_rem' (only parsing).
+
+(** Then, the inequalities constraining the remainder:
+    The remainder is bounded by the divisor, in term of absolute values *)
+
+Theorem Zrem_lt : forall a b:Z, b<>0 ->
+  Z.abs (Z.rem a b) < Z.abs b.
+Proof.
+  apply Z.rem_bound_abs.
+Qed.
+
+(** 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 Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a.
+Proof.
+  destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith;
+  unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl;
+  simpl; destruct n0; simpl; auto with zarith.
+Qed.
+
+(** This can also be said in a simplier way: *)
+
+Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a.
+Proof.
+  rewrite <-Z.sgn_nonneg, Z.sgn_mul; apply Zrem_sgn.
+Qed.
+
+(** Reformulation of [Zquot_lt] and [Zrem_sgn] in 2
+  then 4 particular cases. *)
+
+Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b.
+Proof.
+  intros.
+  assert (0 <= Z.rem a b).
+   generalize (Zrem_sgn a b).
+   destruct (Zle_lt_or_eq 0 a H).
+   rewrite <- Zsgn_pos in H1; rewrite H1. romega with *.
+   subst a; simpl; auto.
+  generalize (Zrem_lt a b H0); romega with *.
+Qed.
+
+Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0.
+Proof.
+  intros.
+  assert (Z.rem a b <= 0).
+   generalize (Zrem_sgn a b).
+   destruct (Zle_lt_or_eq a 0 H).
+   rewrite <- Zsgn_neg in H1; rewrite H1; romega with *.
+   subst a; simpl; auto.
+  generalize (Zrem_lt a b H0); romega with *.
+Qed.
+
+Theorem Zrem_lt_pos_pos a b : 0<=a -> 0<b -> 0 <= Z.rem a b < b.
+Proof.
+  intros; generalize (Zrem_lt_pos a b); romega with *.
+Qed.
+
+Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b.
+Proof.
+  intros; generalize (Zrem_lt_pos a b); romega with *.
+Qed.
+
+Theorem Zrem_lt_neg_pos a b : a<=0 -> 0<b -> -b < Z.rem a b <= 0.
+Proof.
+  intros; generalize (Zrem_lt_neg a b); romega with *.
+Qed.
+
+Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0.
+Proof.
+  intros; generalize (Zrem_lt_neg a b); romega with *.
+Qed.
+
+(** * Division and Opposite *)
+
+(* The precise equalities that are invalid with "historic" Zdiv. *)
+
+Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b).
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b).
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b).
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b.
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b.
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b).
+Proof.
+ destruct a; destruct b; simpl; auto;
+  unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith.
+Qed.
+
+(** * Unicity results *)
+
+Definition Remainder a b r :=
+  (0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0).
+
+Definition Remainder_alt a b r :=
+  Z.abs r < Z.abs b /\ 0 <= r * a.
+
+Lemma Remainder_equiv : forall a b r,
+ Remainder a b r <-> Remainder_alt a b r.
+Proof.
+  unfold Remainder, Remainder_alt; intuition.
+  romega with *.
+  romega with *.
+  rewrite <-(Zmult_opp_opp).
+  apply Zmult_le_0_compat; romega.
+  assert (0 <= Z.sgn r * Z.sgn a) by (rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto).
+  destruct r; simpl Z.sgn in *; romega with *.
+Qed.
+
+Theorem Zquot_mod_unique_full:
+ forall a b q r, Remainder a b r ->
+   a = b*q + r -> q = a÷b /\ r = Z.rem a b.
+Proof.
+  destruct 1 as [(H,H0)|(H,H0)]; intros.
+  apply Zdiv_mod_unique with b; auto.
+  apply Zrem_lt_pos; auto.
+  romega with *.
+  rewrite <- H1; apply Z_quot_rem_eq.
+
+  rewrite <- (Zopp_involutive a).
+  rewrite Zquot_opp_l, Zrem_opp_l.
+  generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)).
+  generalize (Zrem_lt_pos (-a) b).
+  rewrite <-Z_quot_rem_eq, <-Zopp_mult_distr_r, <-Zopp_plus_distr, <-H1.
+  romega with *.
+Qed.
+
+Theorem Zquot_unique_full:
+ forall a b q r, Remainder a b r ->
+  a = b*q + r -> q = a÷b.
+Proof.
+ intros; destruct (Zquot_mod_unique_full a b q r); auto.
+Qed.
+
+Theorem Zquot_unique:
+ forall a b q r, 0 <= a -> 0 <= r < b ->
+   a = b*q + r -> q = a÷b.
+Proof. exact Z.quot_unique. Qed.
+
+Theorem Zrem_unique_full:
+ forall a b q r, Remainder a b r ->
+  a = b*q + r -> r = Z.rem a b.
+Proof.
+ intros; destruct (Zquot_mod_unique_full a b q r); auto.
+Qed.
+
+Theorem Zrem_unique:
+ forall a b q r, 0 <= a -> 0 <= r < b ->
+   a = b*q + r -> r = Z.rem a b.
+Proof. exact Z.rem_unique. Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma Zrem_0_l: forall a, Z.rem 0 a = 0.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zrem_0_r: forall a, Z.rem a 0 = a.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zquot_0_l: forall a, 0÷a = 0.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zquot_0_r: forall a, a÷0 = 0.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zrem_1_r: forall a, Z.rem a 1 = 0.
+Proof. exact Z.rem_1_r. Qed.
+
+Lemma Zquot_1_r: forall a, a÷1 = a.
+Proof. exact Z.quot_1_r. Qed.
+
+Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Zquot_1_r Zrem_1_r
+ : zarith.
+
+Lemma Zquot_1_l: forall a, 1 < a -> 1÷a = 0.
+Proof. exact Z.quot_1_l. Qed.
+
+Lemma Zrem_1_l: forall a, 1 < a -> Z.rem 1 a = 1.
+Proof. exact Z.rem_1_l. Qed.
+
+Lemma Z_quot_same : forall a:Z, a<>0 -> a÷a = 1.
+Proof. exact Z.quot_same. Qed.
+
+Ltac zero_or_not a :=
+  destruct (Z.eq_dec a 0);
+  [subst; rewrite ?Zrem_0_l, ?Zquot_0_l, ?Zrem_0_r, ?Zquot_0_r;
+   auto with zarith|].
+
+Lemma Z_rem_same : forall a, Z.rem a a = 0.
+Proof. intros. zero_or_not a. apply Z.rem_same; auto. Qed.
+
+Lemma Z_rem_mult : forall a b, Z.rem (a*b) b = 0.
+Proof. intros. zero_or_not b. apply Z.rem_mul; auto. Qed.
+
+Lemma Z_quot_mult : forall a b:Z, b <> 0 -> (a*b)÷b = a.
+Proof. exact Z.quot_mul. Qed.
+
+(** * Order results about Zrem and Zquot *)
+
+(* Division of positive numbers is positive. *)
+
+Lemma Z_quot_pos: forall a b, 0 <= a -> 0 <= b -> 0 <= a÷b.
+Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed.
+
+(** As soon as the divisor is greater or equal than 2,
+    the division is strictly decreasing. *)
+
+Lemma Z_quot_lt : forall a b:Z, 0 < a -> 2 <= b -> a÷b < a.
+Proof. intros. apply Z.quot_lt; auto with zarith. Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem Zquot_small: forall a b, 0 <= a < b -> a÷b = 0.
+Proof. exact Z.quot_small. Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem Zrem_small: forall a n, 0 <= a < n -> Z.rem a n = a.
+Proof. exact Z.rem_small. Qed.
+
+(** [Zge] is compatible with a positive division. *)
+
+Lemma Z_quot_monotone : forall a b c, 0<=c -> a<=b -> a÷c <= b÷c.
+Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed.
+
+(** With our choice of division, rounding of (a÷b) is always done toward zero: *)
+
+Lemma Z_mult_quot_le : forall a b:Z, 0 <= a -> 0 <= b*(a÷b) <= a.
+Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed.
+
+Lemma Z_mult_quot_ge : forall a b:Z, a <= 0 -> a <= b*(a÷b) <= 0.
+Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed.
+
+(** The previous inequalities between [b*(a÷b)] and [a] are exact
+    iff the modulo is zero. *)
+
+Lemma Z_quot_exact_full : forall a b:Z, a = b*(a÷b) <-> Z.rem a b = 0.
+Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed.
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem Zrem_le: forall a b, 0 <= a -> 0 <= b -> Z.rem a b <= a.
+Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed.
+
+(** Some additionnal inequalities about Zdiv. *)
+
+Theorem Zquot_le_upper_bound:
+  forall a b q, 0 < b -> a <= q*b -> a÷b <= q.
+Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_upper_bound. Qed.
+
+Theorem Zquot_lt_upper_bound:
+  forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q.
+Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_lt_upper_bound. Qed.
+
+Theorem Zquot_le_lower_bound:
+  forall a b q, 0 < b -> q*b <= a -> q <= a÷b.
+Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_lower_bound. Qed.
+
+Theorem Zquot_sgn: forall a b,
+  0 <= Z.sgn (a÷b) * Z.sgn a * Z.sgn b.
+Proof.
+  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
+  unfold Z.quot; simpl; destruct N.pos_div_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.
+    For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *)
+
+Lemma Z_rem_plus : forall a b c:Z,
+ 0 <= (a+b*c) * a ->
+ Z.rem (a + b * c) c = Z.rem a c.
+Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed.
+
+Lemma Z_quot_plus : forall a b c:Z,
+ 0 <= (a+b*c) * a -> c<>0 ->
+ (a + b * c) ÷ c = a ÷ c + b.
+Proof. intros. apply Z.quot_add; auto with zarith. Qed.
+
+Theorem Z_quot_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. apply Z.quot_add_l; auto with zarith. Qed.
+
+(** Cancellations. *)
+
+Lemma Zquot_mult_cancel_r : forall a b c:Z,
+ c<>0 -> (a*c)÷(b*c) = a÷b.
+Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed.
+
+Lemma Zquot_mult_cancel_l : forall a b c:Z,
+ c<>0 -> (c*a)÷(c*b) = a÷b.
+Proof.
+ intros. rewrite (Zmult_comm c b). zero_or_not b.
+ rewrite (Zmult_comm b c). apply Z.quot_mul_cancel_l; auto.
+Qed.
+
+Lemma Zmult_rem_distr_l: forall a b c,
+  Z.rem (c*a) (c*b) = c * (Z.rem a b).
+Proof.
+ intros. zero_or_not c. rewrite (Zmult_comm c b). zero_or_not b.
+ rewrite (Zmult_comm b c). apply Z.mul_rem_distr_l; auto.
+Qed.
+
+Lemma Zmult_rem_distr_r: forall a b c,
+  Z.rem (a*c) (b*c) = (Z.rem a b) * c.
+Proof.
+ intros. zero_or_not b. rewrite (Zmult_comm b c). zero_or_not c.
+ rewrite (Zmult_comm c b). apply Z.mul_rem_distr_r; auto.
+Qed.
+
+(** Operations modulo. *)
+
+Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n.
+Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed.
+
+Theorem Zmult_rem: forall a b n,
+ Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n.
+Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed.
+
+(** addition and modulo
+
+  Generally speaking, unlike with Zdiv, we don't have
+       (a+b) rem n = (a rem n + b rem n) rem n
+  for any a and b.
+  For instance, take (8 + (-10)) rem 3 = -2 whereas
+  (8 rem 3 + (-10 rem 3)) rem 3 = 1. *)
+
+Theorem Zplus_rem: forall a b n,
+ 0 <= a * b ->
+ Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n.
+Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed.
+
+Lemma Zplus_rem_idemp_l: forall a b n,
+ 0 <= a * b ->
+ Z.rem (Z.rem a n + b) n = Z.rem (a + b) n.
+Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed.
+
+Lemma Zplus_rem_idemp_r: forall a b n,
+ 0 <= a*b ->
+ Z.rem (b + Z.rem a n) n = Z.rem (b + a) n.
+Proof.
+ intros. zero_or_not n. apply Z.add_rem_idemp_r; auto.
+ rewrite Zmult_comm; auto.
+Qed.
+
+Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n.
+Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed.
+
+Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n.
+Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed.
+
+(** Unlike with Zdiv, the following result is true without restrictions. *)
+
+Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c).
+Proof.
+ intros. zero_or_not b. rewrite Zmult_comm. zero_or_not c.
+ rewrite Zmult_comm. apply Z.quot_quot; auto.
+Qed.
+
+(** A last inequality: *)
+
+Theorem Zquot_mult_le:
+ forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
+Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed.
+
+(** Z.rem is related to divisibility (see more in Znumtheory) *)
+
+Lemma Zrem_divides : forall a b,
+ Z.rem a b = 0 <-> exists c, a = b*c.
+Proof.
+ intros. zero_or_not b. firstorder.
+ rewrite Z.rem_divide; trivial.
+ split; intros (c,Hc); exists c; subst; auto with zarith.
+Qed.
+
+(** Particular case : dividing by 2 is related with parity *)
+
+Lemma Zquot2_odd_remainder : forall a,
+ Remainder a 2 (if Z.odd a then Z.sgn a else 0).
+Proof.
+ intros [ |p|p]. simpl.
+ left. simpl. auto with zarith.
+ left. destruct p; simpl; auto with zarith.
+ right. destruct p; simpl; split; now auto with zarith.
+Qed.
+
+Notation Zquot2_quot := Zquot2_quot (only parsing).
+
+Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0.
+Proof.
+ intros. symmetry.
+ apply Zrem_unique_full with (Zquot2 a).
+ apply Zquot2_odd_remainder.
+ apply Zquot2_odd_eqn.
+Qed.
+
+Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a.
+Proof.
+ intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Zeven_bool.
+Qed.
+
+Lemma Zeven_rem : forall a, Z.even a = Zeq_bool (Z.rem a 2) 0.
+Proof.
+ intros a. rewrite Zrem_even.
+ destruct a as [ |p|p]; trivial; now destruct p.
+Qed.
+
+Lemma Zodd_rem : forall a, Z.odd a = negb (Zeq_bool (Z.rem a 2) 0).
+Proof.
+ intros a. rewrite Zrem_odd.
+ destruct a as [ |p|p]; trivial; now destruct p.
+Qed.
+
+(** * Interaction with "historic" Zdiv *)
+
+(** They agree at least on positive numbers: *)
+
+Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b ->
+  a÷b = a/b /\ Z.rem a b = a mod b.
+Proof.
+  intros.
+  apply Zdiv_mod_unique with b.
+  apply Zrem_lt_pos; auto with zarith.
+  rewrite Zabs_eq; auto with *; apply Z_mod_lt; auto with *.
+  rewrite <- Z_div_mod_eq; auto with *.
+  symmetry; apply Z_quot_rem_eq; auto with *.
+Qed.
+
+Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
+  a÷b = a/b.
+Proof.
+ intros a b Ha Hb.
+ destruct (Zle_lt_or_eq _ _ Hb).
+ generalize (Zquotrem_Zdiv_eucl_pos a b Ha H); intuition.
+ subst; rewrite Zquot_0_r, Zdiv_0_r; reflexivity.
+Qed.
+
+Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b ->
+  Z.rem a b = a mod b.
+Proof.
+ intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb);
+ intuition.
+Qed.
+
+(** Modulos are null at the same places *)
+
+Theorem Zrem_Zmod_zero : forall a b, b<>0 ->
+ (Z.rem a b = 0 <-> a mod b = 0).
+Proof.
+ intros.
+ rewrite Zrem_divides, Zmod_divides; intuition.
+Qed.
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt_compat.v
index 1a67bbb2..4584c3f8 100644
--- a/theories/ZArith/Zsqrt.v
+++ b/theories/ZArith/Zsqrt_compat.v
@@ -1,18 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zsqrt.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import ZArithRing.
 Require Import Omega.
 Require Export ZArith_base.
 Open Local Scope Z_scope.
 
+(**  THIS FILE IS DEPRECATED
+
+    Instead of the various [Zsqrt] defined here, please use rather
+    [Z.sqrt] (or [Z.sqrtrem]). The latter are pure functions without
+    proof parts, and more results are available about them.
+    Some equivalence proofs between the old and the new versions
+    can be found below. Importing ZArith will provides by default
+    the new versions.
+
+*)
+
 (**********************************************************************)
 (** Definition and properties of square root on Z *)
 
@@ -213,3 +222,12 @@ Proof.
 Qed.
 
 
+(** Equivalence between Zsqrt_plain and [Z.sqrt] *)
+
+Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Z.sqrt n.
+Proof.
+ intros. destruct (Z_le_gt_dec 0 n).
+ symmetry. apply Z.sqrt_unique; trivial.
+ now apply Zsqrt_interval.
+ now destruct n.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index 53f167e8..30802f82 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zwf.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 Require Import ZArith_base.
 Require Export Wf_nat.
 Require Import Omega.
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index ade35bef..742f4bde 100644
--- a/theories/ZArith/auxiliary.v
+++ b/theories/ZArith/auxiliary.v
@@ -1,14 +1,12 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auxiliary.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
 Require Export Arith_base.
@@ -18,96 +16,79 @@ Require Import Decidable.
 Require Import Peano_dec.
 Require Export Compare_dec.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (***************************************************************)
 (** * Moving terms from one side to the other of an inequality *)
 
-Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0.
+Theorem Zne_left n m : 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;
-      rewrite Zplus_comm; trivial with arith.
+ unfold Zne. now rewrite <- Z.sub_move_0_r.
 Qed.
 
-Theorem Zegal_left : forall n m:Z, n = m -> n + - m = 0.
+Theorem Zegal_left n m : n = m -> n + - m = 0.
 Proof.
-  intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute;
-    rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption.
+ apply Z.sub_move_0_r.
 Qed.
 
-Theorem Zle_left : forall n m:Z, n <= m -> 0 <= m + - n.
+Theorem Zle_left n m : n <= m -> 0 <= m + - n.
 Proof.
-  intros x y H; replace 0 with (x + - x).
-  apply Zplus_le_compat_r; trivial.
-  apply Zplus_opp_r.
+ apply Z.le_0_sub.
 Qed.
 
-Theorem Zle_left_rev : forall n m:Z, 0 <= m + - n -> n <= m.
+Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m.
 Proof.
-  intros x y H; apply Zplus_le_reg_r with (- x).
-  rewrite Zplus_opp_r; trivial.
+ apply Z.le_0_sub.
 Qed.
 
-Theorem Zlt_left_rev : forall n m:Z, 0 < m + - n -> n < m.
+Theorem Zlt_left_rev n m : 0 < m + - n -> n < m.
 Proof.
-  intros x y H; apply Zplus_lt_reg_r with (- x).
-  rewrite Zplus_opp_r; trivial.
+ apply Z.lt_0_sub.
 Qed.
 
-Theorem Zlt_left : forall n m:Z, n < m -> 0 <= m + -1 + - n.
+Theorem Zlt_left_lt n m : n < m -> 0 < m + - n.
 Proof.
-  intros x y H; apply Zle_left; apply Zsucc_le_reg;
-    change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred;
-      apply Zlt_le_succ; assumption.
+ apply Z.lt_0_sub.
 Qed.
 
-Theorem Zlt_left_lt : forall n m:Z, n < m -> 0 < m + - n.
+Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n.
 Proof.
-  intros x y H; replace 0 with (x + - x).
-  apply Zplus_lt_compat_r; trivial.
-  apply Zplus_opp_r.
+ intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0).
+ now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub.
 Qed.
 
-Theorem Zge_left : forall n m:Z, n >= m -> 0 <= n + - m.
+Theorem Zge_left n m : n >= m -> 0 <= n + - m.
 Proof.
-  intros x y H; apply Zle_left; apply Zge_le; assumption.
+ Z.swap_greater. apply Z.le_0_sub.
 Qed.
 
-Theorem Zgt_left : forall n m:Z, n > m -> 0 <= n + -1 + - m.
+Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m.
 Proof.
-  intros x y H; apply Zlt_left; apply Zgt_lt; assumption.
+ Z.swap_greater. apply Zlt_left.
 Qed.
 
-Theorem Zgt_left_gt : forall n m:Z, n > m -> n + - m > 0.
+Theorem Zgt_left_gt n m : n > m -> n + - m > 0.
 Proof.
-  intros x y H; replace 0 with (y + - y).
-  apply Zplus_gt_compat_r; trivial.
-  apply Zplus_opp_r.
+ Z.swap_greater. apply Z.lt_0_sub.
 Qed.
 
-Theorem Zgt_left_rev : forall n m:Z, n + - m > 0 -> n > m.
+Theorem Zgt_left_rev n m : n + - m > 0 -> n > m.
 Proof.
-  intros x y H; apply Zplus_gt_reg_r with (- y).
-  rewrite Zplus_opp_r; trivial.
+ Z.swap_greater. apply Z.lt_0_sub.
 Qed.
 
-Theorem Zle_mult_approx :
-  forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
+Theorem Zle_mult_approx n m p :
+  n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
 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;
-	  assumption ].
+ Z.swap_greater. intros. Z.order_pos.
 Qed.
 
-Theorem Zmult_le_approx :
-  forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
+Theorem Zmult_le_approx n m p :
+  n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
 Proof.
-  intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x;
-    [ assumption
-      | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse;
-	apply Zplus_lt_compat_l; apply Zgt_lt; assumption ].
+ Z.swap_greater. intros. apply Z.lt_succ_r.
+ apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl.
+ apply Z.le_lt_trans with (m*n+p); trivial.
+ now apply Z.add_lt_mono_l.
 Qed.
 
diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget
index 3efa7055..178111cd 100644
--- a/theories/ZArith/vo.itarget
+++ b/theories/ZArith/vo.itarget
@@ -1,4 +1,5 @@
 auxiliary.vo
+BinIntDef.vo
 BinInt.vo
 Int.vo
 Wf_Z.vo
@@ -13,6 +14,7 @@ Zcomplements.vo
 Zdiv.vo
 Zeven.vo
 Zgcd_alt.vo
+Zpow_alt.vo
 Zhints.vo
 Zlogarithm.vo
 Zmax.vo
@@ -21,12 +23,11 @@ Zmin.vo
 Zmisc.vo
 Znat.vo
 Znumtheory.vo
-ZOdiv_def.vo
-ZOdiv.vo
+Zquot.vo
 Zorder.vo
 Zpow_def.vo
 Zpower.vo
 Zpow_facts.vo
-Zsqrt.vo
+Zsqrt_compat.vo
 Zwf.vo
-ZOrderedType.vo
+Zeuclid.vo
diff --git a/theories/theories.itarget b/theories/theories.itarget
index afc3554b..3a87d8cf 100644
--- a/theories/theories.itarget
+++ b/theories/theories.itarget
@@ -6,7 +6,9 @@ MSets/vo.otarget
 Structures/vo.otarget
 Init/vo.otarget
 Lists/vo.otarget
+Vectors/vo.otarget
 Logic/vo.otarget
+PArith/vo.otarget
 NArith/vo.otarget
 Numbers/vo.otarget
 Program/vo.otarget
diff --git a/tools/beautify-archive b/tools/beautify-archive
index ccfeb3db..ccfeb3db 100644..100755
--- a/tools/beautify-archive
+++ b/tools/beautify-archive
diff --git a/parsing/g_zsyntax.mli b/tools/compat5.ml
index 05c161c2..641d80d8 100644
--- a/parsing/g_zsyntax.mli
+++ b/tools/compat5.ml
@@ -1,11 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_zsyntax.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is meant for camlp5, for which there is nothing to
+   add to gain camlp5 compatibility :-).
 
-(* Nice syntax for integers. *)
+   See [compat5.mlp] for the [camlp4] counterpart
+*)
diff --git a/tools/compat5.mlp b/tools/compat5.mlp
new file mode 100644
index 00000000..e7e1aeef
--- /dev/null
+++ b/tools/compat5.mlp
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Adding a bit of camlp5 syntax to camlp4 for compatibility:
+    - GEXTEND ... becomes EXTEND ...
+*)
+
+open Camlp4.PreCast
+
+let rec my_token_filter = parser
+  | [< '(KEYWORD "GEXTEND", loc); s >] ->
+    [< '(KEYWORD "EXTEND", loc); my_token_filter s >]
+  | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >]
+  | [< >] -> [< >]
+
+let _ =
+  Token.Filter.define_filter (Gram.get_filter())
+    (fun prev strm -> prev (my_token_filter strm))
diff --git a/parsing/g_natsyntax.mli b/tools/compat5b.ml
index d3f12bed..f757a065 100644
--- a/parsing/g_natsyntax.mli
+++ b/tools/compat5b.ml
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_natsyntax.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is meant for camlp5, for which there is nothing to
+   add to gain camlp5 compatibility :-).
 
-(* Nice syntax for naturals. *)
-
-open Notation
-
-val nat_of_int : Bigint.bigint prim_token_interpreter
+   See [compat5b.mlp] for the [camlp4] counterpart
+*)
diff --git a/tools/compat5b.mlp b/tools/compat5b.mlp
new file mode 100644
index 00000000..cf8e5494
--- /dev/null
+++ b/tools/compat5b.mlp
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Adding a bit of camlp5 syntax to camlp4 for compatibility:
+    - EXTEND ... becomes EXTEND Gram ...
+*)
+
+open Camlp4.PreCast
+
+let rec my_token_filter = parser
+  | [< '(KEYWORD "EXTEND",_ as t); s >] ->
+    [< 't; '(UIDENT "Gram", Loc.ghost); my_token_filter s >]
+  | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >]
+  | [< >] -> [< >]
+
+let _ =
+  Token.Filter.define_filter (Gram.get_filter())
+    (fun prev strm -> prev (my_token_filter strm))
diff --git a/tools/coq-syntax.el b/tools/coq-syntax.el
index 5b88f6a5..8630fb3a 100644
--- a/tools/coq-syntax.el
+++ b/tools/coq-syntax.el
@@ -417,8 +417,10 @@
      ("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 Constructor" nil "Add Printing Constructor #." t "Add\\s-+Printing\\s-+Constructor")
      ("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 Printing Record" nil "Add Printing Record #." t "Add\\s-+Printing\\s-+Record")
      ("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")
@@ -497,6 +499,7 @@
      ("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 Printing Records" nil "Set Printing Records" t "Set\\s-+Printing\\s-+Records")
      ("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")
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
new file mode 100644
index 00000000..a685d6ea
--- /dev/null
+++ b/tools/coq_makefile.ml
@@ -0,0 +1,714 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* créer un Makefile pour un développement Coq automatiquement *)
+
+let output_channel = ref stdout
+let makefile_name = ref "Makefile"
+let make_name = ref ""
+
+let some_vfile = ref false
+let some_mlfile = ref false
+let some_mlifile = ref false
+let some_ml4file = ref false
+let some_mllibfile = ref false
+let some_mlpackfile = ref false
+
+let print x = output_string !output_channel x
+let printf x = Printf.fprintf !output_channel x
+
+let rec print_list sep = function
+  | [ x ] -> print x
+  | x :: l -> print x; print sep; print_list sep l
+  | [] -> ()
+
+let list_iter_i f =
+  let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1
+
+let section s =
+  let l = String.length s in
+  let sep = String.make (l+5) '#'
+  and sep2 = String.make (l+5) ' ' in
+  String.set sep (l+4) '\n';
+  String.set sep2 0 '#';
+  String.set sep2 (l+3) '#';
+  String.set sep2 (l+4) '\n';
+  print sep;
+  print sep2;
+  print "# "; print s; print " #\n";
+  print sep2;
+  print sep;
+  print "\n"
+
+let usage () =
+  output_string stderr "Usage summary:
+
+coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... [file.mllib]
+  ... [-custom command dependencies file] ... [-I dir] ... [-R physicalpath
+  logicalpath] ... [VARIABLE = value] ...  [-arg opt] ... [-opt|-byte]
+  [-no-install] [-f file] [-o file] [-h] [--help]
+
+[file.v]: Coq file to be compiled
+[file.ml[i4]?]: Objective Caml file to be compiled
+[file.mllib]: ocamlbuild file that describes a Objective Caml library
+[subdirectory] : subdirectory that should be \"made\" and has a
+  Makefile itself to do so.
+[-custom command dependencies file]: add target \"file\" with command
+  \"command\" and dependencies \"dependencies\"
+[-I dir]: look for Objective Caml dependencies in \"dir\"
+[-R physicalpath logicalpath]: look for Coq dependencies resursively
+  starting from \"physicalpath\". The logical path associated to the
+  physical path is \"logicalpath\".
+[VARIABLE = value]: Add the variable definition \"VARIABLE=value\"
+[-byte]: compile with byte-code version of coq
+[-opt]: compile with native-code version of coq
+[-arg opt]: send option \"opt\" to coqc
+[-install opt]: where opt is \"user\" to force install into user directory,
+  \"none\" to build a makefile with no install target or
+  \"global\" to force install in $COQLIB directory
+[-f file]: take the contents of file as arguments
+[-o file]: output should go in file file
+	Output file outside the current directory is forbidden.
+[-h]: print this usage summary
+[--help]: equivalent to [-h]\n";
+  exit 1
+
+let is_genrule r =
+    let genrule = Str.regexp("%") in
+      Str.string_match genrule r 0
+
+let string_prefix a b =
+  let rec aux i = try if a.[i] = b.[i] then aux (i+1) else i with |Invalid_argument _ -> i in
+    String.sub a 0 (aux 0)
+
+let is_prefix dir1 dir2 =
+  let l1 = String.length dir1 in
+  let l2 = String.length dir2 in
+    dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/')
+
+let physical_dir_of_logical_dir ldir =
+  let le = String.length ldir - 1 in
+  let pdir = if ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in
+  for i = 0 to le - 1 do
+    if pdir.[i] = '.' then pdir.[i] <- '/';
+  done;
+  pdir
+
+let standard opt =
+  print "byte:\n";
+  print "\t$(MAKE) all \"OPT:=-byte\"\n\n";
+  print "opt:\n";
+  if not opt then print "\t@echo \"WARNING: opt is disabled\"\n";
+  print "\t$(MAKE) all \"OPT:="; print (if opt then "-opt" else "-byte");
+  print "\"\n\n"
+
+let classify_files_by_root var files (inc_i,inc_r) =
+  if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) then
+    begin
+      let absdir_of_files = List.rev_map
+	(fun x -> Minilib.canonical_path_name (Filename.dirname x))
+	files in
+	(* files in scope of a -I option (assuming they are no overlapping) *)
+      let has_inc_i = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in
+	if has_inc_i then
+	  begin
+	    printf "%sINC=" var;
+	    List.iter (fun (pdir,absdir) ->
+			 if List.mem absdir absdir_of_files
+			 then printf
+			   "$(filter $(wildcard %s/*),$(%s)) "
+			   pdir var
+		      ) inc_i;
+	    printf "\n";
+	  end;
+      (* Files in the scope of a -R option (assuming they are disjoint) *)
+	list_iter_i (fun i (pdir,ldir,abspdir) ->
+		       if List.exists (is_prefix abspdir) absdir_of_files then
+			 printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n"
+			   var i pdir pdir var)
+	  inc_r;
+    end
+
+let install_include_by_root files_var files (inc_i,inc_r) =
+  try
+    (* All files caught by a -R . option (assuming it is the only one) *)
+    let ldir = match inc_r with
+      |[(".",t,_)] -> t
+      |l -> let out = List.assoc "." (List.map (fun (p,l,_) -> (p,l)) inc_r) in
+	 let () = prerr_string "Warning: install rule assumes that -R . _ is the only -R option" in
+	   out in
+    let pdir = physical_dir_of_logical_dir ldir in
+      printf "\tfor i in $(%s); do \\\n" files_var;
+      printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir;
+      printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir;
+      printf "\tdone\n"
+  with Not_found ->
+    let absdir_of_files = List.rev_map
+      (fun x -> Minilib.canonical_path_name (Filename.dirname x))
+      files in
+    let has_inc_i_files =
+      List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in
+    let install_inc_i d =
+      printf "\tinstall -d $(DSTROOT)$(COQLIBINSTALL)/%s; \\\n" d;
+      printf "\tfor i in $(%sINC); do \\\n" files_var;
+      printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" d;
+      printf "\tdone\n"
+    in
+      if inc_r = [] then
+	if has_inc_i_files then
+	  begin
+	    (* Files in the scope of a -I option *)
+	    install_inc_i "$(INSTALLDEFAULTROOT)";
+	  end else ()
+      else
+	(* Files in the scope of a -R option (assuming they are disjoint) *)
+	list_iter_i (fun i (pdir,ldir,abspdir) ->
+		       let has_inc_r_files = List.exists (is_prefix abspdir) absdir_of_files in
+		       let pdir' = physical_dir_of_logical_dir ldir in
+			 if has_inc_r_files then
+			   begin
+			     printf "\tcd %s; for i in $(%s%d); do \\\n" pdir files_var i;
+			     printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir';
+			     printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir';
+			     printf "\tdone\n";
+			   end;
+			 if has_inc_i_files then install_inc_i pdir'
+		    ) inc_r
+
+let install_doc some_vfiles some_mlifiles (_,inc_r) =
+  let install_one_kind kind dir =
+    printf "\tinstall -d $(DSTROOT)$(COQDOCINSTALL)/%s/%s\n" dir kind;
+    printf "\tfor i in %s/*; do \\\n" kind;
+    printf "\t install -m 0644 $$i $(DSTROOT)$(COQDOCINSTALL)/%s/$$i;\\\n" dir;
+    print "\tdone\n" in
+    print "install-doc:\n";
+    let () = match inc_r with
+      |[] ->
+	 if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)";
+	  if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)";
+      |(_,lp,_)::q ->
+	 let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in
+	   if (pr <> "") &&
+	     ((List.exists (fun(_,b,_) -> b = pr) inc_r) || pr.[String.length pr - 1] = '.')
+	   then begin
+	     let rt = physical_dir_of_logical_dir pr in
+	       if some_vfiles then install_one_kind "html" rt;
+	       if some_mlifiles then install_one_kind "mlihtml" rt;
+	   end else begin
+	     prerr_string "Warning: -R options don't have a correct common prefix,
+ install-doc will put anything in $INSTALLDEFAULTROOT";
+	   if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)";
+	   if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)";
+	   end in
+      print "\n"
+
+let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) inc = function
+  |Project_file.NoInstall -> ()
+  |is_install ->
+    let () = if is_install = Project_file.UnspecInstall then
+	print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" in
+  let not_empty = function |[] -> false |_::_ -> true in
+  let cmofiles = mlpackfiles@mlfiles@ml4files in
+  let cmifiles = mlifiles@cmofiles in
+  let cmxsfiles = cmofiles@mllibfiles in
+    if (not_empty cmxsfiles) then begin
+      print "install-natdynlink:\n";
+      install_include_by_root "CMXSFILES" cmxsfiles inc;
+      print "\n";
+    end;
+    print "install:";
+    if (not_empty cmxsfiles) then print "$(if ifeq '$(HASNATDYNLINK)' 'true',install-natdynlink)";
+    print "\n";
+    if not_empty vfiles then install_include_by_root "VOFILES" vfiles inc;
+    if (not_empty cmofiles) then
+      install_include_by_root "CMOFILES" cmofiles inc;
+    if (not_empty cmifiles) then
+      install_include_by_root "CMIFILES" cmifiles inc;
+    if (not_empty mllibfiles) then
+      install_include_by_root "CMAFILES" mllibfiles inc;
+    List.iter
+      (fun x ->
+	 printf "\t(cd %s; $(MAKE) DSTROOT=$(DSTROOT) INSTALLDEFAULTROOT=$(INSTALLDEFAULTROOT)/%s install)\n" x x)
+      sds;
+    print "\n";
+    install_doc (not_empty vfiles) (not_empty mlifiles) inc
+
+let make_makefile sds =
+  if !make_name <> "" then begin
+    printf "%s: %s\n" !makefile_name !make_name;
+    print "\tmv -f $@ $@.bak\n";
+    print "\t$(COQBIN)coq_makefile -f $< -o $@\n\n";
+    List.iter
+      (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n")
+      sds;
+    print "\n";
+  end
+
+let clean sds sps =
+  print "clean:\n";
+  if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin
+    print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n";
+    print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n";
+    print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n";
+  end;
+  if !some_vfile then
+    print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n";
+  print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n";
+  print "\t- rm -rf html mlihtml\n";
+  List.iter
+    (fun (file,_,_) ->
+       if not (is_genrule file) then
+	 (print "\t- rm -rf "; print file; print "\n"))
+    sps;
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n")
+    sds;
+  print "\n";
+  print "archclean:\n";
+  print "\trm -f *.cmx *.o\n";
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n")
+    sds;
+  print "\n";
+  print "printenv:\n\t@$(COQBIN)coqtop -config\n";
+  print "\t@echo CAMLC =\t$(CAMLC)\n\t@echo CAMLOPTC =\t$(CAMLOPTC)\n\t@echo PP =\t$(PP)\n\t@echo COQFLAGS =\t$(COQFLAGS)\n";
+  print "\t@echo COQLIBINSTALL =\t$(COQLIBINSTALL)\n\t@echo COQDOCINSTALL =\t$(COQDOCINSTALL)\n\n"
+
+let header_includes () = ()
+
+let implicit () =
+    section "Implicit rules.";
+  let mli_rules () =
+    print "%.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "%.mli.d: %.mli\n";
+    print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let ml4_rules () =
+    print "%.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
+    print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
+    print "%.ml4.d: %.ml4\n";
+    print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let ml_rules () =
+    print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "%.ml.d: %.ml\n";
+    print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let cmxs_rules () =
+    print "%.cmxs: %.cmx\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n" in
+  let mllib_rules () =
+    print "%.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "%.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "%.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n";
+    print "%.mllib.d: %.mllib\n";
+    print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let mlpack_rules () =
+    print "%.cmo: | %.mlpack\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
+    print "%.cmx: | %.mlpack\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
+    print "%.mlpack.d: %.mlpack\n";
+    print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+in
+  let v_rules () =
+    print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "%.g: %.v\n\t$(GALLINA) $<\n\n";
+    print "%.tex: %.v\n\t$(COQDOC) -latex $< -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) -html -g $< -o $@\n\n";
+    print "%.v.d: %.v\n";
+    print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+    print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n"
+  in
+    if !some_mlifile then mli_rules ();
+    if !some_ml4file then ml4_rules ();
+    if !some_mlfile then ml_rules ();
+    if !some_mlfile || !some_ml4file then cmxs_rules ();
+    if !some_mllibfile then mllib_rules ();
+    if !some_mlpackfile then mlpack_rules ();
+    if !some_vfile then v_rules ()
+
+let variables is_install opt (args,defs) =
+  let var_aux (v,def) = print v; print "="; print def; print "\n" in
+    section "Variables definitions.";
+    List.iter var_aux defs;
+    print "\n";
+    if not opt then
+      print "override OPT:=-byte\n"
+    else
+      print "OPT?=\n";
+    begin
+      match args with
+	|[] -> ()
+	|h::t -> print "OTHERFLAGS=";
+	  print h;
+	  List.iter (fun s -> print " ";print s) t;
+	  print "\n";
+    end;
+    (* Coq executables and relative variables *)
+    if !some_vfile then begin
+    print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
+    print "COQCHKFLAGS?=-silent -o\n";
+    print "COQC?=$(COQBIN)coqc\n";
+    print "COQDEP?=$(COQBIN)coqdep -c\n";
+    print "GALLINA?=$(COQBIN)gallina\n";
+    print "COQDOC?=$(COQBIN)coqdoc\n";
+    print "COQCHK?=$(COQBIN)coqchk\n\n";
+    end;
+    (* Caml executables and relative variables *)
+    if !some_ml4file || !some_mlfile || !some_mlifile then begin
+    print "COQSRCLIBS?=-I $(COQLIB)kernel -I $(COQLIB)lib \\
+  -I $(COQLIB)library -I $(COQLIB)parsing \\
+  -I $(COQLIB)pretyping -I $(COQLIB)interp \\
+  -I $(COQLIB)proofs -I $(COQLIB)tactics \\
+  -I $(COQLIB)toplevel";
+    List.iter (fun c -> print " \\
+  -I $(COQLIB)plugins/"; print c) Coq_config.plugins_dirs; print "\n";
+    print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n";
+    print "CAMLC?=$(OCAMLC) -c -rectypes\n";
+    print "CAMLOPTC?=$(OCAMLOPT) -c -rectypes\n";
+    print "CAMLLINK?=$(OCAMLC) -rectypes\n";
+    print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes\n";
+    print "GRAMMARS?=grammar.cma\n";
+    print "CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n";
+    print "CAMLP4OPTIONS?=\n";
+    print "PP?=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n\n";
+    end;
+    match is_install with
+      | Project_file.NoInstall -> ()
+      | Project_file.UnspecInstall ->
+        section "Install Paths.";
+	print "ifdef USERINSTALL\n";
+        print "XDG_DATA_HOME?=$(HOME)/.local/share\n";
+        print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n";
+        print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n";
+	print "else\n";
+        print "COQLIBINSTALL=${COQLIB}user-contrib\n";
+        print "COQDOCINSTALL=${DOCDIR}user-contrib\n";
+	print "endif\n\n"
+      | Project_file.TraditionalInstall ->
+          section "Install Paths.";
+          print "COQLIBINSTALL=${COQLIB}user-contrib\n";
+          print "COQDOCINSTALL=${DOCDIR}user-contrib\n";
+          print "\n"
+      | Project_file.UserInstall ->
+          section "Install Paths.";
+          print "XDG_DATA_HOME?=$(HOME)/.local/share\n";
+          print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n";
+          print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n";
+          print "\n"
+
+let parameters () =
+  print ".DEFAULT_GOAL := all\n\n# \n";
+  print "# This Makefile may take arguments passed as environment variables:\n";
+  print "# COQBIN to specify the directory where Coq binaries resides;\n";
+  print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n";
+  print "# DSTROOT to specify a prefix to install path.\n\n";
+  print "# Here is a hack to make $(eval $(shell works:\n";
+  print "define donewline\n\n\nendef\n";
+  print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr '\\n' '@'; })))\n";
+  print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"
+
+let include_dirs (inc_i,inc_r) =
+  let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in
+  let parse_rec_includes l =
+    List.map (fun (p,l,_) ->
+      let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l')
+      l in
+  let inc_i' = List.filter (fun (_,i) -> not (List.exists (fun (_,_,i') -> is_prefix i' i) inc_r)) inc_i in
+  let str_i = parse_includes inc_i in
+  let str_i' = parse_includes inc_i' in
+  let str_r = parse_rec_includes inc_r in
+    section "Libraries definitions.";
+    if !some_ml4file || !some_mlfile || !some_mlifile then begin
+      print "OCAMLLIBS?="; print_list "\\\n  " str_i; print "\n";
+    end;
+    if !some_vfile then begin
+      print "COQLIBS?="; print_list "\\\n  " str_i'; print " "; print_list "\\\n  " str_r; print "\n";
+      print "COQDOCLIBS?=";   print_list "\\\n  " str_r; print "\n\n";
+    end
+
+let custom sps =
+  let pr_path (file,dependencies,com) =
+    print file; print ": "; print dependencies; print "\n";
+    if com <> "" then (print "\t"; print com); print "\n\n"
+  in
+    if sps <> [] then section "Custom targets.";
+    List.iter pr_path sps
+
+let subdirs sds =
+  let pr_subdir s =
+    print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n"
+  in
+    if sds <> [] then section "Subdirectories.";
+    List.iter pr_subdir sds
+
+let forpacks l =
+  let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in
+  List.iter (fun it ->
+    let h = Filename.chop_extension it in
+    printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h;
+    printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" (String.capitalize (Filename.basename h));
+    printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h;
+    printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" (String.capitalize (Filename.basename h))
+  ) l
+
+let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc =
+  let decl_var var = function
+    |[] -> ()
+    |l ->
+      printf "%s:=" var; print_list "\\\n  " l; print "\n";
+      printf "\n-include $(addsuffix .d,$(%s))\n.SECONDARY: $(addsuffix .d,$(%s))\n\n" var var
+  in
+  section "Files dispatching.";
+  decl_var "VFILES" vfiles;
+  begin match vfiles with
+    |[] -> ()
+    |l ->
+      print "VOFILES:=$(VFILES:.v=.vo)\n";
+      classify_files_by_root "VOFILES" l inc;
+      print "GLOBFILES:=$(VFILES:.v=.glob)\n";
+      print "VIFILES:=$(VFILES:.v=.vi)\n";
+      print "GFILES:=$(VFILES:.v=.g)\n";
+      print "HTMLFILES:=$(VFILES:.v=.html)\n";
+      print "GHTMLFILES:=$(VFILES:.v=.g.html)\n"
+  end;
+  decl_var "ML4FILES" ml4files;
+  decl_var "MLFILES" mlfiles;
+  decl_var "MLPACKFILES" mlpackfiles;
+  decl_var "MLLIBFILES" mllibfiles;
+  decl_var "MLIFILES" mlifiles;
+  let mlsfiles = match ml4files,mlfiles,mlpackfiles with
+    |[],[],[] -> []
+    |[],[],_ -> Printf.eprintf "Mlpack cannot work without ml[4]?"; []
+    |[],ml,[] ->
+      print "ALLCMOFILES:=$(MLFILES:.ml=.cmo)\n";
+      ml
+    |ml4,[],[] ->
+      print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo)\n";
+      ml4
+    |ml4,ml,[] ->
+      print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo)\n";
+      List.rev_append ml ml4
+    |[],ml,mlpack ->
+      print "ALLCMOFILES:=$(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n";
+      List.rev_append mlpack ml
+    |ml4,[],mlpack ->
+      print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n";
+      List.rev_append mlpack ml4
+    |ml4,ml,mlpack ->
+      print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n";
+      List.rev_append mlpack (List.rev_append ml ml4) in
+  begin match mlsfiles with
+    |[] -> ()
+    |l ->
+  print "CMOFILES=$(filter-out $(addsuffix .cmo,$(foreach lib,$(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES) $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ALLCMOFILES))\n";
+      classify_files_by_root "CMOFILES" l inc;
+      print "CMXFILES=$(CMOFILES:.cmo=.cmx)\n";
+      print "OFILES=$(CMXFILES:.cmx=.o)\n";
+  end;
+  begin match mllibfiles with
+    |[] -> ()
+    |l ->
+      print "CMAFILES:=$(MLLIBFILES:.mllib=.cma)\n";
+	classify_files_by_root "CMAFILES" l inc;
+      print "CMXAFILES:=$(CMAFILES:.cma=.cmxa)\n";
+  end;
+  begin match mlifiles,mlsfiles with
+    |[],[] -> ()
+    |l,[] ->
+       print "CMIFILES:=$(MLIFILES:.mli=.cmi)\n";
+	classify_files_by_root "CMIFILES" l inc;
+    |[],l ->
+      print "CMIFILES=$(ALLCMOFILES:.cmo=.cmi)\n";
+      classify_files_by_root "CMIFILES" l inc;
+    |l1,l2 ->
+      print "CMIFILES=$(sort $(ALLCMOFILES:.cmo=.cmi) $(MLIFILES:.mli=.cmi))\n";
+      classify_files_by_root "CMIFILES" (l1@l2) inc;
+  end;
+  begin match mllibfiles,mlsfiles with
+    |[],[] -> ()
+    |l,[] ->
+      print "CMXSFILES:=$(CMXAFILES:.cmxa=.cmxs)\n";
+      classify_files_by_root "CMXSFILES" l inc;
+    |[],l ->
+      print "CMXSFILES=$(CMXFILES:.cmx=.cmxs)\n";
+      classify_files_by_root "CMXSFILES" l inc;
+    |l1,l2 ->
+      print "CMXSFILES=$(CMXFILES:.cmx=.cmxs) $(CMXAFILES:.cmxa=.cmxs)\n";
+      classify_files_by_root "CMXSFILES" (l1@l2) inc;
+  end;
+  print "\n";
+  section "Definition of the toplevel targets.";
+  print "all: ";
+  if !some_vfile then print "$(VOFILES) ";
+  if !some_mlfile || !some_ml4file || !some_mlpackfile then print "$(CMOFILES) ";
+  if !some_mllibfile then print "$(CMAFILES) ";
+  if !some_mlfile || !some_ml4file || !some_mllibfile || !some_mlpackfile
+  then print "$(if ifeq '$(HASNATDYNLINK)' 'true',$(CMXSFILES)) ";
+  print_list "\\\n  " other_targets; print "\n\n";
+  if !some_mlifile then
+    begin
+      print "mlihtml: $(MLIFILES:.mli=.cmi)\n";
+      print "\t mkdir $@ || rm -rf $@/*\n";
+      print "\t$(OCAMLDOC) -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+      print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n";
+      print "\t$(OCAMLDOC) -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+    end;
+  if !some_vfile then
+    begin
+      print "spec: $(VIFILES)\n\n";
+      print "gallina: $(GFILES)\n\n";
+      print "html: $(GLOBFILES) $(VFILES)\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 -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 $^`\n\n";
+      print "all-gal.ps: $(VFILES)\n";
+      print "\t$(COQDOC) -toc -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "all.pdf: $(VFILES)\n";
+      print "\t$(COQDOC) -toc -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "all-gal.pdf: $(VFILES)\n";
+      print "\t$(COQDOC) -toc -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "validate: $(VOFILES)\n";
+      print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n";
+      print "beautify: $(VFILES:=.beautified)\n";
+      print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n";
+      print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n";
+      print "\t@echo \'If there were a problem, execute \"for file in $$(find . -name \\*.v.old -print); do mv $${file} $${file%.old}; done\" in your shell/'\n\n"
+    end
+
+let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc =
+  let special_targets = List.filter (fun (n,_,_) -> not (is_genrule n)) sps in
+  let other_targets = List.map (function x,_,_ -> x) special_targets @ sds in
+  main_targets vfiles mlfiles other_targets inc;
+    print ".PHONY: ";
+    print_list " "
+      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install"
+	:: "userinstall" :: "depend" :: "html" :: "validate" :: sds);
+    print "\n\n";
+    custom sps;
+    subdirs sds;
+    forpacks mlpackfiles
+
+let banner () =
+  print (Printf.sprintf
+"#############################################################################
+##  v      #                   The Coq Proof Assistant                     ##
+## <O___,, #                INRIA - CNRS - LIX - LRI - PPS                 ##
+##   \\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 ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((i_inc,r_inc) as l) =
+  let here = Sys.getcwd () in
+  let not_tops =List.for_all (fun s -> s <> Filename.basename s) in
+  if List.exists (fun (_,x) -> x = here) i_inc
+    or List.exists (fun (_,_,x) -> is_prefix x here) r_inc
+    or (not_tops v && not_tops mli && not_tops ml4 && not_tops ml
+	&& not_tops mllib && not_tops mlpack) then
+    l
+  else
+    ((".",here)::i_inc,r_inc)
+
+let warn_install_at_root_directory
+    (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_i,inc_r) =
+  let inc_r_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r in
+  let inc_top = List.map (fun (p,_,_) -> p) inc_r_top in
+  let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in
+  if inc_r = [] || List.exists (fun f -> List.mem (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"
+      (if inc_r_top = [] then "" else "with non trivial logical root ")
+
+let check_overlapping_include (_,inc_r) =
+  let pwd = Sys.getcwd () in
+  let rec aux = function
+    | [] -> ()
+    | (pdir,_,abspdir)::l ->
+	if not (is_prefix pwd abspdir) then
+	  Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir;
+	List.iter (fun (pdir',_,abspdir') ->
+	  if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then
+	    Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l;
+  in aux inc_r
+
+let do_makefile args =
+  let has_file var = function
+    |[] -> var := false
+    |_::_ -> var := true in
+  let (project_file,makefile,is_install,opt),l =
+    try Project_file.process_cmd_line Filename.current_dir_name (None,None,Project_file.UnspecInstall,true) [] args
+    with Project_file.Parsing_error -> usage () in
+  let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs =
+    Project_file.split_arguments l in
+
+  let () = match project_file with |None -> () |Some f -> make_name := f in
+  let () = match makefile with
+    |None -> ()
+    |Some f -> makefile_name := f; output_channel := open_out f in
+  has_file some_vfile v_f; has_file some_mlifile mli_f;
+  has_file some_mlfile ml_f; has_file some_ml4file ml4_f;
+  has_file some_mllibfile mllib_f; has_file some_mlpackfile mlpack_f;
+  let check_dep f =
+    if Filename.check_suffix f ".v" then some_vfile := true
+    else if (Filename.check_suffix f ".mli") then some_mlifile := true
+    else if (Filename.check_suffix f ".ml4") then some_ml4file := true
+    else if (Filename.check_suffix f ".ml") then some_mlfile := true
+    else if (Filename.check_suffix f ".mllib") then some_mllibfile := true
+    else if (Filename.check_suffix f ".mlpack") then some_mlpackfile := true
+  in
+  List.iter (fun (_,dependencies,_) ->
+    List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps;
+
+  let inc = ensure_root_dir targets inc in
+  if is_install <> Project_file.NoInstall then warn_install_at_root_directory targets inc;
+  check_overlapping_include inc;
+  banner ();
+  header_includes ();
+  warning ();
+  command_line args;
+  parameters ();
+  include_dirs inc;
+  variables is_install opt defs;
+  all_target targets inc;
+  section "Special targets.";
+  standard opt;
+  install targets inc is_install;
+  clean sds sps;
+  make_makefile sds;
+  implicit ();
+  warning ();
+  if not (makefile = None) 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_makefile.ml4 b/tools/coq_makefile.ml4
deleted file mode 100644
index 50f0344b..00000000
--- a/tools/coq_makefile.ml4
+++ /dev/null
@@ -1,614 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: coq_makefile.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* créer un Makefile pour un développement Coq automatiquement *)
-
-type target =
-  | ML of string (* ML file : foo.ml -> (ML "foo") *)
-  | V of string  (* V file : foo.v -> (V "foo") *)
-  | Special of string * string * string (* file, dependencies, command *)
-  | Subdir of string
-  | Def of string * string (* X=foo -> Def ("X","foo") *)
-  | Include of string
-  | RInclude of string * string (* -R physicalpath logicalpath *)
-
-let output_channel = ref stdout
-let makefile_name = ref "Makefile"
-let make_name = ref ""
-
-let some_file = ref false
-let some_vfile = ref false
-let some_mlfile = ref false
-
-let opt = ref "-opt"
-let impredicative_set = ref false
-let no_install = ref false
-
-let print x = output_string !output_channel x
-let printf x = Printf.fprintf !output_channel x
-
-let rec print_list sep = function
-  | [ x ] -> print x
-  | x :: l -> print x; print sep; print_list sep l
-  | [] -> ()
-
-let list_iter_i f =
-  let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1
-
-let 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"
-
-let section s =
-  let l = String.length s in
-  let sep = String.make (l+5) '#'
-  and sep2 = String.make (l+5) ' ' in
-  String.set sep (l+4) '\n';
-  String.set sep2 0 '#';
-  String.set sep2 (l+3) '#';
-  String.set sep2 (l+4) '\n';
-  print sep;
-  print sep2;
-  print "# "; print s; print " #\n";
-  print sep2;
-  print sep;
-  print "\n"
-
-let usage () =
-  output_string stderr "Usage summary:
-
-coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom
-  command dependencies file] ... [-I dir] ... [-R physicalpath logicalpath]
-  ... [VARIABLE = value] ...  [-opt|-byte] [-impredicative-set] [-no-install]
-  [-f file] [-o file] [-h] [--help]
-
-[file.v]: Coq file to be compiled
-[file.ml]: Objective Caml file to be compiled
-[subdirectory] : subdirectory that should be \"made\"
-[-custom command dependencies file]: add target \"file\" with command
-  \"command\" and dependencies \"dependencies\"
-[-I dir]: look for dependencies in \"dir\"
-[-R physicalpath logicalpath]: look for dependencies resursively starting from
- \"physicalpath\". The logical path associated to the physical path is
- \"logicalpath\".
-[VARIABLE = value]: Add the variable definition \"VARIABLE=value\"
-[-byte]: compile with byte-code version of coq
-[-opt]: compile with native-code version of coq
-[-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
-[-h]: print this usage summary
-[--help]: equivalent to [-h]\n";
-  exit 1
-
-let is_genrule r =
-    let genrule = Str.regexp("%") in
-      Str.string_match genrule r 0
-
-let absolute_dir dir =
-  let current = Sys.getcwd () in
-    Sys.chdir dir;
-    let dir' = Sys.getcwd () in
-      Sys.chdir current;
-      dir'
-
-let is_prefix dir1 dir2 =
-  let l1 = String.length dir1 in
-  let l2 = String.length dir2 in
-    dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/')
-
-let canonize f =
-  let l = String.length f in
-  if l > 2 && f.[0] = '.' && f.[1] = '/' then
-    let n = let i = ref 2 in while !i < l && f.[!i] = '/' do incr i done; !i in
-    String.sub f n (l-n)
-  else f
-
-let is_absolute_prefix dir dir' =
-  is_prefix (absolute_dir dir) (absolute_dir dir')
-
-let is_included dir = function
-  | RInclude (dir',_) -> is_absolute_prefix dir' dir
-  | Include dir' -> absolute_dir dir = absolute_dir dir'
-  | _ -> false
-
-let has_top_file = function
-  | ML s | V s -> s = Filename.basename s
-  | _ -> false
-
-let physical_dir_of_logical_dir ldir =
-  let pdir = String.copy ldir in
-  for i = 0 to String.length ldir - 1 do
-    if pdir.[i] = '.' then pdir.[i] <- '/';
-  done;
-  pdir
-
-let standard ()=
-  print "byte:\n";
-  print "\t$(MAKE) all \"OPT:=-byte\"\n\n";
-  print "opt:\n";
-  if !opt = "" then print "\t@echo \"WARNING: opt is disabled\"\n";
-  print "\t$(MAKE) all \"OPT:="; print !opt; print "\"\n\n"
-
-let is_prefix_of_file dir f =
-  is_prefix dir (absolute_dir (Filename.dirname f))
-
-let classify_files_by_root var files (inc_i,inc_r) =
-  if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) then
-    begin
-      (* Files in the scope of a -R option (assuming they are disjoint) *)
-      list_iter_i (fun i (pdir,ldir,abspdir) ->
-	if List.exists (is_prefix_of_file abspdir) files then
-	  printf "%s%d:=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n"
-	    var i pdir pdir var)
-	inc_r;
-      (* Files not in the scope of a -R option *)
-      let pat_of_dir (pdir,_,_) = pdir^"/%" in
-      let pdir_patterns = String.concat " " (List.map pat_of_dir inc_r) in
-      printf "%s0:=$(filter-out %s,$(%s))\n" var pdir_patterns var
-    end
-
-let install_include_by_root var files (_,inc_r) =
-  try
-    (* All files caught by a -R . option (assuming it is the only one) *)
-    let ldir = List.assoc "." (List.map (fun (p,l,_) -> (p,l)) inc_r) in
-    let pdir = physical_dir_of_logical_dir ldir in
-    printf "\t(for i in $(%s); do \\\n" var;
-    printf "\t install -d `dirname $(COQLIB)/user-contrib/%s/$$i`; \\\n\t install $$i $(COQLIB)/user-contrib/%s/$$i; \\\n" pdir pdir;
-    printf "\t done)\n"
-  with Not_found ->
-    (* Files in the scope of a -R option (assuming they are disjoint) *)
-    list_iter_i (fun i (pdir,ldir,abspdir) ->
-      if List.exists (is_prefix_of_file abspdir) files then
-	begin
-	  let pdir' = physical_dir_of_logical_dir ldir in
-	  printf "\t(cd %s; for i in $(%s%d); do \\\n" pdir var i;
-	  printf "\t install -d `dirname $(COQLIB)/user-contrib/%s/$$i`; \\\n\t install $$i $(COQLIB)/user-contrib/%s/$$i; \\\n" pdir' pdir';
-	  printf "\t done)\n"
-	end) inc_r;
-    (* Files not in the scope of a -R option *)
-    printf "\t(for i in $(%s0); do \\\n" var;
-    printf "\t install -d `dirname $(COQLIB)/user-contrib/$(INSTALLDEFAULTROOT)/$$i`; \\\n\t install $$i $(COQLIB)/user-contrib/$(INSTALLDEFAULTROOT)/$$i; \\\n";
-    printf "\t done)\n"
-
-let install (vfiles,mlfiles,_,sds) inc =
-  print "install:\n";
-  print "\tmkdir -p $(COQLIB)/user-contrib\n";
-  if !some_vfile then install_include_by_root "VOFILES" vfiles inc;
-  if !some_mlfile then install_include_by_root "CMOFILES" mlfiles inc;
-  if !some_mlfile then install_include_by_root "CMIFILES" mlfiles inc;
-  if Coq_config.has_natdynlink && !some_mlfile then
-    install_include_by_root "CMXSFILES" mlfiles inc;
-  List.iter
-    (fun x ->
-      printf "\t(cd %s; $(MAKE) INSTALLDEFAULTROOT=$(INSTALLDEFAULTROOT)/%s install)\n" x x)
-    sds;
-  print "\n"
-
-let make_makefile sds =
-  if !make_name <> "" then begin
-    printf "%s: %s\n" !makefile_name !make_name;
-    printf "\tmv -f %s %s.bak\n" !makefile_name !makefile_name;
-    printf "\t$(COQBIN)coq_makefile -f %s -o %s\n" !make_name !makefile_name;
-    print "\n";
-    List.iter
-      (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n")
-      sds;
-    print "\n";
-  end
-
-let clean sds sps =
-  print "clean:\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";
-  print "\t- rm -rf html\n";
-  List.iter
-    (fun (file,_,_) ->
-       if not (is_genrule file) then
-	 (print "\t- rm -f "; print file; print "\n"))
-    sps;
-  List.iter
-    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n")
-    sds;
-  print "\n";
-  print "archclean:\n";
-  print "\trm -f *.cmx *.o\n";
-  List.iter
-    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n")
-    sds;
-  print "\n\n";
-  print "printenv: \n\t@echo CAMLC =\t$(CAMLC)\n\t@echo CAMLOPTC =\t$(CAMLOPTC)\n";
-  print "\t@echo CAMLP4LIB =\t$(CAMLP4LIB)\n\n"
-
-let header_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"
-
-let implicit () =
-  let ml_rules () =
-    print "%.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
-    print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n";
-    print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n";
-    print "%.cmxs: %.ml\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $(PP) $<\n\n";
-    print "%.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
-    print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
-    print "%.cmxs: %.ml4\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $(PP) -impl $<\n\n";
-    print "%.ml.d: %.ml\n";
-    print "\t$(CAMLBIN)ocamldep -slash $(OCAMLLIBS) $(PP) \"$<\" > \"$@\"\n\n"
-  and v_rule () =
-    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) -html $< -o $@\n\n";
-    print "%.g.tex: %.v\n\t$(COQDOC) -latex -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) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
-  in
-    if !some_mlfile then ml_rules ();
-    if !some_vfile then v_rule ()
-
-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
-      print "override OPT:=-byte\n"
-    else
-      print "OPT:=\n";
-    if !impredicative_set = true then print "OTHERFLAGS=-impredicative-set\n";
-    (* Coq executables and relative variables *)
-    print "COQFLAGS:=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
-    print "ifdef CAMLBIN\n  COQMKTOPFLAGS:=-camlbin $(CAMLBIN) -camlp4bin $(CAMLP4BIN)\nendif\n";
-    print "COQC:=$(COQBIN)coqc\n";
-    print "COQDEP:=$(COQBIN)coqdep -c\n";
-    print "GALLINA:=$(COQBIN)gallina\n";
-    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;
-    printf "CAMLOPTLINK:=$(CAMLBIN)%s -rectypes\n" best_ocamlopt;
-    print "GRAMMARS:=grammar.cma\n";
-    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 $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n";
-    print "\n"
-
-let parameters () =
-  print "# \n";
-  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 "ifndef CAMLP4BIN\n  CAMLP4BIN:=$(CAMLBIN)\nendif\n\n";
-  print "CAMLP4LIB:=$(shell $(CAMLP4BIN)$(CAMLP4) -where)\n\n"
-
-let include_dirs (inc_i,inc_r) =
-  let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in
-  let parse_rec_includes l =
-    List.map (fun (p,l,_) ->
-      let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l')
-      l in
-  let inc_i' = List.filter (fun (i,_) -> not (List.exists (fun (i',_,_) -> is_absolute_prefix i' i) inc_r)) inc_i in
-  let str_i = parse_includes inc_i in
-  let str_i' = parse_includes inc_i' in
-  let str_r = parse_rec_includes inc_r in
-    section "Libraries definitions.";
-    print "OCAMLLIBS:="; print_list "\\\n  " str_i; print "\n";
-    print "COQSRCLIBS:=-I $(COQLIB)/kernel -I $(COQLIB)/lib \\
-  -I $(COQLIB)/library -I $(COQLIB)/parsing \\
-  -I $(COQLIB)/pretyping -I $(COQLIB)/interp \\
-  -I $(COQLIB)/proofs -I $(COQLIB)/tactics \\
-  -I $(COQLIB)/toplevel";
-    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"
-
-
-let rec special = function
-  | [] -> []
-  | Special (file,deps,com) :: r -> (file,deps,com) :: (special r)
-  | _ :: r -> special r
-
-let custom sps =
-  let pr_path (file,dependencies,com) =
-    print file; print ": "; print dependencies; print "\n";
-    if com <> "" then (print "\t"; print com); print "\n\n"
-  in
-    if sps <> [] then section "Custom targets.";
-    List.iter pr_path sps
-
-let subdirs sds =
-  let pr_subdir s =
-    print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n"
-  in
-    if sds <> [] then section "Subdirectories.";
-    List.iter pr_subdir sds;
-    section "Special targets.";
-    print ".PHONY: ";
-    print_list " "
-      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install"
-	:: "depend" :: "html" :: sds);
-    print "\n\n"
-
-let rec split_arguments = function
-  | V n :: r ->
-      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 ->
-      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)
-  | Include p :: r ->
-      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 ->
-      let t,i,d = split_arguments r in (t,i,(v,def)::d)
-  | [] -> ([],[],[],[]),([],[]),[]
-
-let main_targets vfiles mlfiles other_targets inc =
-    if !some_vfile then
-      begin
-	print "VFILES:="; print_list "\\\n  " vfiles; print "\n";
-	print "VOFILES:=$(VFILES:.v=.vo)\n";
-	classify_files_by_root "VOFILES" vfiles inc;
-	print "GLOBFILES:=$(VFILES:.v=.glob)\n";
-	print "VIFILES:=$(VFILES:.v=.vi)\n";
-	print "GFILES:=$(VFILES:.v=.g)\n";
-	print "HTMLFILES:=$(VFILES:.v=.html)\n";
-	print "GHTMLFILES:=$(VFILES:.v=.g.html)\n"
-      end;
-    if !some_mlfile then
-      begin
-	print "MLFILES:="; print_list "\\\n  " mlfiles; print "\n";
-	print "CMOFILES:=$(MLFILES:.ml=.cmo)\n";
-	classify_files_by_root "CMOFILES" mlfiles inc;
-	print "CMIFILES:=$(MLFILES:.ml=.cmi)\n";
-	classify_files_by_root "CMIFILES" mlfiles inc;
-	print "CMXFILES:=$(MLFILES:.ml=.cmx)\n";
-	print "CMXSFILES:=$(MLFILES:.ml=.cmxs)\n";
-	classify_files_by_root "CMXSFILES" mlfiles inc;
-	print "OFILES:=$(MLFILES:.ml=.o)\n";
-      end;
-    print "\nall: ";
-    if !some_vfile then print "$(VOFILES) ";
-    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
-      begin
-	print "spec: $(VIFILES)\n\n";
-	print "gallina: $(GFILES)\n\n";
-	print "html: $(GLOBFILES) $(VFILES)\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 -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";
-	print "all-gal.ps: $(VFILES)\n";
-	print "\t$(COQDOC) -toc -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
-	print "all.pdf: $(VFILES)\n";
-	print "\t$(COQDOC) -toc -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
-	print "all-gal.pdf: $(VFILES)\n";
-	print "\t$(COQDOC) -toc -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
-	print "\n\n"
-      end
-
-let all_target (vfiles, mlfiles, sps, sds) inc =
-  let special_targets = List.filter (fun (n,_,_) -> not (is_genrule n)) sps in
-  let other_targets = List.map (fun x,_,_ -> x) special_targets @ sds in
-  section "Definition of the \"all\" target.";
-  main_targets vfiles mlfiles other_targets inc;
-  custom sps;
-  subdirs sds
-
-let parse f =
-  let rec string = parser
-    | [< '' ' | '\n' | '\t' >] -> ""
-    | [< 'c; s >] -> (String.make 1 c)^(string s)
-    | [< >] -> ""
-  and string2 = parser
-    | [< ''"' >] -> ""
-    | [< 'c; s >] -> (String.make 1 c)^(string2 s)
-  and skip_comment = parser
-    | [< ''\n'; s >] -> s
-    | [< 'c; s >] -> skip_comment s
-    | [< >] -> [< >]
-  and args = parser
-    | [< '' ' | '\n' | '\t'; s >] -> args s
-    | [< ''#'; s >] -> args (skip_comment s)
-    | [< ''"'; str = string2; s >] -> ("" ^ str) :: args s
-    | [< 'c; str = string; s >] -> ((String.make 1 c) ^ str) :: (args s)
-    | [< >] -> []
-  in
-  let c = open_in f in
-  let res = args (Stream.of_channel c) in
-    close_in c;
-    res
-
-let rec process_cmd_line = function
-  | [] ->
-      some_file := !some_file or !some_mlfile or !some_vfile; []
-  | ("-h"|"--help") :: _ ->
-      usage ()
-  | ("-no-opt"|"-byte") :: r ->
-      opt := "-byte"; process_cmd_line r
-  | ("-full"|"-opt") :: r ->
-      opt := "-opt"; process_cmd_line r
-  | "-impredicative-set" :: r ->
-      impredicative_set := true; process_cmd_line r
-  | "-no-install" :: r ->
-      no_install := true; process_cmd_line r
-  | "-custom" :: com :: dependencies :: file :: r ->
-      let check_dep f =
-	if Filename.check_suffix f ".v" then
-          some_vfile := true
-	else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then
-          some_mlfile := true
-      in
-	List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies);
-	Special (file,dependencies,com) :: (process_cmd_line r)
-  | "-I" :: d :: r ->
-      Include d :: (process_cmd_line r)
-  | "-R" :: p :: l :: r ->
-      RInclude (p,l) :: (process_cmd_line r)
-  | ("-I"|"-custom") :: _ ->
-      usage ()
-  | "-f" :: file :: r ->
-      make_name := file;
-      process_cmd_line ((parse file)@r)
-  | ["-f"] ->
-      usage ()
-  | "-o" :: file :: r ->
-      makefile_name := file;
-      output_channel := (open_out file);
-      (process_cmd_line r)
-  | v :: "=" :: def :: r ->
-      Def (v,def) :: (process_cmd_line r)
-  | f :: r ->
-      if Filename.check_suffix f ".v" then begin
-          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;
-	  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 (Printf.sprintf
-"#############################################################################
-##  v      #                   The Coq Proof Assistant                     ##
-## <O___,, #                INRIA - CNRS - LIX - LRI - PPS                 ##
-##   \\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 =
-    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 ->
-	print_dep d before; iter (d :: dirs, d :: before) l
-    | (ML f) :: l ->
-	print_dep f dirs; iter (dirs, f :: before) l
-    | (V f) :: l ->
-	print_dep f dirs; iter (dirs, f :: before) l
-    | (Special (f,_,_)) :: l ->
-	print_dep f dirs; iter (dirs, f :: before) l
-    | _ :: l ->
-	iter acc l
-  in
-    iter ([],[]) l
-
-let ensure_root_dir l =
-  if List.exists (is_included ".") l or not (List.exists has_top_file l) then
-    l
-  else
-    Include "." :: l
-
-let warn_install_at_root_directory (vfiles,mlfiles,_,_) (inc_i,inc_r) =
-  let inc_r_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r in
-  let inc_top = List.map (fun (p,_,a) -> (p,a)) inc_r_top @ inc_i in
-  let files = vfiles @ mlfiles in
-  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"
-      (if inc_r_top = [] then "" else "with non trivial logical root ")
-
-let check_overlapping_include (inc_i,inc_r) =
-  let pwd = Sys.getcwd () in
-  let rec aux = function
-    | [] -> ()
-    | (pdir,_,abspdir)::l ->
-	if not (is_prefix pwd abspdir) then
-	  Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir;
-	List.iter (fun (pdir',_,abspdir') ->
-	  if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then
-	    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
-  in aux inc_r
-
-let do_makefile args =
-  let l = process_cmd_line args in
-  let l = ensure_root_dir l in
-  let (_,_,sps,sds as targets), inc, defs = split_arguments l in
-  warn_install_at_root_directory targets inc;
-  check_overlapping_include inc;
-  banner ();
-  header_includes ();
-  warning ();
-  command_line args;
-  parameters ();
-  include_dirs inc;
-  variables defs;
-  all_target targets inc;
-  implicit ();
-  standard ();
-  if not !no_install then install targets inc;
-  clean sds sps;
-  make_makefile sds;
-  (* TEST directories_deps l; *)
-  footer_includes ();
-  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 14a37a2e..485162ee 100644
--- a/tools/coq_tex.ml4
+++ b/tools/coq_tex.ml4
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_tex.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* coq-tex
  * JCF, 16/1/98
  * adapted from caml-tex (perl script written by Xavier Leroy)
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index d36fdae3..bc840d2d 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqdep.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Printf
 open Coqdep_lexer
 open Coqdep_common
@@ -40,7 +38,7 @@ let rec warning_mult suf iter =
 let add_coqlib_known phys_dir log_dir f =
   match get_extension f [".vo"] with
     | (basename,".vo") ->
-	let name = log_dir@[basename] in
+        let name = log_dir@[basename] in
 	let paths = suffixes name in
         List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths
     | _ -> ()
@@ -192,6 +190,7 @@ 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;
+  (* NOTE: These directories are searched from last to first *)
   if !Flags.boot then begin
     add_rec_dir add_known "theories" ["Coq"];
     add_rec_dir add_known "plugins" ["Coq"]
@@ -200,7 +199,9 @@ let coqdep () =
     add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"];
     add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"];
     let user = coqlib//"user-contrib" in
-    if Sys.file_exists user then add_rec_dir add_coqlib_known user []
+    if Sys.file_exists user then add_rec_dir add_coqlib_known user [];
+    List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.xdg_dirs;
+    List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.coqpath;
   end;
   List.iter (fun (f,d) -> add_mli_known f d) !mliAccu;
   List.iter (fun (f,d) -> add_mllib_known f d) !mllibAccu;
diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml
index 68197e0c..2834af81 100644
--- a/tools/coqdep_boot.ml
+++ b/tools/coqdep_boot.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqdep_boot.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Coqdep_common
 
 (** [coqdep_boot] is a stripped-down version of [coqdep], whose
@@ -22,6 +20,8 @@ let rec parse = function
   | "-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 *)
+  | "-mldep" :: ocamldep :: ll ->
+      option_mldep := Some ocamldep; option_c := true; parse ll
   | "-I" :: r :: ll ->
        (* To solve conflict (e.g. same filename in kernel and checker)
           we allow to state an explicit order *)
diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml
index 5d06b888..e412bc8f 100644
--- a/tools/coqdep_common.ml
+++ b/tools/coqdep_common.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqdep_common.ml 11984 2009-03-16 13:41:49Z letouzey $ *)
-
 open Printf
 open Coqdep_lexer
 open Unix
@@ -26,6 +24,7 @@ let option_c = ref false
 let option_noglob = ref false
 let option_slash = ref false
 let option_natdynlk = ref true
+let option_mldep = ref None
 
 let norecdir_list = ref ([]:string list)
 
@@ -63,6 +62,7 @@ let basename_noext filename =
 let mlAccu  = ref ([] : (string * string * dir) list)
 and mliAccu = ref ([] : (string * dir) list)
 and mllibAccu = ref ([] : (string * dir) list)
+and mlpackAccu = ref ([] : (string * dir) list)
 
 (** Coq files specifies on the command line:
     - first string is the full filename, with only its extension removed
@@ -108,12 +108,17 @@ let mkknown () =
 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 add_mlpack_known, _, search_mlpack_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 error_cannot_parse s (i,j) =
+  Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j;
+  exit 1
+
 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"
@@ -122,12 +127,12 @@ let warning_module_notfound f s =
 
 let warning_notfound f s =
   eprintf "*** Warning: in file %s, the file " f;
-  eprintf "%s.v is required and has not been found !\n" s;
+  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;
+  eprintf "%s has not been found!\n" s;
   flush stderr
 
 let warning_clash file dir =
@@ -178,7 +183,26 @@ let depend_ML str =
 	(" "^mlifile^".cmi"," "^mlifile^".cmi")
     | None, None -> "", ""
 
-let traite_fichier_ML md ext =
+let soustraite_fichier_ML dep md ext =
+  try
+    let chan = open_process_in (dep^" -modules "^md^ext) in
+    let list = ocamldep_parse (Lexing.from_channel chan) in
+    let a_faire = ref "" in
+    let a_faire_opt = ref "" in
+    List.iter
+      (fun str ->
+	 let byte,opt = depend_ML str in
+	 a_faire := !a_faire ^ byte;
+	 a_faire_opt := !a_faire_opt ^ opt)
+      (List.rev list);
+    (!a_faire, !a_faire_opt)
+  with
+    | Sys_error _ -> ("","")
+    | _ ->
+       Printf.eprintf "Coqdep: subprocess %s failed on file %s%s\n" dep md ext;
+       exit 1
+
+let autotraite_fichier_ML md ext =
   try
     let chan = open_in (md ^ ext) in
     let buf = Lexing.from_channel chan in
@@ -203,22 +227,29 @@ let traite_fichier_ML md ext =
     (!a_faire, !a_faire_opt)
   with Sys_error _ -> ("","")
 
-let traite_fichier_mllib md ext =
+let traite_fichier_ML md ext =
+  match !option_mldep with
+    | Some dep -> soustraite_fichier_ML dep md ext
+    | None -> autotraite_fichier_ML md ext
+
+let traite_fichier_modules 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 _ -> ("","")
-
+    List.fold_left
+      (fun a_faire str -> match search_mlpack_known str with
+	| Some mldir ->
+	  let file = file_name str mldir in
+	  a_faire^" "^file
+	| None ->
+	  match search_ml_known str with
+	    | Some mldir ->
+	      let file = file_name str mldir in
+	      a_faire^" "^file
+	    | None -> a_faire) "" list
+  with
+    | Sys_error _ -> ""
+    | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j)
 
 (* Makefile's escaping rules are awful: $ is escaped by doubling and
    other special characters are escaped by backslash prefixing while
@@ -302,9 +333,12 @@ let traite_fichier_Coq verbose f =
 		  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
+		      match search_mlpack_known s with
+			| Some mldir -> declare ".cmo" 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 ->
@@ -316,9 +350,10 @@ let traite_fichier_Coq verbose f =
                   printf " %s.v" (canonize file_str)
                 with Not_found -> ()
        	      end
+          | AddLoadPath _ | AddRecLoadPath _ -> (* TODO *) ()
       done
-    with Fin_fichier -> ();
-      close_in chan
+    with Fin_fichier -> close_in chan
+       | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j)
   with Sys_error _ -> ()
 
 
@@ -346,19 +381,30 @@ let mL_dependencies () =
   List.iter
     (fun (name,dirname) ->
        let fullname = file_name name dirname in
-       let (dep,dep_opt) = traite_fichier_mllib fullname ".mllib" in
+       let dep = traite_fichier_modules fullname ".mllib" in
+       let efullname = escape fullname in
+       printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep;
+       printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname;
+       printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname efullname;
+       flush stdout)
+    (List.rev !mllibAccu);
+  List.iter
+    (fun (name,dirname) ->
+       let fullname = file_name name dirname in
+       let dep = traite_fichier_modules fullname ".mlpack" in
        let efullname = escape fullname in
-       printf "%s.cma:%s\n" efullname dep;
-       printf "%s.cmxa %s.cmxs:%s\n" efullname efullname dep_opt;
+       printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep;
+       printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname;
+       printf "%s.cmx %s.cmxs:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname efullname;
        flush stdout)
-    (List.rev !mllibAccu)
+    (List.rev !mlpackAccu)
 
 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;
+       printf "%s%s%s %s.v.beautified: %s.v" ename !suffixe glob ename ename;
        traite_fichier_Coq true (name ^ ".v");
        printf "\n";
        flush stdout)
@@ -370,7 +416,7 @@ let rec suffixes = function
   | 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
+  match get_extension f [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with
     | (basename,".v") ->
 	let name = log_dir@[basename] in
 	let file = phys_dir//basename in
@@ -380,6 +426,7 @@ let add_known phys_dir log_dir f =
     | (basename,(".ml"|".ml4")) -> add_ml_known basename (Some phys_dir)
     | (basename,".mli") -> add_mli_known basename (Some phys_dir)
     | (basename,".mllib") -> add_mllib_known basename (Some phys_dir)
+    | (basename,".mlpack") -> add_mlpack_known basename (Some phys_dir)
     | _ -> ()
 
 (* Visits all the directories under [dir], including [dir],
@@ -432,7 +479,7 @@ let rec treat_file old_dirname old_name =
 	     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
+	(match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with
 	   | (base,".v") ->
 	       let name = file_name base dirname
 	       and absname = absolute_file_name base dirname in
@@ -440,5 +487,6 @@ let rec treat_file old_dirname old_name =
 	   | (base,(".ml"|".ml4" as ext)) -> addQueue mlAccu (base,ext,dirname)
 	   | (base,".mli") -> addQueue mliAccu (base,dirname)
 	   | (base,".mllib") -> addQueue mllibAccu (base,dirname)
+	   | (base,".mlpack") -> addQueue mlpackAccu (base,dirname)
 	   | _ -> ())
     | _ -> ()
diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli
new file mode 100644
index 00000000..53c3ba17
--- /dev/null
+++ b/tools/coqdep_common.mli
@@ -0,0 +1,49 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+val option_c : bool ref
+val option_noglob : bool ref
+val option_slash : bool ref
+val option_natdynlk : bool ref
+val option_mldep : string option ref
+val norecdir_list : string list ref
+val suffixe : string ref
+type dir = string option
+val ( // ) : string -> string -> string
+val get_extension : string -> string list -> string * string
+val basename_noext : string -> string
+val mlAccu : (string * string * dir) list ref
+val mliAccu : (string * dir) list ref
+val mllibAccu : (string * dir) list ref
+val vAccu : (string * string) list ref
+val addQueue : 'a list ref -> 'a -> unit
+val add_ml_known : string -> dir -> unit
+val iter_ml_known : (string -> dir -> unit) -> unit
+val search_ml_known : string -> dir option
+val add_mli_known : string -> dir -> unit
+val iter_mli_known : (string -> dir -> unit) -> unit
+val search_mli_known : string -> dir option
+val add_mllib_known : string -> dir -> unit
+val search_mllib_known : string -> dir option
+val vKnown : (string list, string) Hashtbl.t
+val coqlibKnown : (string list, unit) Hashtbl.t
+val file_name : string -> string option -> string
+val escape : string -> string
+val canonize : string -> string
+val mL_dependencies : unit -> unit
+val coq_dependencies : unit -> unit
+val suffixes : 'a list -> 'a list list
+val add_known : string -> string list -> string -> unit
+val add_directory :
+  bool ->
+  (string -> string list -> string -> unit) -> string -> string list -> unit
+val add_dir :
+  (string -> string list -> string -> unit) -> string -> string list -> unit
+val add_rec_dir :
+  (string -> string list -> string -> unit) -> string -> string list -> unit
+val treat_file : dir -> string -> unit
diff --git a/tools/coqdep_lexer.mli b/tools/coqdep_lexer.mli
new file mode 100644
index 00000000..6b6e0da9
--- /dev/null
+++ b/tools/coqdep_lexer.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type mL_token = Use_module of string
+
+type qualid = string list
+
+type coq_token =
+    Require of qualid list
+  | RequireString of string
+  | Declare of string list
+  | Load of string
+  | AddLoadPath of string
+  | AddRecLoadPath of string * qualid
+
+exception Fin_fichier
+exception Syntax_error of int * int
+
+val coq_action : Lexing.lexbuf -> coq_token
+val caml_action : Lexing.lexbuf -> mL_token
+val mllib_list : Lexing.lexbuf -> string list
+val ocamldep_parse : Lexing.lexbuf -> string list
diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
index 28ea4200..159c6d3c 100644
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqdep_lexer.mll 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 {
 
   open Filename
@@ -15,26 +13,42 @@
 
   type mL_token = Use_module of string
 
-  type spec = bool
+  type qualid = string list
 
   type coq_token =
-    | Require of string list list
+    | Require of qualid list
     | RequireString of string
-    | Declare of string list
+    | Declare of string list (* Names are assumed to be uncapitalized *)
     | Load of string
+    | AddLoadPath of string
+    | AddRecLoadPath of string * qualid
 
   let comment_depth = ref 0
 
   exception Fin_fichier
+  exception Syntax_error of int*int
 
   let module_current_name = ref []
   let module_names = ref []
   let ml_module_name = ref ""
+  let loadpath = ref ""
 
   let mllist = ref ([] : string list)
 
   let field_name s = String.sub s 1 (String.length s - 1)
 
+  let unquote_string s =
+    String.sub s 1 (String.length s - 2)
+
+  let unquote_vfile_string s =
+    let f = unquote_string s in
+    if check_suffix f ".v" then chop_suffix f ".v" else f
+
+  let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos;
+    lexbuf.lex_curr_p <- lexbuf.lex_start_p
+
+  let syntax_error lexbuf =
+    raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf))
 }
 
 let space = [' ' '\t' '\n' '\r']
@@ -42,31 +56,71 @@ let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255']
 let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
 let identchar =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
-let 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 coq_firstchar =
+  (* This is only an approximation, refer to lib/util.ml for correct def *)
+  ['A'-'Z' 'a'-'z' '_'] |
+  (* superscript 1 *)
+  '\194' '\185' |
+  (* utf-8 latin 1 supplement *)
+  '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] |
+  (* utf-8 letters *)
+  '\206' (['\145'-'\161'] | ['\163'-'\187'])
+  '\226' ('\130' [ '\128'-'\137' ] (* subscripts *)
+    | '\129' [ '\176'-'\187' ] (* superscripts *)
+    | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
+let coq_identchar = coq_firstchar | ['\'' '0'-'9']
+let coq_ident = coq_firstchar coq_identchar*
+let coq_field = '.' coq_ident
+
 let dot = '.' ( space+ | eof)
 
 rule coq_action = parse
   | "Require" space+
-      { module_names := []; opened_file lexbuf }
+      { require_file lexbuf }
   | "Require" space+ "Export" space+
-      { module_names := []; opened_file lexbuf}
+      { require_file lexbuf}
   | "Require" space+ "Import" space+
-      { module_names := []; opened_file lexbuf}
+      { require_file lexbuf}
   | "Local"? "Declare" space+ "ML" space+ "Module" space+
       { mllist := []; modules lexbuf}
   | "Load" space+
       { load_file lexbuf }
-  | "\""
-      { string lexbuf; coq_action lexbuf}
-  | "(*" (* "*)" *)
+  | "Add" space+ "LoadPath" space+
+      { add_loadpath lexbuf }
+  | space+
+      { coq_action lexbuf }
+  | "(*"
       { comment_depth := 1; comment lexbuf; coq_action lexbuf }
   | eof
       { raise Fin_fichier}
   | _
-      { coq_action lexbuf }
+      { skip_to_dot lexbuf; coq_action lexbuf }
+
+and add_loadpath = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; add_loadpath lexbuf }
+  | space+
+      { add_loadpath lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | '"' [^ '"']* '"' (*'"'*)
+      { loadpath := unquote_string (lexeme lexbuf);
+        add_loadpath_as lexbuf }
+
+and add_loadpath_as = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; add_loadpath_as lexbuf }
+  | space+
+      { add_loadpath_as lexbuf }
+  | "as"
+      { let qid = coq_qual_id lexbuf in
+        skip_to_dot lexbuf;
+        AddRecLoadPath (!loadpath,qid) }
+  | dot
+      { AddLoadPath !loadpath }
 
 and caml_action = parse
   | space +
@@ -133,7 +187,8 @@ and comment = parse
       { comment lexbuf }
   | eof
       { raise Fin_fichier }
-  | _ { comment lexbuf }
+  | _
+      { comment lexbuf }
 
 and string = parse
   | '"' (* '"' *)
@@ -152,69 +207,108 @@ and string = parse
 and load_file = parse
   | '"' [^ '"']* '"' (*'"'*)
       { let s = lexeme lexbuf in
-	let f = String.sub s 1 (String.length s - 2) in
-	skip_to_dot lexbuf;
-	Load (if check_suffix f ".v" then chop_suffix f ".v" else f) }
+	parse_dot lexbuf;
+	Load (unquote_vfile_string s) }
   | coq_ident
       { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s }
   | eof
-      { raise Fin_fichier }
+      { syntax_error lexbuf }
   | _
-      { load_file lexbuf }
+      { syntax_error lexbuf }
+
+and require_file = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; require_file lexbuf }
+  | space+
+      { require_file lexbuf }
+  | coq_ident
+      { module_current_name := [Lexing.lexeme lexbuf];
+        module_names := [coq_qual_id_tail lexbuf];
+        let qid = coq_qual_id_list lexbuf in
+        parse_dot lexbuf;
+        Require qid }
+  | '"' [^'"']* '"' (*'"'*)
+      { let s = Lexing.lexeme lexbuf in
+        parse_dot lexbuf;
+        RequireString (unquote_vfile_string s) }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { syntax_error lexbuf }
 
 and skip_to_dot = parse
   | dot { () }
-  | eof { () }
+  | eof { syntax_error lexbuf }
   | _   { skip_to_dot lexbuf }
 
-and opened_file = parse
-  | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; opened_file lexbuf }
+and parse_dot = parse
+  | dot { () }
+  | eof { syntax_error lexbuf }
+  | _ { syntax_error lexbuf }
+
+and coq_qual_id = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; coq_qual_id lexbuf }
   | space+
-      	       	{ opened_file lexbuf }
+      { coq_qual_id lexbuf }
   | coq_ident
-       	       	{ module_current_name := [Lexing.lexeme lexbuf];
-                  opened_file_fields lexbuf }
-
-  | '"' [^'"']* '"'   { (*'"'*)
-                        let lex = Lexing.lexeme lexbuf in
-      	       	       	let str = String.sub lex 1 (String.length lex - 2) in
-                        let str =
-                          if Filename.check_suffix str ".v" then
-                            Filename.chop_suffix str ".v"
-                          else str in
-			RequireString str }
-  | eof         { raise Fin_fichier }
-  | _           { opened_file lexbuf }
-
-and opened_file_fields = parse
-  | "(*" (* "*)" *)
-                { comment_depth := 1; comment lexbuf;
-                  opened_file_fields lexbuf }
+      { module_current_name := [Lexing.lexeme lexbuf];
+        coq_qual_id_tail lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { backtrack lexbuf;
+        let qid = List.rev !module_current_name in
+        module_current_name := [];
+        qid }
+
+and coq_qual_id_tail = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; coq_qual_id_tail lexbuf }
   | space+
-                { opened_file_fields lexbuf }
+      { coq_qual_id_tail lexbuf }
   | coq_field
-                { module_current_name :=
-                    field_name (Lexing.lexeme lexbuf) :: !module_current_name;
-                  opened_file_fields lexbuf }
-  | 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 (List.rev !module_names) }
-  | eof         { raise Fin_fichier }
-  | _           { opened_file_fields lexbuf }
+      { module_current_name :=
+          field_name (Lexing.lexeme lexbuf) :: !module_current_name;
+        coq_qual_id_tail lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { backtrack lexbuf;
+        let qid = List.rev !module_current_name in
+        module_current_name := [];
+        qid }
+
+and coq_qual_id_list = parse
+  | "(*"
+      { comment_depth := 1; comment lexbuf; coq_qual_id_list lexbuf }
+  | space+
+      { coq_qual_id_list lexbuf }
+  | coq_ident
+      { module_current_name := [Lexing.lexeme lexbuf];
+        module_names := coq_qual_id_tail lexbuf :: !module_names;
+        coq_qual_id_list lexbuf
+      }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { backtrack lexbuf;
+        List.rev !module_names }
 
 and modules = parse
-  | space+              { modules lexbuf }
-  | "(*" (* "*)" *)	{ comment_depth := 1; comment lexbuf;
-      	       	       	  modules lexbuf }
+  | space+
+      { modules lexbuf }
+  | "(*"
+      { comment_depth := 1; comment lexbuf;
+        modules lexbuf }
   | '"' [^'"']* '"'
-        { 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)) }
+      { let lex = (Lexing.lexeme lexbuf) in
+	let str = String.sub lex 1 (String.length lex - 2) in
+	mllist := str :: !mllist; modules lexbuf}
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { (Declare (List.rev !mllist)) }
 
 and qual_id = parse
   | '.' [^ '.' '(' '['] {
@@ -223,10 +317,12 @@ and qual_id = parse
   | _ { caml_action lexbuf }
 
 and mllib_list = parse
-  | coq_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf)
+  | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf)
 		in s :: mllib_list lexbuf }
+  | "*predef*" { mllib_list lexbuf }
   | space+ { mllib_list lexbuf }
   | eof { [] }
+  | _ { syntax_error lexbuf }
 
-
-
+and ocamldep_parse = parse
+  | [^ ':' ]* ':' { mllib_list lexbuf }
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index 83bfa5ed..e2bc457e 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Cdglobals
 
 let norm_char_latin1 c = match Char.uppercase c with
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
index ec5b084f..45836086 100644
--- a/tools/coqdoc/alpha.mli
+++ b/tools/coqdoc/alpha.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Alphabetic order. *)
 
 val compare_char : char -> char -> int
diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml
index 5cb670dc..6b8a3f5e 100644
--- a/tools/coqdoc/cdglobals.ml
+++ b/tools/coqdoc/cdglobals.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -49,21 +49,40 @@ type glob_source_t =
 
 let glob_source = ref DotGlob
 
+(*s Manipulations of paths and path aliases *)
+
+let normalize_path p =
+  (* We use the Unix subsystem to normalize a physical path (relative
+     or absolute) and get rid of symbolic links, relative links (like
+     ./ or ../ in the middle of the path; it's tricky but it
+     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
+
+let normalize_filename f =
+  let basename = Filename.basename f in
+  let dirname = Filename.dirname f in
+  normalize_path dirname, basename
+
 (** A weaker analog of the function in Envars *)
 
 let guess_coqlib () =
   let file = "states/initial.coq" in
-  if Sys.file_exists (Filename.concat Coq_config.coqlib file)
-  then Coq_config.coqlib
-  else
-    let coqbin = Filename.dirname Sys.executable_name in
-    let prefix = Filename.dirname coqbin in
-    let rpath = if Coq_config.local then [] else
-	(if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in
-    let coqlib = List.fold_left Filename.concat prefix rpath in
-    if Sys.file_exists (Filename.concat coqlib file) then coqlib
-    else
-      Coq_config.coqlib
+  match Coq_config.coqlib with
+    | Some coqlib when Sys.file_exists (Filename.concat coqlib file) ->
+      coqlib
+    | Some _ | None ->
+      let coqbin = normalize_path (Filename.dirname Sys.executable_name) in
+      let prefix = Filename.dirname coqbin in
+      let rpath = if Coq_config.local then [] else
+	  (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in
+      let coqlib = List.fold_left Filename.concat prefix rpath in
+      if Sys.file_exists (Filename.concat coqlib file) then coqlib
+      else prefix
 
 let header_trailer = ref true
 let header_file = ref ""
@@ -90,6 +109,7 @@ let toc_depth = (ref None : int option ref)
 let lib_name = ref "Library"
 let lib_subtitles = ref false
 let interpolate = ref false
+let inline_notmono = ref false
 
 let charset = ref "iso-8859-1"
 let inputenc = ref ""
@@ -103,7 +123,7 @@ let set_latin1 () =
 
 let set_utf8 () =
   charset := "utf-8";
-  inputenc := "utf8";
+  inputenc := "utf8x";
   utf8 := true
 
 (* Parsing options *)
diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css
index 24b514b7..ccd285f1 100644
--- a/tools/coqdoc/coqdoc.css
+++ b/tools/coqdoc/coqdoc.css
@@ -101,8 +101,13 @@ h4.section {
     color: rgb(30%,30%,70%);
     font-family: monospace } 
 
-.doc .inlinecode .id {
-    color: rgb(30%,30%,70%);
+.doc .inlinecode .id { 
+    color: rgb(30%,30%,70%); 
+} 
+
+.inlinecodenm { 
+    display: inline;
+    color: #444444;
 }
 
 .doc .code { 
@@ -124,6 +129,32 @@ h4.section {
     font-family: monospace;
  } 
 
+table.infrule {
+  border: 0px;
+  margin-left: 50px;
+  margin-top: 10px;
+  margin-bottom: 10px;
+}
+
+td.infrule {
+    font-family: monospace;
+    text-align: center;
+/*    color: rgb(35%,35%,70%);  */
+    padding: 0px;
+    line-height: 100%;
+}
+
+tr.infrulemiddle hr {
+    margin: 1px 0 1px 0;
+}
+
+.infrulenamecol {
+    color: rgb(60%,60%,60%); 
+    font-size: 80%;
+    padding-left: 1em;
+    padding-bottom: 0.1em
+}
+
 /* Pied de page */
 
 #footer { font-size: 65%;
@@ -231,4 +262,13 @@ h4.section {
     position: absolute;
     bottom: 0;
     text-align: bottom;
-}
\ No newline at end of file
+}
+
+.paragraph {
+    height: 0.75em;
+}
+
+ul.doclist {
+    margin-top: 0em;
+    margin-bottom: 0em;
+}
diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli
index 085ae122..cb511c16 100644
--- a/tools/coqdoc/cpretty.mli
+++ b/tools/coqdoc/cpretty.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cpretty.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Index
 
 val coq_file : string -> Cdglobals.coq_module -> unit
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
index 63850bd5..89047e83 100644
--- a/tools/coqdoc/cpretty.mll
+++ b/tools/coqdoc/cpretty.mll
@@ -1,14 +1,11 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cpretty.mll 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s Utility functions for the scanners *)
 
 {
@@ -318,6 +315,7 @@ let def_token =
   | "SubClass"
   | "Example"
   | "Fixpoint"
+  | "Function"
   | "Boxed"
   | "CoFixpoint"
   | "Record"
@@ -657,8 +655,6 @@ and coq = parse
 (*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
@@ -668,31 +664,24 @@ and doc_bol = parse
           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
+  | space_nl* '-'+
+      { let buf' = lexeme lexbuf in
+        let bufs = Str.split_delim (Str.regexp "['\n']") buf' in
+        let lines = (List.length bufs) - 1 in
+        let line = 
+          match bufs with
+          | [] -> eprintf "Internal error bad_split1 - please report\n";
+                  exit 1
+          | _ -> List.nth bufs lines
         in
-          match check_start_list buf with
+          match check_start_list line 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
+          | List n -> Output.paragraph ();
+                      Output.item 1; doc (Some [n]) lexbuf
           | Rule -> Output.rule (); doc None lexbuf
       }
+  | space* nl+
+      { Output.paragraph (); doc_bol lexbuf }
   | "<<" space*
       { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf }
   | eof
@@ -728,6 +717,8 @@ and doc_list_bol indents = parse
         Output.end_inline_coq_block ();
         formatted := false;
         doc_list_bol indents lexbuf }
+  | "[[[" nl
+      { inf_rules (Some indents) lexbuf }
   | space* nl space* '-'
       { (* Like in the doc_bol production, these two productions
            exist only to deal properly with whitespace *)
@@ -763,9 +754,16 @@ and doc_list_bol indents = parse
                 backtrack_past_newline lexbuf;
                 doc_list_bol indents lexbuf
               end
-        | Before -> Output.stop_item ();
-                    backtrack_past_newline lexbuf;
-                    doc_bol lexbuf
+        | Before -> 
+        (* Here we were at the beginning of a line, and it was blank.
+           The next line started before any list items.  So: insert
+           a paragraph for the empty line, rewind to whatever's just
+           after the newline, then toss over to doc_bol for whatever
+           comes next. *)
+            Output.stop_item ();
+            Output.paragraph ();
+            backtrack_past_newline lexbuf;
+            doc_bol lexbuf
 
       }
   | space* _
@@ -774,7 +772,10 @@ and doc_list_bol indents = parse
         | Before -> Output.stop_item (); backtrack lexbuf;
                     doc_bol lexbuf
         | StartLevel n ->
-            Output.reach_item_level (n-1);
+            (if n = 1 then
+               Output.stop_item ()
+             else
+               Output.reach_item_level (n-1));
             backtrack lexbuf;
             doc (Some (take (n-1) indents)) lexbuf
         | InLevel (n,_) ->
@@ -802,6 +803,8 @@ and doc indents = parse
 		  | Some ls -> doc_list_bol ls lexbuf
 		  | None -> doc_bol lexbuf
 		else doc indents lexbuf)}
+  | "[[[" nl
+      { inf_rules indents lexbuf }
   | "[]"
       { Output.proofbox (); doc indents lexbuf }
   | "["
@@ -817,6 +820,18 @@ and doc indents = parse
         let eol = comment lexbuf in
           if eol then bol_parse lexbuf else doc indents lexbuf
       }
+  | '*'* "*)" space_nl* "(**"
+      {(match indents with
+        | Some _ -> Output.stop_item ()
+        | None -> ());
+       (* this says - if there is a blank line between the two comments,
+          insert one in the output too *)
+       let lines = List.length (Str.split_delim (Str.regexp "['\n']") 
+                                                (lexeme lexbuf))
+       in 
+         if lines > 2 then Output.paragraph ();
+       doc_bol lexbuf
+      }
   | '*'* "*)" space* nl
       { true }
   | '*'* "*)"
@@ -905,10 +920,16 @@ and escaped_coq = parse
       { Tokens.flush_sublexer();
         Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
         escaped_coq lexbuf }
-  | space
-      { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0);
-        escaped_coq lexbuf }
-  | _
+  | space_nl*
+      { let str = lexeme lexbuf in
+          Tokens.flush_sublexer();
+          (if !Cdglobals.inline_notmono then () 
+                                        else Output.end_inline_coq ()); 
+          String.iter Output.char str; 
+          (if !Cdglobals.inline_notmono then () 
+                                        else Output.start_inline_coq ());
+          escaped_coq lexbuf }
+  | _ 
       { Output.sublexer (lexeme_char lexbuf 0) (lexeme_start lexbuf);
         escaped_coq lexbuf }
 
@@ -1135,6 +1156,71 @@ and printing_token_body = parse
   | _   { Buffer.add_string token_buffer (lexeme lexbuf);
 	  printing_token_body lexbuf }
 
+(*s These handle inference rules, parsing the body segments of things
+    enclosed in [[[  ]]] brackets *)
+and inf_rules indents = parse
+  | space* nl     (* blank line, before or between definitions *)
+      { inf_rules indents lexbuf }
+  | "]]]" nl      (* end of the inference rules block *)
+      { match indents with
+        | Some ls -> doc_list_bol ls lexbuf
+        | None -> doc_bol lexbuf }
+  | _ 
+      { backtrack lexbuf;  (* anything else must be the first line in a rule *)
+        inf_rules_assumptions indents [] lexbuf}
+
+(* The inference rule parsing just collects the inference rule and then
+   calls the output function once, instead of doing things incrementally
+   like the rest of the lexer.  If only there were a real parsing phase...
+*)
+and inf_rules_assumptions indents assumptions = parse
+  | space* "---" '-'* [^ '\n']* nl (* hit the horizontal line *)
+      { let line = lexeme lexbuf in
+        let (spaces,_) = count_spaces line in
+        let dashes_and_name = 
+               cut_head_tail_spaces (String.sub line 0 (String.length line - 1))
+        in
+        let ldn = String.length dashes_and_name in
+        let (dashes,name) = 
+          try (let i = String.index dashes_and_name ' ' in
+               let d = String.sub dashes_and_name 0 i in
+               let n = cut_head_tail_spaces 
+                        (String.sub dashes_and_name (i+1) (ldn-i-1))
+               in
+                 (d, Some n))
+          with _ -> (dashes_and_name, None)
+            
+        in
+          inf_rules_conclusion indents (List.rev assumptions) 
+                               (spaces, dashes, name) [] lexbuf }
+  | [^ '\n']* nl (* if it's not the horizontal line, it's an assumption *)
+      { let line = lexeme lexbuf in
+        let (spaces,_) = count_spaces line in
+        let assumption = cut_head_tail_spaces 
+                            (String.sub line 0 (String.length line - 1))
+        in
+          inf_rules_assumptions indents ((spaces,assumption)::assumptions)
+                                lexbuf }
+
+(*s The conclusion is required to come immediately after the
+    horizontal bar.  It is allowed to contain multiple lines of
+    text, like the assumptions.  The conclusion ends when we spot a
+    blank line or a ']]]'. *)
+and inf_rules_conclusion indents assumptions middle conclusions = parse
+  | space* nl | space* "]]]" nl (* end of conclusions. *)
+      { backtrack lexbuf;
+        Output.inf_rule assumptions middle (List.rev conclusions);
+        inf_rules indents lexbuf }
+  | space* [^ '\n']+ nl (* this is a line in the conclusion *)
+      { let line = lexeme lexbuf in
+        let (spaces,_) = count_spaces line in
+        let conc = cut_head_tail_spaces (String.sub line 0 
+                                                    (String.length line - 1))
+        in
+          inf_rules_conclusion indents assumptions middle 
+                               ((spaces,conc) :: conclusions) lexbuf
+      }
+
 (*s A small scanner to support the chapter subtitle feature *)
 and st_start m = parse
   | "(*" "*"+ space+ "*" space+
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
index a2cb995e..c8e7770a 100644
--- a/tools/coqdoc/index.ml
+++ b/tools/coqdoc/index.ml
@@ -1,14 +1,11 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: index.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Filename
 open Lexing
 open Printf
@@ -238,18 +235,20 @@ let type_name = function
 let prepare_entry s = function
   | Notation ->
       (* We decode the encoding done in Dumpglob.cook_notation of coqtop *)
-      (* Encoded notations have the form section:sc:x_'++'_x where: *)
-      (* - the section, if any, ends with a "." *)
-      (* - the scope can be empty *)
-      (* - tokens are separated with "_" *)
-      (* - non-terminal symbols are conventionally represented by "x" *)
-      (* - terminals are enclosed within simple quotes *)
-      (* - existing simple quotes (that necessarily are parts of terminals) *)
-      (*   are doubled *)
+      (* Encoded notations have the form section:sc:x_'++'_x where:      *)
+      (* - the section, if any, ends with a "."                          *)
+      (* - the scope can be empty                                        *)
+      (* - tokens are separated with "_"                                 *)
+      (* - non-terminal symbols are conventionally represented by "x"    *)
+      (* - terminals are enclosed within simple quotes                   *)
+      (* - existing simple quotes (that necessarily are parts of         *)
+      (*   terminals) are doubled                                        *)
       (*   (as a consequence, when a terminal contains "_" or "x", these *)
       (*   necessarily appear enclosed within non-doubled simple quotes) *)
-      (*   Example: "x ' %x _% y %'x %'_' z" is encoded as *)
-      (*     "x_''''_'%x'_'_%'_x_'%''x'_'%''_'''_x" *)
+      (* - non-printable characters < 32 are left encoded so that they   *)
+      (*   are human-readable in index files                             *)
+      (* Example: "x ' %x _% y %'x %'_' z" is encoded as                 *)
+      (*   "x_''''_'%x'_'_%'_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
@@ -268,10 +267,10 @@ let prepare_entry s = function
 	  | _ -> assert false)
 	end
 	else
-	  if s.[!j] = '\'' then begin
-	    if (!j = l || s.[!j+1] <> '\'') then quoted := false
-	    else (ntn.[!k] <- s.[!j]; incr k; incr j)
-	  end else begin
+	  if s.[!j] = '\'' then
+	    if (!j = l || s.[!j+1] = '_') then quoted := false
+	    else (incr j; ntn.[!k] <- s.[!j]; incr k)
+	  else begin
 	    ntn.[!k] <- s.[!j];
 	    incr k
 	  end;
@@ -324,8 +323,27 @@ let type_of_string = function
   | "sec" -> Section
   | s -> raise (Invalid_argument ("type_of_string:" ^ s))
 
-let read_glob f =
+let ill_formed_glob_file f =
+  eprintf "Warning: ill-formed file %s (links will not be available)\n" f
+let outdated_glob_file f =
+  eprintf "Warning: %s not consistent with corresponding .v file (links will not be available)\n" f
+
+let correct_file vfile f c =
+  let s = input_line c in
+  if String.length s < 7 || String.sub s 0 7 <> "DIGEST " then
+    (ill_formed_glob_file f; false)
+  else
+    let s = String.sub s 7 (String.length s - 7) in
+    match vfile, s with
+    | None, "NO" -> true
+    | Some _, "NO" -> ill_formed_glob_file f; false
+    | None, _ -> ill_formed_glob_file f; false
+    | Some vfile, s ->
+        s = Digest.to_hex (Digest.file vfile) || (outdated_glob_file f; false)
+
+let read_glob vfile f =
   let c = open_in f in
+  if correct_file vfile f c then
   let cur_mod = ref "" in
   try
     while true do
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index a009e9dc..bb775d26 100644
--- a/tools/coqdoc/index.mli
+++ b/tools/coqdoc/index.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: index.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Cdglobals
 
 type loc = int
@@ -54,7 +52,7 @@ val add_external_library : string -> coq_module -> unit
 
 (*s Read globalizations from a file (produced by coqc -dump-glob) *)
 
-val read_glob : string -> unit
+val read_glob : Digest.t option -> string -> unit
 
 (*s Indexes *)
 
diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
index 23dadbc1..b1303f18 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.ml
@@ -1,14 +1,11 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: main.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004:
  *  - handling of absolute filenames (function coq_module)
  *  - coq_module: chop ./// (arbitrary amount of slashes), not only "./"
@@ -53,6 +50,7 @@ let usage () =
   prerr_endline "  -p <string>          insert <string> in LaTeX preamble";
   prerr_endline "  --files-from <file>  read file names to process in <file>";
   prerr_endline "  --glob-from <file>   read globalization information from <file>";
+  prerr_endline "  --no-glob            don't use any globalization information (no links will be inserted at identifiers)";
   prerr_endline "  --quiet              quiet mode (default)";
   prerr_endline "  --verbose            verbose mode";
   prerr_endline "  --no-externals       no links to Coq standard library";
@@ -73,6 +71,7 @@ let usage () =
   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 "  --inline-notmono     use a proportional width font for inline code (possibly with a different color)";
   prerr_endline "";
   exit 1
 
@@ -107,25 +106,6 @@ let check_if_file_exists f =
   end
 
 
-(*s Manipulations of paths and path aliases *)
-
-let normalize_path p =
-  (* We use the Unix subsystem to normalize a physical path (relative
-     or absolute) and get rid of symbolic links, relative links (like
-     ./ or ../ in the middle of the path; it's tricky but it
-     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
-
-let normalize_filename f =
-  let basename = Filename.basename f in
-  let dirname = Filename.dirname f in
-  normalize_path dirname, basename
-
 (* [paths] maps a physical path to a name *)
 let paths = ref []
 
@@ -303,6 +283,9 @@ let parse () =
     | ("-lib-subtitles" | "--lib-subtitles") :: rem ->
       Cdglobals.lib_subtitles := true;
       parse_rec rem
+    | ("-inline-notmono" | "--inline-notmono") :: rem ->
+      Cdglobals.inline_notmono := true;
+      parse_rec rem
 
     | ("-latin1" | "--latin1") :: rem ->
 	Cdglobals.set_latin1 (); parse_rec rem
@@ -341,6 +324,8 @@ let parse () =
 	glob_source := GlobFile f; parse_rec rem
     | ("-glob-from" | "--glob-from") :: [] ->
 	usage ()
+    | ("-no-glob" | "--no-glob") :: rem ->
+	glob_source := NoGlob; parse_rec rem
     | ("--no-externals" | "-no-externals" | "-noexternals") :: rem ->
 	Cdglobals.externals := false; parse_rec rem
     | ("--external" | "-external") :: u :: logicalpath :: rem ->
@@ -350,7 +335,11 @@ let parse () =
     | ("--coqlib" | "-coqlib") :: [] ->
 	usage ()
     | ("--boot" | "-boot") :: rem ->
-	Cdglobals.coqlib_path := Coq_config.coqsrc; parse_rec rem
+	Cdglobals.coqlib_path := normalize_path (
+          Filename.concat
+            (Filename.dirname Sys.executable_name)
+            Filename.parent_dir_name
+        ); parse_rec rem
     | ("--coqlib_path" | "-coqlib_path") :: d :: rem ->
 	Cdglobals.coqlib_path := d; parse_rec rem
     | ("--coqlib_path" | "-coqlib_path") :: [] ->
@@ -458,13 +447,13 @@ let gen_mult_files l =
     end
       (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *)
 
-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 vfile f =
+  try Index.read_glob vfile f
+  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")
+  | Vernac_file (f,_) ->
+      read_glob_file (Some f) (Filename.chop_extension f ^ ".glob")
   | Latex_file _ -> ()
 
 let index_module = function
@@ -486,7 +475,7 @@ let produce_document l =
   (match !Cdglobals.glob_source with
     | NoGlob -> ()
     | DotGlob -> List.iter read_glob_file_of l
-    | GlobFile f -> read_glob_file f);
+    | GlobFile f -> read_glob_file None f);
   List.iter index_module l;
   match !out_to with
     | StdOut ->
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index eefcfd11..e3d5741a 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -1,14 +1,11 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Cdglobals
 open Index
 
@@ -32,7 +29,7 @@ let build_table l =
 
 let is_keyword =
   build_table
-    [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint";
+    [ "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "CoFixpoint";
       "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example";
       "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint";
       "Hypothesis"; "Hypotheses";
@@ -44,8 +41,7 @@ let is_keyword =
       "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";
-      "Boxed"; "Unboxed"; "Inline";
+      "Delimit"; "Bind"; "Open"; "Scope"; "Inline";
       "Implicit Arguments"; "Add"; "Strict";
       "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation";
       "subgoal";
@@ -182,10 +178,20 @@ module Latex = struct
 
   let push_in_preamble s = Queue.add s preamble
 
+  let utf8x_extra_support () =
+    printf "\n";
+    printf "%%Warning: tipa declares many non-standard macros used by utf8x to\n";
+    printf "%%interpret utf8 characters but extra packages might have to be added\n";
+    printf "%%(e.g. \"textgreek\" for Greek letters not already in tipa).\n";
+    printf "%%Use coqdoc's option -p to add new packages.\n";
+    printf "\\usepackage{tipa}\n";
+    printf "\n"
+
   let header () =
     if !header_trailer then begin
       printf "\\documentclass[12pt]{report}\n";
       if !inputenc != "" then printf "\\usepackage[%s]{inputenc}\n" !inputenc;
+      if !inputenc = "utf8x" then utf8x_extra_support ();
       printf "\\usepackage[T1]{fontenc}\n";
       printf "\\usepackage{fullpage}\n";
       printf "\\usepackage{coqdoc}\n";
@@ -306,8 +312,14 @@ module Latex = struct
 	  printf "\\coqdoc%s{%s}" (type_name typ) s
 
   let defref m id ty s =
-    printf "\\coqdef{"; label_ident (m ^ "." ^ id);
-    printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s
+    if ty <> Notation then
+      (printf "\\coqdef{"; label_ident (m ^ "." ^ id);
+       printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s)
+    else
+      (* Glob file still not able to say the exact extent of the definition *)
+      (* so we currently renounce to highlight the notation location *)
+      (printf "\\coqdef{"; label_ident (m ^ "." ^ id);
+       printf "}{%s}{%s}" s s)
 
   let reference s = function
     | Def (fullid,typ) ->
@@ -478,6 +490,8 @@ module Html = struct
 	end
 
   let trailer () =
+    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
@@ -489,8 +503,6 @@ module Html = struct
 	  with End_of_file -> Pervasives.close_in cin
       else
 	begin
-	  if !index && (get_module false) <> "Index" then
-	    printf "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"%s.html\">Index</a>" !index_name;
 	  printf "<hr/>This page has been generated by ";
 	  printf "<a href=\"%s\">coqdoc</a>\n" Coq_config.wwwcoq;
 	  printf "</div>\n\n</div>\n\n</body>\n</html>"
@@ -624,7 +636,7 @@ module Html = struct
 
   let rec reach_item_level n =
     if !item_level < n then begin
-      printf "<ul>\n<li>"; incr item_level;
+      printf "<ul class=\"doclist\">\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;
@@ -662,7 +674,9 @@ module Html = struct
 
   let end_code () = end_coq (); start_doc ()
 
-  let start_inline_coq () = printf "<span class=\"inlinecode\">"
+  let start_inline_coq () = 
+    if !inline_notmono then printf "<span class=\"inlinecodenm\">"
+                       else printf "<span class=\"inlinecode\">"
 
   let end_inline_coq () = printf "</span>"
 
@@ -670,7 +684,50 @@ module Html = struct
 
   let end_inline_coq_block () = end_inline_coq ()
 
-  let paragraph () = printf "\n<br/> <br/>\n"
+  let paragraph () = printf "\n<div class=\"paragraph\"> </div>\n\n" 
+
+  (* inference rules *)
+  let inf_rule assumptions (_,_,midnm) conclusions =
+    (* this first function replaces any occurance of 3 or more spaces
+       in a row with "&nbsp;"s.  We do this to the assumptions so that
+       people can put multiple rules on a line with nice formatting *)
+    let replace_spaces str =
+      let rec copy a n = match n with 0 -> [] | n -> (a :: copy a (n - 1)) in 
+      let results = Str.full_split (Str.regexp "[' '][' '][' ']+") str in
+      let strs = List.map (fun r -> match r with
+                                    | Str.Text s  -> [s]
+                                    | Str.Delim s -> 
+                                        copy "&nbsp;" (String.length s))  
+                          results
+      in
+        String.concat "" (List.concat strs)
+    in
+    let start_assumption line =
+          (printf "<tr class=\"infruleassumption\">\n";
+           printf "  <td class=\"infrule\">%s</td>\n" (replace_spaces line)) in
+    let end_assumption () =
+          (printf "  <td></td>\n";
+           printf "</td>\n") in
+    let rec print_assumptions hyps = 
+          match hyps with
+          | []                 -> start_assumption "&nbsp;&nbsp;"
+          | [(_,hyp)]          -> start_assumption hyp
+          | ((_,hyp) :: hyps') -> (start_assumption hyp;
+                                   end_assumption ();
+                                   print_assumptions hyps') in
+    printf "<center><table class=\"infrule\">\n";
+    print_assumptions assumptions;
+    printf "  <td class=\"infrulenamecol\" rowspan=\"3\">\n";
+    (match midnm with
+     | None   -> printf "    &nbsp;\n  </td>" 
+     | Some s -> printf "    %s &nbsp;\n  </td>" s);
+    printf "</tr>\n";
+    printf "<tr class=\"infrulemiddle\">\n";
+    printf "  <td class=\"infrule\"><hr /></td>\n";
+    printf "</tr>\n";
+    print_assumptions conclusions;
+    end_assumption ();
+    printf "</table></center>"
 
   let section lev f =
     let lab = new_label () in
@@ -1136,6 +1193,21 @@ let verbatim_char =
   select output_char Html.char TeXmacs.char Raw.char
 let hard_verbatim_char = output_char
 
+let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = 
+  start_verbatim ();
+  let dumb_line = 
+       function (sp,ln) -> (String.iter char ((String.make sp ' ') ^ ln);
+                            char '\n')
+  in 
+    (List.iter dumb_line assumptions;
+     dumb_line (midsp, midln ^ (match midnm with 
+                                | Some s -> " " ^ s 
+                                | None -> ""));
+     List.iter dumb_line conclusions);
+  stop_verbatim ()
+
+let inf_rule = select inf_rule_dumb Html.inf_rule inf_rule_dumb inf_rule_dumb
+
 let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index Raw.make_multi_index
 let make_index = select Latex.make_index Html.make_index TeXmacs.make_index Raw.make_index
 let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc Raw.make_toc
diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli
index dcd9072d..53d88666 100644
--- a/tools/coqdoc/output.mli
+++ b/tools/coqdoc/output.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Cdglobals
 open Index
 
@@ -80,6 +78,23 @@ val stop_latex_math : unit -> unit
 val start_verbatim : unit -> unit
 val stop_verbatim : unit -> unit
 
+(* this outputs an inference rule in one go.  You pass it the list of
+   assumptions, then the middle line info, then the conclusion (which
+   is allowed to span multiple lines).
+
+   In each case, the int is the number of spaces before the start of
+   the line's text and the string is the text of the line with the
+   leading trailing space trimmed.  For the middle rule, you can
+   also optionally provide a name.
+
+   We need the space info so that in modes where we aren't doing
+   something smart we can just format the rule verbatim like the user did
+*)
+val inf_rule :  (int * string) list
+             -> (int * string * (string option)) 
+             -> (int * string) list
+             -> unit
+
 val make_multi_index : unit -> unit
 val make_index : unit -> unit
 val make_toc : unit -> unit
diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml
index 9de39083..a228797e 100644
--- a/tools/coqdoc/tokens.ml
+++ b/tools/coqdoc/tokens.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli
index 3b756e18..6adc2d8c 100644
--- a/tools/coqdoc/tokens.mli
+++ b/tools/coqdoc/tokens.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
index 380448be..9d254684 100644
--- a/tools/coqwc.mll
+++ b/tools/coqwc.mll
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,8 +9,6 @@
 (* coqwc - counts the lines of spec, proof and comments in Coq sources
  * Copyright (C) 2003 Jean-Christophe Filliâtre *)
 
-(*i $Id: coqwc.mll 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source.
     It assumes the files to be lexically well-formed. *)
 
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
new file mode 100644
index 00000000..f2255981
--- /dev/null
+++ b/tools/fake_ide.ml
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Fake_ide : Simulate a [coqide] talking to a [coqtop -ideslave] *)
+
+exception Comment
+
+let coqtop = ref (stdin, stdout)
+
+let p = Xml_parser.make ()
+let () = Xml_parser.check_eof p false
+
+let eval_call (call:'a Ide_intf.call) =
+  prerr_endline (Ide_intf.pr_call call);
+  let xml_query = Ide_intf.of_call call in
+  Xml_utils.print_xml (snd !coqtop) xml_query;
+  flush (snd !coqtop);
+  let xml_answer = Xml_parser.parse p (Xml_parser.SChannel (fst !coqtop)) in
+  let res = Ide_intf.to_answer xml_answer in
+  prerr_endline (Ide_intf.pr_full_value call res);
+  match res with Interface.Fail _ -> exit 1 | _ -> ()
+
+let commands =
+  [ "INTERPRAWSILENT", (fun s -> eval_call (Ide_intf.interp (true,false,s)));
+    "INTERPRAW", (fun s -> eval_call (Ide_intf.interp (true,true,s)));
+    "INTERPSILENT", (fun s -> eval_call (Ide_intf.interp (false,false,s)));
+    "INTERP", (fun s -> eval_call (Ide_intf.interp (false,true,s)));
+    "REWIND", (fun s -> eval_call (Ide_intf.rewind (int_of_string s)));
+    "GOALS", (fun _ -> eval_call Ide_intf.goals);
+    "HINTS", (fun _ -> eval_call Ide_intf.hints);
+    "GETOPTIONS", (fun _ -> eval_call Ide_intf.get_options);
+    "STATUS", (fun _ -> eval_call Ide_intf.status);
+    "INLOADPATH", (fun s -> eval_call (Ide_intf.inloadpath s));
+    "MKCASES", (fun s -> eval_call (Ide_intf.mkcases s));
+    "#", (fun _ -> raise Comment);
+  ]
+
+let read_eval_print line =
+  let lline = String.length line in
+  let rec find_cmd = function
+    | [] -> prerr_endline ("Error: Unknown API Command :"^line); exit 1
+    | (cmd,fn) :: cmds ->
+      let lcmd = String.length cmd in
+      if lline >= lcmd && String.sub line 0 lcmd = cmd then
+	let arg = try String.sub line (lcmd+1) (lline-lcmd-1) with _ -> ""
+	in fn arg
+      else find_cmd cmds
+  in
+  find_cmd commands
+
+let usage () =
+  Printf.printf
+    "A fake coqide process talking to a coqtop -ideslave.\n\
+     Usage: %s [<coqtop>]\n\
+     Input syntax is one API call per line, the keyword coming first,\n\
+     with the rest of the line as string argument (e.g. INTERP Check plus.)\n\
+     Supported API keywords are:\n" (Filename.basename Sys.argv.(0));
+  List.iter (fun (s,_) -> Printf.printf "\t%s\n" s) commands;
+  exit 1
+
+let main =
+  Sys.set_signal Sys.sigpipe
+    (Sys.Signal_handle
+       (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1));
+  let coqtop_name = match Array.length Sys.argv with
+    | 1 -> "coqtop"
+    | 2 when Sys.argv.(1) <> "-help" -> Sys.argv.(1)
+    | _ -> usage ()
+  in
+  coqtop := Unix.open_process (coqtop_name^" -ideslave");
+  while true do
+    let l = try read_line () with End_of_file -> exit 0
+    in
+    try read_eval_print l
+    with
+      | Comment -> ()
+      | e ->
+	prerr_endline ("Uncaught exception" ^ Printexc.to_string e); exit 1
+  done
diff --git a/tools/gallina.ml b/tools/gallina.ml
index 161d86a8..3d7b1a2c 100644
--- a/tools/gallina.ml
+++ b/tools/gallina.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Gallina_lexer
 
 let vfiles = ref ([] : string list)
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
index 638d5936..b7a42cb6 100644
--- a/tools/gallina_lexer.mll
+++ b/tools/gallina_lexer.mll
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina_lexer.mll 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 {
  open Lexing
 
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 16ceffed..f4dab15f 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto_ind_decl.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* This file is about the automatic generation of schemes about
    decidable equality, created by Vincent Siles, Oct 2007 *)
 
@@ -79,6 +77,25 @@ let sumbool = Coqlib.build_coq_sumbool
 
 let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb
 
+let induct_on c =
+  new_induct false
+    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
+    None (None,None) None
+
+let destruct_on_using c id =
+  new_destruct false
+    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
+    None
+    (None,Some (dl,Genarg.IntroOrAndPattern [
+                                    [dl,Genarg.IntroAnonymous];
+                                    [dl,Genarg.IntroIdentifier id]]))
+    None
+
+let destruct_on c =
+  new_destruct false
+    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
+    None (None,None) None
+
 (* reconstruct the inductive with the correct deBruijn indexes *)
 let mkFullInd ind n =
   let mib = Global.lookup_mind (fst ind) in
@@ -329,13 +346,12 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q =
         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 = string_of_ppcmds
 	                              (str "Leibniz->boolean:" ++
                                        str "You have to declare the" ++
 				       str "decidability over " ++
 				       Printer.pr_constr type_of_pq ++
-				       str " first.");
-	                Format.flush_str_formatter ()
+				       str " first.")
           in
           error err_msg
     in let lb_args = Array.append (Array.append
@@ -387,13 +403,12 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
                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 = string_of_ppcmds
 	                                (str "boolean->Leibniz:" ++
                                          str "You have to declare the" ++
 			   	         str "decidability over " ++
 				         Printer.pr_constr tt1 ++
-				         str " first.");
- 	                       Format.flush_str_formatter ()
+				         str " first.")
 		 in
 		 error err_msg
                in let bl_args =
@@ -513,17 +528,9 @@ let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig =
       avoid := freshz::(!avoid);
       tclTHENSEQ [ intros_using fresh_first_intros;
                      intro_using freshn ;
-                     new_induct false [ (Tacexpr.ElimOnConstr ((mkVar freshn),
-                                        Rawterm.NoBindings))]
-                                None
-                                (None,None)
-		                None;
+                     induct_on (mkVar freshn);
                      intro_using freshm;
-                     new_destruct false [ (Tacexpr.ElimOnConstr ((mkVar freshm),
-                                    Rawterm.NoBindings))]
-                                None
-                                (None,None)
-		                None;
+                     destruct_on (mkVar freshm);
                      intro_using freshz;
                      intros;
                      tclTRY (
@@ -541,7 +548,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
                            in
                             avoid := fresht::(!avoid);
                             (new_destruct false [Tacexpr.ElimOnConstr
-                                      ((mkVar freshz,Rawterm.NoBindings))]
+                                      (Evd.empty,((mkVar freshz,Glob_term.NoBindings)))]
                                   None
                                   (None, Some (dl,Genarg.IntroOrAndPattern [[
                                     dl,Genarg.IntroIdentifier fresht;
@@ -551,7 +558,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
   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
+                    fun gls-> let gl = pf_concl gls in
                       match (kind_of_term gl) with
                       | App (c,ca) -> (
                         match (kind_of_term c) with
@@ -583,7 +590,7 @@ let make_bl_scheme mind =
   let nparrec = mib.mind_nparams_rec in
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic
+  [|Pfedit.build_by_tactic (Global.env())
     (compute_bl_goal ind lnamesparrec nparrec)
     (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|]
 
@@ -651,30 +658,22 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig =
       avoid := freshz::(!avoid);
       tclTHENSEQ [ intros_using fresh_first_intros;
                      intro_using freshn ;
-                     new_induct false [Tacexpr.ElimOnConstr
-                                    ((mkVar freshn),Rawterm.NoBindings)]
-                                None
-                                (None,None)
-		                None;
+                     induct_on (mkVar freshn);
                      intro_using freshm;
-                     new_destruct false [Tacexpr.ElimOnConstr
-                                    ((mkVar freshm),Rawterm.NoBindings)]
-                                None
-                                (None,None)
-		                None;
+                     destruct_on (mkVar freshm);
                      intro_using freshz;
                      intros;
                      tclTRY (
                       tclORELSE reflexivity (Equality.discr_tac false None)
                      );
-                     Equality.inj [] false (mkVar freshz,Rawterm.NoBindings);
+                     Equality.inj [] false (mkVar freshz,Glob_term.NoBindings);
 		     intros; simpl_in_concl;
                      Auto.default_auto;
                      tclREPEAT (
                       tclTHENSEQ [apply (andb_true_intro());
                                   simplest_split ;Auto.default_auto ]
                       );
-                      fun gls -> let gl = (gls.Evd.it).Evd.evar_concl in
+                      fun gls -> let gl = pf_concl gls in
                   (* assume the goal to be eq (eq_type ...) = true *)
                         match (kind_of_term gl) with
                           | App(c,ca) -> (match (kind_of_term ca.(1)) with
@@ -703,7 +702,7 @@ let make_lb_scheme mind =
   let nparrec = mib.mind_nparams_rec in
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic
+  [|Pfedit.build_by_tactic (Global.env())
     (compute_lb_goal ind lnamesparrec nparrec)
     (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|]
 
@@ -810,24 +809,11 @@ let compute_dec_tact ind lnamesparrec nparrec gsig =
         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);
+	  (tclTHEN (destruct_on eqbnm) 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
-	  ) [
+	  tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
 	    (* left *)
 	    tclTHENSEQ [
 	      simplest_left;
@@ -850,10 +836,10 @@ let compute_dec_tact ind lnamesparrec nparrec gsig =
                   Auto.default_auto
 		]);
 	      Equality.general_rewrite_bindings_in true
-	                      all_occurrences false
+	                      all_occurrences true false
                               (List.hd !avoid)
                               ((mkVar (List.hd (List.tl !avoid))),
-                                Rawterm.NoBindings
+                                Glob_term.NoBindings
                               )
                               true;
               Equality.discr_tac false None
@@ -870,7 +856,7 @@ let make_eq_decidability mind =
   let nparrec = mib.mind_nparams_rec in
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic
+  [|Pfedit.build_by_tactic (Global.env())
     (compute_dec_goal ind lnamesparrec nparrec)
     (compute_dec_tact ind lnamesparrec nparrec)|]
 
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
index c791da28..076a946a 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/toplevel/auto_ind_decl.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,7 +14,12 @@ open Sign
 open Proof_type
 open Ind_tables
 
-(* Build boolean equality of a block of mutual inductive types *)
+(** This file is about the automatic generation of schemes about
+    decidable equality,
+    @author Vincent Siles
+    Oct 2007 *)
+
+(** {6 Build boolean equality of a block of mutual inductive types } *)
 
 exception EqNotFound of inductive * inductive
 exception EqUnknown of string
@@ -27,7 +32,7 @@ exception NonSingletonProp of inductive
 val beq_scheme_kind : mutual scheme_kind
 val build_beq_scheme : mutual_inductive -> constr array
 
-(* Build equivalence between boolean equality and Leibniz equality *)
+(** {6 Build equivalence between boolean equality and Leibniz equality } *)
 
 val lb_scheme_kind : mutual scheme_kind
 val make_lb_scheme : mutual_inductive -> constr array
@@ -35,7 +40,7 @@ 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 *)
+(** {6 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
index 4a67ede4..9258a39f 100644
--- a/toplevel/autoinstance.ml
+++ b/toplevel/autoinstance.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
 (*i*)
 open Pp
 open Printer
@@ -181,8 +179,10 @@ 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 ce = { const_entry_body= def;
+             const_entry_secctx = None;
+	     const_entry_type=None;
+	     const_entry_opaque=false } in
   let cst = Declare.declare_constant ident
     (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in
   new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def
@@ -195,14 +195,16 @@ let declare_class_instance gr ctx params =
   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
+    {  const_entry_type = Some typ;
+       const_entry_secctx = None;
+       const_entry_body= def;
+       const_entry_opaque=false } in
   try
   let cst = Declare.declare_constant ident
     (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in
   Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst));
   new_instance_message ident typ def
-  with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str"  "++Cerrors.explain_exn e)
+  with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str"  "++Errors.print e)
 
 let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t;
   match kind_of_term t with
@@ -255,7 +257,7 @@ let gen_sort_topo l evm =
 (* 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 evm = Evarutil.nf_evar_map evm in
   let gen = gen_sort_topo gen evm in
   let (evm,gen) = List.fold_right
     (fun ev (evm,gen) ->
@@ -310,6 +312,7 @@ let end_autoinstance () =
 let _ =
   Goptions.declare_bool_option
     { Goptions.optsync=true;
+      Goptions.optdepr=false;
       Goptions.optkey=["Autoinstance"];
       Goptions.optname="automatic typeclass instance recognition";
       Goptions.optread=(fun () -> !autoinstance_opt);
diff --git a/toplevel/autoinstance.mli b/toplevel/autoinstance.mli
index b9b1e3c2..dd50cda5 100644
--- a/toplevel/autoinstance.mli
+++ b/toplevel/autoinstance.mli
@@ -1,38 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
-(*i*)
 open Term
 open Libnames
 open Typeclasses
 open Names
 open Evd
 open Sign
-(*i*)
 
-(*s Automatic detection of (some) record instances *)
+(** {6 Automatic detection of (some) record instances } *)
 
-(* What to do if we find an instance. Passed are : the reference
+(** 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)
+(** [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
+(** [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 *)
+(** 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 86057b4b..5f2c3dbb 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -1,20 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cerrors.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Pp
 open Util
 open Indtypes
 open Type_errors
 open Pretype_errors
 open Indrec
-open Lexer
 
 let print_loc loc =
   if loc = dummy_loc then
@@ -25,86 +23,37 @@ let print_loc loc =
 
 let guill s = "\""^s^"\""
 
-let where s =
-  if !Flags.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
 
 exception EvaluatedError of std_ppcmds * exn option
 
-(* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *)
-
-let rec explain_exn_default_aux anomaly_string report_fn = function
-  | Stream.Failure ->
-      hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.")
-  | Stream.Error txt ->
-      hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Token.Error txt ->
-      hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Sys_error msg ->
-      hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ())
-  | UserError(s,pps) ->
-      hov 0 (str "Error: " ++ where s ++ pps)
-  | Out_of_memory ->
-      hov 0 (str "Out of memory.")
-  | Stack_overflow ->
-      hov 0 (str "Stack overflow.")
-  | 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) ++
-      if Sys.ocaml_version = "3.06" then
-		   (str " from character " ++ int pos1 ++
-                    str " to " ++ int pos2)
-		 else
-		   (str " at line " ++ int pos1 ++
-		    str " character " ++ int pos2)
-	           ++ report_fn ())
-  | Not_found ->
-      hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ())
-  | Failure s ->
-      hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ())
-  | Invalid_argument s ->
-      hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ())
-  | Sys.Break ->
-      hov 0 (fnl () ++ str "User interrupt.")
-  | Lexer.Error Illegal_character ->
-      hov 0 (str "Syntax error: Illegal character.")
-  | Lexer.Error Unterminated_comment ->
-      hov 0 (str "Syntax error: Unterminated comment.")
-  | Lexer.Error Unterminated_string ->
-      hov 0 (str "Syntax error: Unterminated string.")
-  | Lexer.Error Undefined_token ->
-      hov 0 (str "Syntax error: Undefined token.")
-  | Lexer.Error (Bad_token s) ->
-      hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".")
-  | Stdpp.Exc_located (loc,exc) ->
+(** Registration of generic errors
+    Nota: explain_exn does NOT end with a newline anymore!
+*)
+
+let explain_exn_default = function
+  (* Basic interaction exceptions *)
+  | Stream.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ "."))
+  | Token.Error txt ->  hov 0 (str ("Syntax error: " ^ txt ^ "."))
+  | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err))
+  | Sys_error msg -> hov 0 (str ("System error: " ^ guill msg))
+  | Out_of_memory -> hov 0 (str "Out of memory.")
+  | Stack_overflow -> hov 0 (str "Stack overflow.")
+  | Timeout -> hov 0 (str "Timeout!")
+  | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.")
+  (* Meta-exceptions *)
+  | Loc.Exc_located (loc,exc) ->
       hov 0 ((if loc = dummy_loc then (mt ())
                else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
-               ++ explain_exn_default_aux anomaly_string report_fn exc)
-  | Assert_failure (s,b,e) ->
-      hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
-	       (if s <> "" then
-		 if Sys.ocaml_version = "3.06" then
-		   (str ("(file \"" ^ s ^ "\", characters ") ++
-		    int b ++ str "-" ++ int e ++ str ")")
-		 else
-		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
-		    str ", characters " ++ int e ++ str "-" ++
-		    int (e+6) ++ str ")")
-	       else
-		 (mt ())) ++
-	       report_fn ())
-  | EvaluatedError (msg,None) ->
-      msg
-  | EvaluatedError (msg,Some reraise) ->
-      msg ++ explain_exn_default_aux anomaly_string report_fn reraise
-  | reraise ->
-      hov 0 (anomaly_string () ++ str "Uncaught exception " ++
-	       str (Printexc.to_string reraise) ++ report_fn ())
+               ++ Errors.print_no_anomaly exc)
+  | EvaluatedError (msg,None) -> msg
+  | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print_no_anomaly reraise
+  (* Otherwise, not handled here *)
+  | _ -> raise Errors.Unhandled
+
+let _ = Errors.register_handler explain_exn_default
+
+
+(** Pre-explain a vernac interpretation error *)
 
 let wrap_vernac_error strm =
   EvaluatedError (hov 0 (str "Error:" ++ spc () ++ strm), None)
@@ -120,13 +69,17 @@ let rec process_vernac_interp_error = function
 	  mt() in
       wrap_vernac_error (str "Universe inconsistency" ++ msg ++ str ".")
   | TypeError(ctx,te) ->
-      wrap_vernac_error (Himsg.explain_type_error ctx te)
-  | PretypeError(ctx,te) ->
-      wrap_vernac_error (Himsg.explain_pretype_error ctx te)
+      wrap_vernac_error (Himsg.explain_type_error ctx Evd.empty te)
+  | PretypeError(ctx,sigma,te) ->
+      wrap_vernac_error (Himsg.explain_pretype_error ctx sigma te)
   | Typeclasses_errors.TypeClassError(env, te) ->
       wrap_vernac_error (Himsg.explain_typeclass_error env te)
   | InductiveError e ->
       wrap_vernac_error (Himsg.explain_inductive_error e)
+  | Modops.ModuleTypingError e ->
+      wrap_vernac_error (Himsg.explain_module_error e)
+  | Modintern.ModuleInternalizationError e ->
+      wrap_vernac_error (Himsg.explain_module_internalization_error e)
   | RecursionSchemeError e ->
       wrap_vernac_error (Himsg.explain_recursion_scheme_error e)
   | Cases.PatternMatchingError (env,e) ->
@@ -145,10 +98,10 @@ let rec process_vernac_interp_error = function
         (str "No constant of this name:" ++ spc () ++
          Libnames.pr_qualid q ++ str ".")
   | Refiner.FailError (i,s) ->
-      EvaluatedError (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")."),
-                None)
+      wrap_vernac_error
+	(str "Tactic failure" ++
+           (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++
+           if i=0 then str "." else str " (level " ++ int i ++ str").")
   | AlreadyDeclared msg ->
       wrap_vernac_error (msg ++ str ".")
   | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () ->
@@ -156,32 +109,13 @@ let rec process_vernac_interp_error = function
   | Proof_type.LtacLocated (s,exc) ->
       EvaluatedError (hov 0 (Himsg.explain_ltac_call_trace s ++ fnl()),
         Some (process_vernac_interp_error exc))
-  | Stdpp.Exc_located (loc,exc) ->
-      Stdpp.Exc_located (loc,process_vernac_interp_error exc)
+  | Loc.Exc_located (loc,exc) ->
+      Loc.Exc_located (loc,process_vernac_interp_error exc)
   | exc ->
       exc
 
-let anomaly_string () = str "Anomaly: "
-
-let report () = (str "." ++ spc () ++ str "Please report.")
-
-let explain_exn_default =
-  explain_exn_default_aux anomaly_string report
-
-let raise_if_debug e =
-  if !Flags.debug then raise e
-
 let _ = Tactic_debug.explain_logic_error :=
-  (fun e -> explain_exn_default (process_vernac_interp_error e))
+  (fun e -> Errors.print (process_vernac_interp_error e))
 
 let _ = Tactic_debug.explain_logic_error_no_anomaly :=
-  (fun e ->
-    explain_exn_default_aux (fun () -> mt()) (fun () -> str ".")
-      (process_vernac_interp_error e))
-
-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
+  (fun e -> Errors.print_no_report (process_vernac_interp_error e))
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index e1f7c035..da9d3590 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -1,35 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cerrors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
-(*i*)
 
-(* Error report. *)
+(** Error report. *)
 
 val print_loc : loc -> std_ppcmds
 
-val explain_exn : exn -> std_ppcmds
-
-(** Precompute errors raised during vernac interpretation *)
-
-val explain_exn_no_anomaly : exn -> std_ppcmds
-
 (** Pre-explain a vernac interpretation error *)
 
 val process_vernac_interp_error : exn -> exn
 
-(** For debugging purpose (?), the explain function can be twicked *)
+(** General explain function. Should not be used directly now,
+    see instead function [Errors.print] and variants *)
 
-val explain_exn_function : (exn -> std_ppcmds) ref
 val explain_exn_default : exn -> std_ppcmds
 
-val raise_if_debug : exn -> unit
diff --git a/toplevel/class.ml b/toplevel/class.ml
index 09ce84e0..ebaa19b6 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: class.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Names
@@ -94,7 +92,9 @@ let check_target clt = function
 let uniform_cond nargs lt =
   let rec aux = function
     | (0,[]) -> true
-    | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l))
+    | (n,t::l) ->
+      let t = strip_outer_cast t in
+      isRel t && destRel t = n && aux ((n-1),l)
     | _ -> false
   in
   aux (nargs,lt)
@@ -126,7 +126,7 @@ let get_source lp source =
 	let (cl1,lv1) =
           match lp with
 	    | [] -> raise Not_found
-            | t1::_ -> find_class_type (Global.env()) Evd.empty t1
+            | t1::_ -> find_class_type Evd.empty t1
         in
 	(cl1,lv1,1)
     | Some cl ->
@@ -134,7 +134,7 @@ let get_source lp source =
 	  | [] -> raise Not_found
 	  | t1::lt ->
 	      try
-		let cl1,lv1 = find_class_type (Global.env()) Evd.empty t1 in
+		let cl1,lv1 = find_class_type Evd.empty t1 in
 		if cl = cl1 then cl1,lv1,(List.length lt+1)
 		else raise Not_found
               with Not_found -> aux lt
@@ -144,7 +144,7 @@ let get_target t ind =
   if (ind > 1) then
     CL_FUN
   else
-    fst (find_class_type (Global.env()) Evd.empty t)
+    fst (find_class_type Evd.empty t)
 
 let prods_of t =
   let rec aux acc d = match kind_of_term d with
@@ -212,16 +212,16 @@ let build_id_coercion idf_opt source =
     match idf_opt with
       | Some idf -> idf
       | None ->
-	  let cl,_ = find_class_type (Global.env()) Evd.empty t in
+	  let cl,_ = find_class_type Evd.empty t in
 	  id_of_string ("Id_"^(ident_key_of_class source)^"_"^
                         (ident_key_of_class cl))
   in
   let constr_entry = (* Cast is necessary to express [val_f] is identity *)
     DefinitionEntry
       { const_entry_body = mkCast (val_f, DEFAULTcast, typ_f);
+        const_entry_secctx = None;
 	const_entry_type = Some typ_f;
-        const_entry_opaque = false;
-	const_entry_boxed = Flags.boxed_definitions()} in
+        const_entry_opaque = false } in
   let kn = declare_constant idf (constr_entry,IsDefinition IdentityCoercion) in
   ConstRef kn
 
@@ -266,7 +266,7 @@ let add_new_coercion_core coef stre source target isid =
   check_arity cls;
   check_arity clt;
   let stre' = get_strength stre coef cls clt in
-  declare_coercion coef stre' isid cls clt (List.length lvs)
+  declare_coercion coef stre' ~isid ~src:cls ~target:clt ~params:(List.length lvs)
 
 let try_add_new_coercion_core ref b c d e =
   try add_new_coercion_core ref b c d e
diff --git a/toplevel/class.mli b/toplevel/class.mli
index b05f38e7..2cc8c453 100644
--- a/toplevel/class.mli
+++ b/toplevel/class.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: class.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Classops
@@ -16,31 +13,30 @@ open Declare
 open Libnames
 open Decl_kinds
 open Nametab
-(*i*)
 
-(* Classes and coercions. *)
+(** Classes and coercions. *)
 
-(* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
+(** [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 ->
   source:cl_typ -> target:cl_typ ->  unit
 
-(* [try_add_new_coercion ref s] declares [ref], assumed to be of type
+(** [try_add_new_coercion ref s] declares [ref], assumed to be of type
    [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
 val try_add_new_coercion : global_reference -> locality -> unit
 
-(* [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
+(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
    transparent constant which unfolds to some class [tg]; it declares
    an identity coercion from [cst] to [tg], named something like
    ["Id_cst_tg"] *)
 val try_add_new_coercion_subclass : cl_typ -> locality -> unit
 
-(* [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
+(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
    from [src] to [tg] where the target is inferred from the type of [ref] *)
 val try_add_new_coercion_with_source : global_reference -> locality ->
   source:cl_typ -> unit
 
-(* [try_add_new_identity_coercion id s src tg] enriches the
+(** [try_add_new_identity_coercion id s src tg] enriches the
    environment with a new definition of name [id] declared as an
    identity coercion from [src] to [tg] *)
 val try_add_new_identity_coercion : identifier -> locality ->
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index 28c1ab75..1e83e4b8 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -1,19 +1,15 @@
-(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classes.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Names
 open Decl_kinds
 open Term
-open Termops
 open Sign
 open Entries
 open Evd
@@ -25,7 +21,7 @@ open Typeclasses_errors
 open Typeclasses
 open Libnames
 open Constrintern
-open Rawterm
+open Glob_term
 open Topconstr
 (*i*)
 
@@ -34,18 +30,21 @@ open Entries
 
 let typeclasses_db = "typeclass_instances"
 
-let set_typeclass_transparency c b = 
-  Auto.add_hints false [typeclasses_db] 
+let set_typeclass_transparency c local b = 
+  Auto.add_hints local [typeclasses_db] 
     (Auto.HintsTransparencyEntry ([c], b))
     
 let _ =
   Typeclasses.register_add_instance_hint
-    (fun inst pri ->
+    (fun inst local pri ->
+     let path = try Auto.PathHints [global_of_constr inst] with _ -> Auto.PathAny in
       Flags.silently (fun () ->
-	Auto.add_hints false [typeclasses_db]
+	Auto.add_hints local [typeclasses_db]
 	  (Auto.HintsResolveEntry
-	      [pri, false, constr_of_global inst])) ());
-  Typeclasses.register_set_typeclass_transparency set_typeclass_transparency
+	     [pri, false, path, inst])) ());
+  Typeclasses.register_set_typeclass_transparency set_typeclass_transparency;
+  Typeclasses.register_classes_transparent_state 
+    (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db))
     
 let declare_class g =
   match global g with
@@ -54,12 +53,13 @@ let declare_class g =
   | _ -> user_err_loc (loc_of_reference g, "declare_class", 
 		      Pp.str"Unsupported class type, only constants and inductives are allowed")
     
-let declare_instance glob g =
+(** TODO: add subinstances *)
+let existing_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 c)
+      | 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.")
 
@@ -68,13 +68,6 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m
 
 type binder_list = (identifier located * bool * constr_expr) list
 
-(* Calls to interpretation functions. *)
-
-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
@@ -108,19 +101,18 @@ open Pp
 let ($$) g f = fun x -> g (f x)
 
 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 cst ~enriching:false imps;
-    Typeclasses.add_instance inst;
-    (match hook with Some h -> h cst | None -> ())
+  Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
+  Typeclasses.declare_instance pri (not global) cst;
+  (match hook with Some h -> h cst | None -> ())
 
 let declare_instance_constant k pri global imps ?hook id term termtype =
   let cdecl =
     let kind = IsDefinition Instance in
     let entry =
       { const_entry_body   = term;
+        const_entry_secctx = None;
 	const_entry_type   = Some termtype;
-	const_entry_opaque = false;
-	const_entry_boxed  = false }
+	const_entry_opaque = false }
     in DefinitionEntry entry, kind
   in
   let kn = Declare.declare_constant id cdecl in
@@ -148,8 +140,8 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
   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 ~fail_evar:false env' tclass in
+    let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in
+    let c', imps' = interp_type_evars_impls ~impls ~evdref:evars ~fail_evar:false env' tclass in
     let len = List.length ctx in
     let imps = imps @ Impargs.lift_implicits len imps' in
     let ctx', c = decompose_prod_assum c' in
@@ -190,26 +182,29 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
 	    Evarutil.nf_evar !evars t
 	in
 	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 (ConstRef cst); id
+	let cst = Declare.declare_constant ~internal:Declare.KernelSilent id
+	  (Entries.ParameterEntry 
+            (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
+	in instance_hook k None global imps ?hook (ConstRef cst); id
       end
     else
       begin
 	let props =
 	  match props with
-	  | CRecord (loc, _, fs) ->
+	  | Some (CRecord (loc, _, fs)) ->
 	      if List.length fs > List.length k.cl_props then
 		mismatched_props env' (List.map snd fs) k.cl_props;
-	      Inl fs
-	  | _ -> Inr props
+	      Some (Inl fs)
+	  | Some t -> Some (Inr t)
+	  | None -> None
 	in
 	let subst =
 	  match props with
-	  | Inr term ->
+	  | None -> if k.cl_props = [] then Some (Inl subst) else None
+	  | Some (Inr term) ->
 	      let c = interp_casted_constr_evars evars env' term cty in
-		Inr (c, subst)
-	  | Inl props ->
+		Some (Inr (c, subst))
+	  | Some (Inl props) ->
 	      let get_id =
 		function
 		  | Ident id' -> id'
@@ -223,7 +218,10 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
 			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);
+			  List.iter (fun (n, _, x) -> 
+				       if n = Name mid then
+					 Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
+			    k.cl_projs;
 			  c :: props, rest'
 		      with Not_found ->
 			(CHole (Util.dummy_loc, None) :: props), rest
@@ -233,12 +231,14 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
 		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)
+		  Some (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 ->
+	  | None -> let termtype = it_mkProd_or_LetIn cty ctx in
+	      None, termtype
+	  | Some (Inl subst) ->
 	      let subst = List.fold_left2
 		(fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
 		[] subst (k.cl_props @ snd k.cl_context)
@@ -246,26 +246,25 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
 	      let app, ty_constr = instance_constructor k subst in
 	      let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
 	      let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
-	        term, termtype
-	  | Inr (def, subst) ->
+		Some term, termtype
+	  | Some (Inr (def, subst)) ->
 	      let termtype = it_mkProd_or_LetIn cty ctx in
 	      let term = Termops.it_mkLambda_or_LetIn def ctx in
-		term, termtype
+		Some term, termtype
 	in
 	let termtype = Evarutil.nf_evar !evars termtype in
-	let term = Evarutil.nf_evar !evars term in
+	let term = Option.map (Evarutil.nf_evar !evars) term in
 	let evm = undefined_evars !evars in
 	Evarutil.check_evars env Evd.empty !evars termtype;
-	  if Evd.is_empty evm then
-	    declare_instance_constant k pri global imps ?hook id term termtype
+	  if Evd.is_empty evm && term <> None then
+	    declare_instance_constant k pri global imps ?hook id (Option.get term) termtype
 	  else begin
 	    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 () ->
 		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))
+		if term <> None then 
+		  Pfedit.by (!refine_ref (evm, Option.get term))
 		else if Flags.is_auto_intros () then
 		  Pfedit.by (Refiner.tclDO len Tactics.intro);
 		(match tac with Some tac -> Pfedit.by tac | None -> ())) ();
@@ -284,18 +283,13 @@ let named_of_rel_context l =
       l ([], [])
   in ctx
 
-let push_named_context = List.fold_right push_named
-
-let rec list_filter_map f = function
-  | [] -> []
-  | hd :: tl -> match f hd with
-    | None -> list_filter_map f tl
-    | Some x -> x :: list_filter_map f tl
-
-let context ?(hook=fun _ -> ()) l =
+let string_of_global r =
+ string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
+      
+let context l =
   let env = Global.env() in
   let evars = ref Evd.empty in
-  let (env', fullctx), impls = interp_context_evars evars env l in
+  let _, ((env', fullctx), impls) = interp_context_evars evars env l 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;
@@ -304,13 +298,13 @@ let context ?(hook=fun _ -> ()) l =
   in
   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)
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent id
+	(ParameterEntry (None,t,None), IsAssumption Logical)
       in
 	match class_of_constr t with
-	| Some tc ->
-	    add_instance (Typeclasses.new_instance tc None false (ConstRef cst));
-	    hook (ConstRef cst)
+	| Some (rels, (tc, args) as _cl) ->
+	    add_instance (Typeclasses.new_instance tc None false (ConstRef cst))
+	    (* declare_subclasses (ConstRef cst) cl *)
 	| None -> ()
     else (
       let impl = List.exists 
@@ -318,9 +312,6 @@ let context ?(hook=fun _ -> ()) l =
 	   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))
+	  [] impl (* implicit *) None (* inline *) (dummy_loc, id))
   in List.iter fn (List.rev ctx)
-	
+       
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index 69e4dd8b..68a93a74 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Decl_kinds
 open Term
@@ -22,59 +19,56 @@ open Util
 open Typeclasses
 open Implicit_quantifiers
 open Libnames
-(*i*)
 
-(* Errors *)
+(** Errors *)
 
 val mismatched_params : env -> constr_expr list -> rel_context -> 'a
 
 val mismatched_props : env -> constr_expr list -> rel_context -> 'a
 
-(* Post-hoc class declaration. *)
+(** Post-hoc class declaration. *)
 
 val declare_class : reference -> unit
 
-(* Instance declaration *)
+(** Instance declaration *)
 
-val declare_instance : bool -> reference -> unit
+val existing_instance : bool -> reference -> unit
 
 val declare_instance_constant :
   typeclass ->
-  int option -> (* priority *)
-  bool -> (* globality *)
-  Impargs.manual_explicitation list -> (* implicits *)
+  int option -> (** priority *)
+  bool -> (** globality *)
+  Impargs.manual_explicitation list -> (** implicits *)
   ?hook:(Libnames.global_reference -> unit) ->
-  identifier -> (* name *)
-  Term.constr -> (* body *)
-  Term.types -> (* type *)
+  identifier -> (** name *)
+  Term.constr -> (** body *)
+  Term.types -> (** type *)
   Names.identifier
 
 val new_instance :
-  ?abstract:bool -> (* Not abstract by default. *)
-  ?global:bool -> (* Not global by default. *)
+  ?abstract:bool -> (** Not abstract by default. *)
+  ?global:bool -> (** Not global by default. *)
   local_binder list ->
   typeclass_constraint ->
-  constr_expr ->
+  constr_expr option ->
   ?generalize:bool ->
   ?tac:Proof_type.tactic  ->
   ?hook:(Libnames.global_reference -> unit) ->
   int option ->
   identifier
 
-(* Setting opacity *)
+(** Setting opacity *)
 
-val set_typeclass_transparency : evaluable_global_reference -> bool -> unit
+val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit
 
-(* For generation on names based on classes only *)
+(** 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) ->
-  local_binder list -> unit
+val context : local_binder list -> unit
 
-(* Forward ref for refine *)
+(** Forward ref for refine *)
 
 val refine_ref : (open_constr -> Proof_type.tactic) ref
-
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 1112ac6d..eca53ae7 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Flags
@@ -64,35 +62,36 @@ let red_constant_entry n ce = function
   | 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 }
+        under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body }
 
-let interp_definition boxed bl red_option c ctypopt =
+let interp_definition bl red_option c ctypopt =
   let env = Global.env() in
   let evdref = ref Evd.empty in
-  let (env_bl, ctx), imps1 = interp_context_evars evdref env bl in
+  let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in
+  let nb_args = List.length ctx in
   let imps,ce =
     match ctypopt with
       None ->
-	let c, imps2 = interp_constr_evars_impls ~evdref ~fail_evar:false env_bl c in
+	let c, imps2 = interp_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c in
 	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
 	check_evars env Evd.empty !evdref body;
-	imps1@imps2,
+	imps1@(Impargs.lift_implicits nb_args imps2),
 	{ const_entry_body = body;
+          const_entry_secctx = None;
 	  const_entry_type = None;
-          const_entry_opaque = false;
-	  const_entry_boxed = boxed }
+          const_entry_opaque = false }
     | 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 ty, impsty = interp_type_evars_impls ~impls ~evdref ~fail_evar:false env_bl ctyp in
+	let c, imps2 = interp_casted_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c ty in
 	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
 	let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in
 	check_evars env Evd.empty !evdref body;
 	check_evars env Evd.empty !evdref typ;
-	imps1@imps2,
+	imps1@(Impargs.lift_implicits nb_args imps2),
 	{ const_entry_body = body;
+          const_entry_secctx = None;
 	  const_entry_type = Some typ;
-          const_entry_opaque = false;
-	  const_entry_boxed = boxed }
+          const_entry_opaque = false }
   in
   red_constant_entry (rel_context_length ctx) ce red_option, imps
 
@@ -115,11 +114,11 @@ let declare_definition ident (local,k) ce imps hook =
   let r = match local with
     | Local when Lib.sections_are_opened () ->
         let c =
-          SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) 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
+          Flags.if_warn msg_warning
 	    (str"Local definition " ++ pr_id ident ++
              str" is not visible from current goals");
         VarRef ident
@@ -139,10 +138,12 @@ let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) =
         if is_verbose () & Pfedit.refining () then
           msgerrnl (str"Warning: Variable " ++ pr_id ident ++
           str" is not visible from current goals");
-        VarRef ident
+	let r = VarRef ident in
+	  Typeclasses.declare_instance None true r; r
     | (Global|Local) ->
         let kn =
-          declare_constant ident (ParameterEntry (c,nl), IsAssumption kind) in
+          declare_constant ident 
+            (ParameterEntry (None,c,nl), IsAssumption kind) in
 	let gr = ConstRef kn in
 	  maybe_declare_manual_implicits false gr imps;
         assumption_message ident;
@@ -150,8 +151,10 @@ let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) =
           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
+	Typeclasses.declare_instance None false gr;
+        gr 
+  in
+    if is_coe then Class.try_add_new_coercion r local
 
 let declare_assumptions_hook = ref ignore
 let set_declare_assumptions_hook = (:=) declare_assumptions_hook
@@ -225,7 +228,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
   check_all_names_different indl;
   let env0 = Global.env() in
   let evdref = ref Evd.empty in
-  let (env_params, ctx_params), userimpls =
+  let _, ((env_params, ctx_params), userimpls) =
     interp_context_evars evdref env0 paramsl
   in
   let indnames = List.map (fun ind -> ind.ind_name) indl in
@@ -321,7 +324,7 @@ let extract_params indl =
 let extract_inductive indl =
   List.map (fun ((_,indname),_,ar,lc) -> {
     ind_name = indname;
-    ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar;
+    ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Glob_term.GType None)) ar;
     ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
   }) indl
 
@@ -335,7 +338,7 @@ let extract_mutual_inductive_declaration_components indl =
 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
-  let mind = Global.mind_of_delta (mind_of_kn kn) in
+  let mind = Global.mind_of_delta_kn kn in
   list_iter_i (fun i (indimpls, constrimpls) ->
 		   let ind = (mind,i) in
 		     Autoinstance.search_declaration (IndRef ind);
@@ -442,7 +445,7 @@ let check_mutuality env isfix fixl =
   let po = partial_order preorder in
   match List.filter (function (_,Inr _) -> true | _ -> false) po with
     | (x,Inr xge)::(y,Inr yge)::rest ->
-	if_verbose msg_warning (non_full_mutual_message x xge y yge isfix rest)
+	if_warn msg_warning (non_full_mutual_message x xge y yge isfix rest)
     | _ -> ()
 
 type structured_fixpoint_expr = {
@@ -455,8 +458,8 @@ type structured_fixpoint_expr = {
 
 let interp_fix_context evdref env isfix fix =
   let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
-  let (env', ctx), imps = interp_context_evars evdref env before in
-  let (env'', ctx'), imps' = interp_context_evars evdref env' after in
+  let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in
+  let _, ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in
   let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
     ((env'', ctx' @ ctx), imps @ imps', annot)
       
@@ -471,13 +474,13 @@ let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
 
 let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
 
-let declare_fix boxed kind f def t imps =
+let declare_fix kind f def t imps =
   let ce = {
     const_entry_body = def;
+    const_entry_secctx = None;
     const_entry_type = Some t;
-    const_entry_opaque = false;
-    const_entry_boxed = boxed
-  } in
+    const_entry_opaque = false }
+  in
   let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in
   let gr = ConstRef kn in
   Autoinstance.search_declaration (ConstRef kn);
@@ -547,7 +550,7 @@ let interp_recursive isfix fixl notations =
 let interp_fixpoint = interp_recursive true
 let interp_cofixpoint = interp_recursive false
 
-let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
+let declare_fixpoint ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
   if List.mem None fixdefs then
     (* Some bodies to define by proof *)
     let thms =
@@ -565,14 +568,14 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
     let fiximps = List.map (fun (n,r,p) -> r) 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);
+    ignore (list_map4 (declare_fix Fixpoint) fixnames fixdecls fixtypes fiximps);
     (* Declare the recursive definitions *)
     fixpoint_message (Some indexes) fixnames;
   end;
   (* Declare notations *)
   List.iter Metasyntax.add_notation_interpretation ntns
 
-let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
+let declare_cofixpoint ((fixnames,fixdefs,fixtypes),fiximps) ntns =
   if List.mem None fixdefs then
     (* Some bodies to define by proof *)
     let thms =
@@ -588,22 +591,23 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
     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 (fun (len,imps,idx) -> imps) fiximps in
-    ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps);
+    ignore (list_map4 (declare_fix CoFixpoint) fixnames fixdecls fixtypes fiximps);
     (* Declare the recursive definitions *)
     cofixpoint_message fixnames
   end;
   (* Declare notations *)
   List.iter Metasyntax.add_notation_interpretation ntns
 
-let extract_decreasing_argument = function
+let extract_decreasing_argument limit = function
   | (na,CStructRec) -> na
+  | (na,_) when not limit -> na
   | _ -> error 
       "Only structural decreasing is supported for a non-Program Fixpoint"
 
-let extract_fixpoint_components l =
+let extract_fixpoint_components limit l =
   let fixl, ntnl = List.split l in
   let fixl = List.map (fun ((_,id),ann,bl,typ,def) ->
-    let ann = extract_decreasing_argument ann in
+    let ann = extract_decreasing_argument limit ann in
       {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
   fixl, List.flatten ntnl
 
@@ -613,13 +617,13 @@ let extract_cofixpoint_components l =
     {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
   List.flatten ntnl
 
-let do_fixpoint l b =
-  let fixl,ntns = extract_fixpoint_components l in
+let do_fixpoint l =
+  let fixl,ntns = extract_fixpoint_components true l in
   let fix = interp_fixpoint fixl ntns in
   let possible_indexes =
     List.map compute_possible_guardness_evidences (snd fix) in
-  declare_fixpoint b fix possible_indexes ntns
+  declare_fixpoint fix possible_indexes ntns
 
-let do_cofixpoint l b =
+let do_cofixpoint l =
   let fixl,ntns = extract_cofixpoint_components l in
-  declare_cofixpoint b (interp_cofixpoint fixl ntns) ntns
+  declare_cofixpoint (interp_cofixpoint fixl ntns) ntns
diff --git a/toplevel/command.mli b/toplevel/command.mli
index af89b59a..8ffdbdec 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -21,45 +18,41 @@ open Decl_kinds
 open Redexpr
 open Constrintern
 open Pfedit
-(*i*)
 
-(*s This file is about the interpretation of raw commands into typed
+(** This file is about the interpretation of raw commands into typed
     ones and top-level declaration of the main Gallina objects *)
 
-(* Hooks for Pcoq *)
+(** {6 Hooks for Pcoq} *)
 
 val set_declare_definition_hook : (definition_entry -> unit) -> unit
 val get_declare_definition_hook : unit -> (definition_entry -> unit)
 val set_declare_assumptions_hook : (types -> unit) -> unit
 
-(*************************************************************************)
-(* Definitions/Let *)
+(** {6 Definitions/Let} *)
 
 val interp_definition :
-  boxed_flag -> local_binder list -> red_expr option -> constr_expr ->
-  constr_expr option -> definition_entry * manual_implicits
+  local_binder list -> red_expr option -> constr_expr ->
+  constr_expr option -> definition_entry * Impargs.manual_implicits
 
 val declare_definition : identifier -> locality * definition_object_kind ->
-  definition_entry -> manual_implicits -> declaration_hook -> unit
+  definition_entry -> Impargs.manual_implicits -> declaration_hook -> unit
 
-(*************************************************************************)
-(* Parameters/Assumptions *)
+(** {6 Parameters/Assumptions} *)
 
 val interp_assumption :
-  local_binder list -> constr_expr -> types * manual_implicits
+  local_binder list -> constr_expr -> types * Impargs.manual_implicits
 
 val declare_assumption : coercion_flag -> assumption_kind -> types ->
-  manual_implicits ->
-  bool (* implicit *) -> bool (* inline *) -> variable located -> unit
+  Impargs.manual_implicits ->
+  bool (** implicit *) -> Entries.inline -> variable located -> unit
 
 val declare_assumptions : variable located list ->
-  coercion_flag -> assumption_kind -> types -> manual_implicits ->
-  bool -> bool -> unit
+  coercion_flag -> assumption_kind -> types -> Impargs.manual_implicits ->
+  bool -> Entries.inline -> unit
 
-(*************************************************************************)
-(* Inductive and coinductive types *)
+(** {6 Inductive and coinductive types} *)
 
-(* Extracting the semantical components out of the raw syntax of mutual
+(** Extracting the semantical components out of the raw syntax of mutual
    inductive declarations *)
 
 type structured_one_inductive_expr = {
@@ -75,30 +68,29 @@ val extract_mutual_inductive_declaration_components :
   (one_inductive_expr * decl_notation list) list ->
     structured_inductive_expr * (*coercions:*) qualid list * decl_notation list
 
-(* Typing mutual inductive definitions *)
+(** Typing mutual inductive definitions *)
 
 type one_inductive_impls =
-  Impargs.manual_explicitation list (* for inds *)*
-  Impargs.manual_explicitation list list (* for constrs *)
+  Impargs.manual_implicits (** for inds *)*
+  Impargs.manual_implicits list (** for constrs *)
 
 val interp_mutual_inductive :
   structured_inductive_expr -> decl_notation list -> bool ->
     mutual_inductive_entry * one_inductive_impls list
 
-(* Registering a mutual inductive definition together with its
+(** Registering a mutual inductive definition together with its
    associated schemes *)
 
 val declare_mutual_inductive_with_eliminations :
   Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list ->
   mutual_inductive
 
-(* Entry points for the vernacular commands Inductive and CoInductive *)
+(** Entry points for the vernacular commands Inductive and CoInductive *)
 
 val do_mutual_inductive :
   (one_inductive_expr * decl_notation list) list -> bool -> unit
 
-(*************************************************************************)
-(* Fixpoints and cofixpoints *)
+(** {6 Fixpoints and cofixpoints} *)
 
 type structured_fixpoint_expr = {
   fix_name : identifier;
@@ -108,10 +100,10 @@ type structured_fixpoint_expr = {
   fix_type : constr_expr
 }
 
-(* Extracting the semantical components out of the raw syntax of
+(** Extracting the semantical components out of the raw syntax of
    (co)fixpoints declarations *)
 
-val extract_fixpoint_components :
+val extract_fixpoint_components : bool ->
   (fixpoint_expr * decl_notation list) list ->
     structured_fixpoint_expr list * decl_notation list
 
@@ -119,40 +111,40 @@ val extract_cofixpoint_components :
   (cofixpoint_expr * decl_notation list) list ->
     structured_fixpoint_expr list * decl_notation list
 
-(* Typing global fixpoints and cofixpoint_expr *)
+(** Typing global fixpoints and cofixpoint_expr *)
 
 type recursive_preentry =
   identifier list * constr option list * types list
 
 val interp_fixpoint :
   structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * (name list * manual_implicits * int option) list
+    recursive_preentry * (name list * Impargs.manual_implicits * int option) list
 
 val interp_cofixpoint :
   structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * (name list * manual_implicits * int option) list
+    recursive_preentry * (name list * Impargs.manual_implicits * int option) list
 
-(* Registering fixpoints and cofixpoints in the environment *)
+(** Registering fixpoints and cofixpoints in the environment *)
 
 val declare_fixpoint :
-  bool -> recursive_preentry * (name list * manual_implicits * int option) list -> 
+  recursive_preentry * (name list * Impargs.manual_implicits * int option) list ->
   lemma_possible_guards -> decl_notation list -> unit
 
 val declare_cofixpoint :
-  bool -> recursive_preentry * (name list * manual_implicits * int option) list ->
+  recursive_preentry * (name list * Impargs.manual_implicits * int option) list ->
     decl_notation list -> unit
 
-(* Entry points for the vernacular commands Fixpoint and CoFixpoint *)
+(** Entry points for the vernacular commands Fixpoint and CoFixpoint *)
 
 val do_fixpoint :
-  (fixpoint_expr * decl_notation list) list -> bool -> unit
+  (fixpoint_expr * decl_notation list) list -> unit
 
 val do_cofixpoint :
-  (cofixpoint_expr * decl_notation list) list -> bool -> unit
+  (cofixpoint_expr * decl_notation list) list -> unit
 
-(* Utils *)
+(** 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
+val declare_fix : definition_object_kind -> identifier ->
+  constr -> types -> Impargs.manual_implicits -> global_reference
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 210507e1..e4cfcb3f 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqinit.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open System
 open Toplevel
@@ -17,13 +15,13 @@ let (/) = Filename.concat
 let set_debug () = Flags.debug := true
 
 (* Loading of the ressource file.
-   rcfile is either $HOME/.coqrc.VERSION, or $HOME/.coqrc if the first one
+   rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one
   does not exist. *)
 
-let rcfile = ref (home/".coqrc")
+let rcdefaultname = "coqrc"
+let rcfile = ref ""
 let rcfile_specified = ref false
 let set_rcfile s = rcfile := s; rcfile_specified := true
-let set_rcuser s = rcfile := ("~"^s)/".coqrc"
 
 let load_rc = ref true
 let no_load_rc () = load_rc := false
@@ -35,14 +33,17 @@ let load_rcfile() =
         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
-        Vernac.load_vernac false (!rcfile^"."^Coq_config.version)
-      else if file_readable_p !rcfile then
-        Vernac.load_vernac false !rcfile
-      else ()
+      else try let inferedrc = List.find file_readable_p [
+	Envars.xdg_config_home/rcdefaultname^"."^Coq_config.version;
+	Envars.xdg_config_home/rcdefaultname;
+	System.home/"."^rcdefaultname^"."^Coq_config.version;
+	System.home/"."^rcdefaultname;
+      ] in
+        Vernac.load_vernac false inferedrc
+	with Not_found -> ()
 	(*
 	Flags.if_verbose
-	  mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^
+	  mSGNL (str ("No coqrc or coqrc."^Coq_config.version^
 			 " found. Skipping rcfile loading."))
 	*)
     with e ->
@@ -52,9 +53,9 @@ let load_rcfile() =
     Flags.if_verbose msgnl (str"Skipping rcfile loading.")
 
 (* 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])
-let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root])
+let coq_add_path unix_path s =
+  Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.id_of_string s])
+let coq_add_rec_path unix_path = Mltop.add_rec_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root])
 
 (* By the option -include -I or -R of the command line *)
 let includes = ref []
@@ -75,10 +76,12 @@ let theories_dirs_map = [
     "theories/Sets", "Sets" ;
     "theories/Structures", "Structures" ;
     "theories/Lists", "Lists" ;
+    "theories/Vectors", "Vectors" ;
     "theories/Wellfounded", "Wellfounded" ;
     "theories/Relations", "Relations" ;
     "theories/Numbers", "Numbers" ;
     "theories/QArith", "QArith" ;
+    "theories/PArith", "PArith" ;
     "theories/NArith", "NArith" ;
     "theories/ZArith", "ZArith" ;
     "theories/Arith", "Arith" ;
@@ -91,24 +94,31 @@ let theories_dirs_map = [
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
+  let xdg_dirs = Envars.xdg_dirs in
+  let coqpath = Envars.coqpath in
   let dirs = ["states";"plugins"] in
-    (* first user-contrib *)
-    if Sys.file_exists user_contrib then
-      Mltop.add_rec_path user_contrib Nameops.default_root_prefix;
-    (* then states, theories and dev *)
-    List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
-    (* developer specific directory to open *)
+    (* NOTE: These directories are searched from last to first *)
+    (* first, developer specific directory to open *)
     if Coq_config.local then coq_add_path (coqlib/"dev") "dev";
     (* 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]))
+      (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root]))
       theories_dirs_map;
+    (* then states and plugins *)
+    List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
+    (* then user-contrib *)
+    if Sys.file_exists user_contrib then
+      Mltop.add_rec_path ~unix_path:user_contrib ~coq_root:Nameops.default_root_prefix;
+    (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
+    List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) xdg_dirs;
+    (* then directories in COQPATH *)
+    List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) coqpath;
     (* then current directory *)
-    Mltop.add_path "." Nameops.default_root_prefix;
+    Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix;
     (* additional loadpath, given with -I -include -R options *)
     List.iter
-      (fun (s,alias,reci) ->
-	if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias)
+      (fun (unix_path, coq_root, reci) ->
+	if reci then Mltop.add_rec_path ~unix_path ~coq_root else Mltop.add_path ~unix_path ~coq_root)
       (List.rev !includes)
 
 let init_library_roots () =
@@ -117,9 +127,8 @@ let init_library_roots () =
 (* Initialises the Ocaml toplevel before launching it, so that it can
    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)
+    Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl)
   in
     Mltop.add_ml_dir (Envars.coqlib ());
     List.iter add_subdir
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index c0f59a56..43b1556d 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -1,19 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqinit.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Initialization. *)
+(** Initialization. *)
 
 val set_debug : unit -> unit
 
 val set_rcfile : string -> unit
-val set_rcuser : string -> unit
 
 val no_load_rc : unit -> unit
 val load_rcfile : unit -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 7887a060..76e9c2fe 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqtop.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open System
@@ -122,51 +120,19 @@ let compile_files () =
       (List.rev !compile_list)
 
 let set_compat_version = function
+  | "8.3" -> compat_version := Some V8_3
   | "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"
-
-(* Re-exec Coq in bytecode or native code if necessary. [s] is either
-   ["byte"] or ["opt"]. Notice that this is possible since the nature of
-   the toplevel has already been set in [Mltop] by the main file created
-   by coqmktop (see scripts/coqmktop.ml). *)
-
-let re_exec is_ide =
-  let s = !re_exec_version in
-  let is_native = Mltop.is_native in
-  (* Unix.readlink is not implemented on Windows architectures :-(
-     let prog =
-       try Unix.readlink "/proc/self/exe"
-       with Unix.Unix_error _ -> Sys.argv.(0) in
-  *)
-  let prog = Sys.argv.(0) in
-  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 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
-    in
-    Sys.argv.(0) <- newprog;
-    Unix.handle_unix_error (Unix.execvp newprog) Sys.argv
-  end
-
 (*s options for the virtual machine *)
 
 let boxed_val = ref false
-let boxed_def = ref false
 let use_vm = ref false
 
 let set_vm_opt () =
   Vm.set_transp_values (not !boxed_val);
-  Flags.set_boxed_definitions !boxed_def;
   Vconv.set_use_vm !use_vm
 
 (*s Parsing of the command line.
@@ -183,12 +149,13 @@ let usage () =
 
 let warning s = msg_warning (str s)
 
+let ide_slave = ref false
+let filter_opts = ref false
 
-let ide_args = ref []
-let parse_args is_ide =
+let parse_args arglist =
   let glob_opt = ref false in
   let rec parse = function
-    | [] -> ()
+    | [] -> []
     | "-with-geoproof" :: s :: rem ->
 	if s = "yes" then Coq_config.with_geoproof := true
 	else if s = "no" then Coq_config.with_geoproof := false
@@ -216,14 +183,15 @@ let parse_args is_ide =
     | "-notop" :: rem -> unset_toplevel_name (); parse rem
     | "-q" :: rem -> no_load_rc (); parse rem
 
-    | "-opt" :: rem -> set_opt(); parse rem
-    | "-byte" :: rem -> set_byte(); parse rem
+    | "-opt" :: rem -> warning "option -opt deprecated, call with .opt suffix\n"; parse rem
+    | "-byte" :: rem -> warning "option -byte deprecated, call with .byte suffix\n"; parse rem
     | "-full" :: rem -> warning "option -full deprecated\n"; parse rem
 
     | "-batch" :: rem -> set_batch_mode (); parse rem
     | "-boot" :: rem -> boot := true; no_load_rc (); parse rem
     | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem
-    | "-outputstate" :: s :: rem -> set_outputstate s; parse rem
+    | "-outputstate" :: s :: rem ->
+      Flags.load_proofs := Flags.Force; set_outputstate s; parse rem
     | "-outputstate" :: []       -> usage ()
 
     | "-nois" :: rem -> set_inputstate ""; parse rem
@@ -264,7 +232,9 @@ let parse_args is_ide =
     | "-compile-verbose" :: f :: rem -> add_compile true f;  if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem
     | "-compile-verbose" :: []       -> usage ()
 
-    | "-dont-load-proofs" :: rem -> Flags.dont_load_proofs := true; parse rem
+    | "-force-load-proofs" :: rem -> Flags.load_proofs := Flags.Force; parse rem
+    | "-lazy-load-proofs" :: rem -> Flags.load_proofs := Flags.Lazy; parse rem
+    | "-dont-load-proofs" :: rem -> Flags.load_proofs := Flags.Dont; parse rem
 
     | "-beautify" :: rem -> make_beautify true; parse rem
 
@@ -278,30 +248,28 @@ let parse_args is_ide =
 
     | "-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;
-	Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem
+    | "-emacs-U" :: rem ->
+	warning "Obsolete option \"-emacs-U\", use -emacs instead.";	
+	Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem
 
     | "-unicode" :: rem -> add_require "Utf8_core"; parse rem
 
     | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem
     | "-coqlib" :: [] -> usage ()
 
-    | "-where" :: _ -> print_endline (Envars.coqlib ()); exit 0
+    | "-where" :: _ -> print_endline (Envars.coqlib ()); exit (if !filter_opts then 2 else 0)
 
-    | ("-config"|"--config") :: _ -> Usage.print_config (); exit 0
+    | ("-config"|"--config") :: _ -> Usage.print_config (); exit (if !filter_opts then 2 else 0)
 
     | ("-quiet"|"-silent") :: rem -> Flags.make_silent true; parse rem
 
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
 
-    | ("-v"|"--version") :: _ -> Usage.version ()
+    | ("-v"|"--version") :: _ -> Usage.version (if !filter_opts then 2 else 0)
 
     | "-init-file" :: f :: rem -> set_rcfile f; parse rem
     | "-init-file" :: []       -> usage ()
 
-    | "-user" :: u :: rem -> set_rcuser u; parse rem
-    | "-user" :: []       -> usage ()
-
     | "-notactics" :: rem ->
 	warning "Obsolete option \"-notactics\".";
 	remove_top_ml (); parse rem
@@ -320,32 +288,41 @@ let parse_args is_ide =
 
     | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem
 
+    | "-ideslave" :: rem -> ide_slave := true; parse rem
+
+    | "-filteropts" :: rem -> filter_opts := true; parse rem
+
     | s :: rem ->
-	if is_ide then begin
-	  ide_args := s :: !ide_args;
-	  parse rem
-	end else begin
-	  prerr_endline ("Don't know what to do with " ^ s); usage ()
-	end
+      if !filter_opts then
+       s :: (parse rem)
+      else
+       (prerr_endline ("Don't know what to do with " ^ s); usage ())
   in
   try
-    parse (List.tl (Array.to_list Sys.argv))
+    parse arglist
   with
     | UserError(_,s) as e -> begin
 	try
 	  Stream.empty s; exit 1
 	with Stream.Failure ->
-	  msgnl (Cerrors.explain_exn e); exit 1
+	  msgnl (Errors.print e); exit 1
       end
-    | e -> begin msgnl (Cerrors.explain_exn e); exit 1 end
+    | e -> begin msgnl (Errors.print e); exit 1 end
 
-let init is_ide =
+let init arglist =
   Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
   Lib.init();
+  (* Default Proofb Mode starts with an alternative default. *)
+  Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic";
   begin
     try
-      parse_args is_ide;
-      re_exec is_ide;
+      let foreign_args = parse_args arglist in
+      if !filter_opts then
+        (print_string (String.concat "\n" foreign_args); exit 0);
+      if !ide_slave then begin
+        Flags.make_silent true;
+        Ide_slave.init_stdout ()
+      end;
       if_verbose print_header ();
       init_load_path ();
       inputstate ();
@@ -374,13 +351,14 @@ let init is_ide =
      exit 0);
   Lib.declare_initial_state ()
 
-let init_toplevel () = init false
-
-let init_ide () = init true; List.rev !ide_args
+let init_toplevel = init
 
 let start () =
-  init_toplevel ();
-  Toplevel.loop();
+  init_toplevel (List.tl (Array.to_list Sys.argv));
+  if !ide_slave then
+    Ide_slave.loop ()
+  else
+    Toplevel.loop();
   (* Initialise and launch the Ocaml toplevel *)
   Coqinit.init_ocaml_path();
   Mltop.ocaml_toploop();
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index ef730915..16d2b874 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -1,23 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqtop.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* The Coq main module. The following function [start] will parse the
+(** The Coq main module. The following function [start] will parse the
    command line, print the banner, initialize the load path, load the input
    state, load the files given on the command line, load the ressource file,
    produce the output state if any, and finally will launch [Toplevel.loop]. *)
 
-val start : unit -> unit
-
-(* [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
+val init_toplevel : string list -> unit
 
+val start : unit -> unit
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index 58122e11..bab711ea 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: discharge.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Names
 open Util
 open Sign
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index f881e8a2..f94ed6e3 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: discharge.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Sign
 open Cooking
 open Declarations
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index 62d19bea..1bd68014 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: himsg.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Flags
@@ -28,7 +26,7 @@ open Reduction
 open Cases
 open Logic
 open Printer
-open Rawterm
+open Glob_term
 open Evd
 
 let pr_lconstr c = quote (pr_lconstr c)
@@ -52,7 +50,8 @@ let explain_unbound_var env v =
   let var = pr_id v in
   str "No such section variable or assumption: " ++ var ++ str "."
 
-let explain_not_type env j =
+let explain_not_type env sigma j =
+  let j = j_nf_evar sigma j in
   let pe = pr_ne_context_of (str "In environment") env in
   let pc,pt = pr_ljudge_env env j in
   pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++
@@ -111,7 +110,8 @@ let explain_elim_arity env ind sorts c pj okinds =
     str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++
   fnl () ++ msg
 
-let explain_case_not_inductive env cj =
+let explain_case_not_inductive env sigma cj =
+  let cj = j_nf_evar sigma cj in
   let env = make_all_name_different env in
   let pc = pr_lconstr_env env cj.uj_val in
   let pct = pr_lconstr_env env cj.uj_type in
@@ -123,7 +123,8 @@ let explain_case_not_inductive env cj =
 	  str "has type" ++ brk(1,1) ++ pct ++ spc () ++
 	  str "which is not a (co-)inductive type."
 
-let explain_number_branches env cj expn =
+let explain_number_branches env sigma cj expn =
+  let cj = j_nf_evar sigma cj in
   let env = make_all_name_different env in
   let pc = pr_lconstr_env env cj.uj_val in
   let pct = pr_lconstr_env env cj.uj_type in
@@ -131,14 +132,17 @@ let explain_number_branches env cj expn =
   str "of type" ++ brk(1,1) ++ pct ++ spc () ++
   str "expects " ++  int expn ++ str " branches."
 
-let explain_ill_formed_branch env c i actty expty =
+let explain_ill_formed_branch env sigma c ci actty expty =
+  let simp t = Reduction.nf_betaiota (nf_evar sigma t) in
+  let c = nf_evar sigma c in
   let env = make_all_name_different env in
   let pc = pr_lconstr_env env c in
-  let pa = pr_lconstr_env env actty in
-  let pe = pr_lconstr_env env expty in
-  str "In pattern-matching on term" ++ brk(1,1) ++ pc ++
-  spc () ++ str "the " ++ nth (i+1) ++ str " branch has type" ++
-  brk(1,1) ++ pa ++ spc () ++
+  let pa = pr_lconstr_env env (simp actty) in
+  let pe = pr_lconstr_env env (simp expty) in
+  strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++
+  spc () ++ strbrk "the branch for constructor" ++ spc () ++
+  quote (pr_constructor env ci) ++
+  spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++
   str "which should be" ++ brk(1,1) ++ pe ++ str "."
 
 let explain_generalization env (name,var) j =
@@ -150,7 +154,9 @@ let explain_generalization env (name,var) j =
   str "it has type" ++ spc () ++ pt ++
   spc () ++ str "which should be Set, Prop or Type."
 
-let explain_actual_type env j pt =
+let explain_actual_type env sigma j pt =
+  let j = j_nf_betaiotaevar sigma j in
+  let pt = Reductionops.nf_betaiota sigma pt in
   let pe = pr_ne_context_of (str "In environment") env in
   let (pc,pct) = pr_ljudge_env env j in
   let pt = pr_lconstr_env env pt in
@@ -159,7 +165,11 @@ let explain_actual_type env j pt =
   str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++
   str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str "."
 
-let explain_cant_apply_bad_type env (n,exptyp,actualtyp) rator randl =
+let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
+  let randl = jv_nf_betaiotaevar sigma randl in
+  let exptyp = nf_evar sigma exptyp in
+  let actualtyp = Reductionops.nf_betaiota sigma actualtyp in
+  let rator = j_nf_evar sigma rator in
   let env = make_all_name_different env in
   let nargs = Array.length randl in
 (*  let pe = pr_ne_context_of (str "in environment") env in*)
@@ -181,7 +191,9 @@ let explain_cant_apply_bad_type env (n,exptyp,actualtyp) rator randl =
   str "which should be coercible to" ++ brk(1,1) ++
   pr_lconstr_env env exptyp ++ str "."
 
-let explain_cant_apply_not_functional env rator randl =
+let explain_cant_apply_not_functional env sigma rator randl =
+  let randl = jv_nf_evar sigma randl in
+  let rator = j_nf_evar sigma rator in
   let env = make_all_name_different env in
   let nargs = Array.length randl in
 (*  let pe = pr_ne_context_of (str "in environment") env in*)
@@ -200,14 +212,16 @@ let explain_cant_apply_not_functional env rator randl =
   str "cannot be applied to the " ++ str (plural nargs "term") ++ fnl () ++
   str " " ++ v 0 appl
 
-let explain_unexpected_type env actual_type expected_type =
+let explain_unexpected_type env sigma actual_type expected_type =
+  let actual_type = nf_evar sigma actual_type in
+  let expected_type = nf_evar sigma expected_type in
   let pract = pr_lconstr_env env actual_type in
   let prexp = pr_lconstr_env env expected_type in
-  str "This type is" ++ spc () ++ pract ++ spc () ++
-  str "but is expected to be" ++
-  spc () ++ prexp ++ str "."
+  str "Found type" ++ spc () ++ pract ++ spc () ++
+  str "where" ++ spc () ++ prexp ++ str " was expected."
 
-let explain_not_product env c =
+let explain_not_product env sigma c =
+  let c = nf_evar sigma c in
   let pr = pr_lconstr_env env c in
   str "The type of this term is a product" ++ spc () ++
   str "while it is expected to be" ++
@@ -229,7 +243,8 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
   | RecursionNotOnInductiveType c ->
       str "Recursive definition on" ++ spc () ++ pr_lconstr_env env c ++ spc () ++
       str "which should be an inductive type"
-  | RecursionOnIllegalTerm(j,arg,le,lt) ->
+  | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) ->
+      let arg_env = make_all_name_different arg_env in
       let called =
         match names.(j) with
             Name id -> pr_id id
@@ -247,7 +262,7 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
               prlist_with_sep pr_spc pr_db lt in
       str "Recursive call to " ++ called ++ spc () ++
       strbrk "has principal argument equal to" ++ spc () ++
-      pr_lconstr_env env arg ++ strbrk " instead of " ++ vars
+      pr_lconstr_env arg_env arg ++ strbrk " instead of " ++ vars
 
   | NotEnoughArgumentsForFixCall j ->
       let called =
@@ -274,12 +289,12 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
       str "Recursive call forbidden in the type of a recursive definition" ++
       spc () ++ pr_lconstr_env env c
   | RecCallInCaseFun c ->
-      str "Recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c
+      str "Invalid recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c
   | RecCallInCaseArg c ->
-      str "Recursive call in the argument of cases in" ++ spc () ++
+      str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++
       pr_lconstr_env env c
   | RecCallInCasePred c ->
-      str "Recursive call in the type of cases in" ++  spc () ++
+      str "Invalid recursive call in the \"return\" clause of \"match\" in" ++  spc () ++
       pr_lconstr_env env c
   | NotGuardedForm c ->
       str "Sub-expression " ++ pr_lconstr_env env c ++
@@ -295,7 +310,9 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
 	str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
     with _ -> mt ())
 
-let explain_ill_typed_rec_body env i names vdefj vargs =
+let explain_ill_typed_rec_body env sigma i names vdefj vargs =
+  let vdefj = jv_nf_evar sigma vdefj in
+  let vargs = Array.map (nf_evar sigma) vargs in
   let env = make_all_name_different env in
   let pvd,pvdt = pr_ljudge_env env (vdefj.(i)) in
   let pv = pr_lconstr_env env vargs.(i) in
@@ -305,12 +322,14 @@ let explain_ill_typed_rec_body env i names vdefj vargs =
   str "has type" ++ spc () ++ pvdt ++ spc () ++
   str "while it should be" ++ spc () ++ pv ++ str "."
 
-let explain_cant_find_case_type env c =
+let explain_cant_find_case_type env sigma c =
+  let c = nf_evar sigma c in
   let env = make_all_name_different env in
   let pe = pr_lconstr_env env c in
   str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "."
 
-let explain_occur_check env ev rhs =
+let explain_occur_check env sigma ev rhs =
+  let rhs = nf_evar sigma rhs in
   let env = make_all_name_different env in
   let id = Evd.string_of_existential ev in
   let pt = pr_lconstr_env env rhs in
@@ -354,7 +373,8 @@ let explain_hole_kind env evi = function
   | MatchingVar _ ->
       assert false
 
-let explain_not_clean env ev t k =
+let explain_not_clean env sigma ev t k =
+  let t = nf_evar sigma t in
   let env = make_all_name_different env in
   let id = Evd.string_of_existential ev in
   let var = pr_lconstr_env env t in
@@ -401,13 +421,15 @@ let explain_wrong_case_info env ind ci =
     str "was given to a pattern-matching expression on the inductive type" ++
     spc () ++ pc ++ str "."
 
-let explain_cannot_unify env m n =
+let explain_cannot_unify env sigma m n =
+  let m = nf_evar sigma m in
+  let n = nf_evar sigma n in
   let pm = pr_lconstr_env env m in
   let pn = pr_lconstr_env env n in
   str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++
   str "with" ++ brk(1,1) ++ pn ++ str "."
 
-let explain_cannot_unify_local env m n subn =
+let explain_cannot_unify_local env sigma m n subn =
   let pm = pr_lconstr_env env m in
   let pn = pr_lconstr_env env n in
   let psubn = pr_lconstr_env env subn in
@@ -449,7 +471,7 @@ let explain_non_linear_unification env m t =
   strbrk " which would require to abstract twice on " ++
   pr_lconstr_env env t ++ str "."
 
-let explain_type_error env err =
+let explain_type_error env sigma err =
   let env = make_all_name_different env in
   match err with
   | UnboundRel n ->
@@ -457,7 +479,7 @@ let explain_type_error env err =
   | UnboundVar v ->
       explain_unbound_var env v
   | NotAType j ->
-      explain_not_type env j
+      explain_not_type env sigma j
   | BadAssumption c ->
       explain_bad_assumption env c
   | ReferenceVariables id ->
@@ -465,38 +487,39 @@ let explain_type_error env err =
   | ElimArity (ind, aritylst, c, pj, okinds) ->
       explain_elim_arity env ind aritylst c pj okinds
   | CaseNotInductive cj ->
-      explain_case_not_inductive env cj
+      explain_case_not_inductive env sigma cj
   | NumberBranches (cj, n) ->
-      explain_number_branches env cj n
+      explain_number_branches env sigma cj n
   | IllFormedBranch (c, i, actty, expty) ->
-      explain_ill_formed_branch env c i actty expty
+      explain_ill_formed_branch env sigma c i actty expty
   | Generalization (nvar, c) ->
       explain_generalization env nvar c
   | ActualType (j, pt) ->
-      explain_actual_type env j pt
+      explain_actual_type env sigma j pt
   | CantApplyBadType (t, rator, randl) ->
-      explain_cant_apply_bad_type env t rator randl
+      explain_cant_apply_bad_type env sigma t rator randl
   | CantApplyNonFunctional (rator, randl) ->
-      explain_cant_apply_not_functional env rator randl
+      explain_cant_apply_not_functional env sigma rator randl
   | IllFormedRecBody (err, lna, i, fixenv, vdefj) ->
       explain_ill_formed_rec_body env err lna i fixenv vdefj
   | IllTypedRecBody (i, lna, vdefj, vargs) ->
-     explain_ill_typed_rec_body env i lna vdefj vargs
+     explain_ill_typed_rec_body env sigma i lna vdefj vargs
   | WrongCaseInfo (ind,ci) ->
       explain_wrong_case_info env ind ci
 
-let explain_pretype_error env err =
+let explain_pretype_error env sigma err =
+  let env = env_nf_betaiotaevar sigma env in
   let env = make_all_name_different env in
   match err with
-  | CantFindCaseType c -> explain_cant_find_case_type env c
-  | OccurCheck (n,c) -> explain_occur_check env n c
-  | NotClean (n,c,k) -> explain_not_clean env n c k
+  | CantFindCaseType c -> explain_cant_find_case_type env sigma c
+  | OccurCheck (n,c) -> explain_occur_check env sigma n c
+  | NotClean (n,c,k) -> explain_not_clean env sigma n c k
   | UnsolvableImplicit (evi,k,exp) -> explain_unsolvable_implicit env evi k exp
   | VarNotFound id -> explain_var_not_found env id
-  | UnexpectedType (actual,expect) -> explain_unexpected_type env actual expect
-  | NotProduct c -> explain_not_product env c
-  | CannotUnify (m,n) -> explain_cannot_unify env m n
-  | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env m n sn
+  | UnexpectedType (actual,expect) -> explain_unexpected_type env sigma actual expect
+  | NotProduct c -> explain_not_product env sigma c
+  | CannotUnify (m,n) -> explain_cannot_unify env sigma m n
+  | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn
   | CannotGeneralize ty -> explain_refiner_cannot_generalize env ty
   | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env c id
   | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n
@@ -504,6 +527,155 @@ let explain_pretype_error env err =
       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
+  | TypingError t -> explain_type_error env sigma t
+
+(* Module errors *)
+
+open Modops
+
+let explain_not_match_error = function
+  | InductiveFieldExpected _ ->
+    strbrk "an inductive definition is expected"
+  | DefinitionFieldExpected ->
+    strbrk "a definition is expected"
+  | ModuleFieldExpected ->
+    strbrk "a module is expected"
+  | ModuleTypeFieldExpected ->
+    strbrk "a module type is expected"
+  | NotConvertibleInductiveField id | NotConvertibleConstructorField id ->
+    str "types given to " ++ str (string_of_id id) ++ str " differ"
+  | NotConvertibleBodyField ->
+    str "the body of definitions differs"
+  | NotConvertibleTypeField ->
+    str "types differ"
+  | NotSameConstructorNamesField ->
+    str "constructor names differ"
+  | NotSameInductiveNameInBlockField ->
+    str "inductive types names differ"
+  | FiniteInductiveFieldExpected isfinite ->
+    str "type is expected to be " ++
+    str (if isfinite then "coinductive" else "inductive")
+  | InductiveNumbersFieldExpected n ->
+    str "number of inductive types differs"
+  | InductiveParamsNumberField n ->
+    str "inductive type has not the right number of parameters"
+  | RecordFieldExpected isrecord ->
+    str "type is expected " ++ str (if isrecord then "" else "not ") ++
+    str "to be a record"
+  | RecordProjectionsExpected nal ->
+    (if List.length nal >= 2 then str "expected projection names are "
+     else str "expected projection name is ") ++
+    pr_enum (function Name id -> str (string_of_id id) | _ -> str "_") nal
+  | NotEqualInductiveAliases ->
+    str "Aliases to inductive types do not match"
+  | NoTypeConstraintExpected ->
+    strbrk "a definition whose type is constrained can only be subtype of a definition whose type is itself constrained"
+
+let explain_signature_mismatch l spec why =
+  str "Signature components for label " ++ str (string_of_label l) ++
+  str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "."
+
+let explain_label_already_declared l =
+  str ("The label "^string_of_label l^" is already declared.")
+
+let explain_application_to_not_path _ =
+  str "Application of modules is restricted to paths."
+
+let explain_not_a_functor mtb =
+  str "Application of not a functor."
+
+let explain_incompatible_module_types mexpr1 mexpr2 =
+  str "Incompatible module types."
+
+let explain_not_equal_module_paths mp1 mp2 =
+  str "Non equal modules."
+
+let explain_no_such_label l =
+  str "No such label " ++ str (string_of_label l) ++ str "."
+
+let explain_incompatible_labels l l' =
+  str "Opening and closing labels are not the same: " ++
+  str (string_of_label l) ++ str " <> " ++ str (string_of_label l') ++ str "!"
+
+let explain_signature_expected mtb =
+  str "Signature expected."
+
+let explain_no_module_to_end () =
+  str "No open module to end."
+
+let explain_no_module_type_to_end () =
+  str "No open module type to end."
+
+let explain_not_a_module s =
+  quote (str s) ++ str " is not a module."
+
+let explain_not_a_module_type s =
+  quote (str s) ++ str " is not a module type."
+
+let explain_not_a_constant l =
+  quote (pr_label l) ++ str " is not a constant."
+
+let explain_incorrect_label_constraint l =
+  str "Incorrect constraint for label " ++
+  quote (pr_label l) ++ str "."
+
+let explain_generative_module_expected l =
+  str "The module " ++ str (string_of_label l) ++
+  strbrk " is not generative. Only components of generative modules can be changed using the \"with\" construct."
+
+let explain_non_empty_local_context = function
+  | None -> str "The local context is not empty."
+  | Some l ->
+      str "The local context of the component " ++
+      str (string_of_label l) ++ str " is not empty."
+
+let explain_label_missing l s =
+  str "The field " ++ str (string_of_label l) ++ str " is missing in "
+  ++ str s ++ str "."
+
+let explain_module_error = function
+  | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err
+  | LabelAlreadyDeclared l -> explain_label_already_declared l
+  | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr
+  | NotAFunctor mtb -> explain_not_a_functor mtb
+  | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2
+  | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2
+  | NoSuchLabel l -> explain_no_such_label l
+  | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2
+  | SignatureExpected mtb -> explain_signature_expected mtb
+  | NoModuleToEnd -> explain_no_module_to_end ()
+  | NoModuleTypeToEnd -> explain_no_module_type_to_end ()
+  | NotAModule s -> explain_not_a_module s
+  | NotAModuleType s -> explain_not_a_module_type s
+  | NotAConstant l -> explain_not_a_constant l
+  | IncorrectWithConstraint l -> explain_incorrect_label_constraint l
+  | GenerativeModuleExpected l -> explain_generative_module_expected l
+  | NonEmptyLocalContect lopt -> explain_non_empty_local_context lopt
+  | LabelMissing (l,s) -> explain_label_missing l s
+
+(* Module internalization errors *)
+
+(*
+let explain_declaration_not_path _ =
+  str "Declaration is not a path."
+
+*)
+
+let explain_not_module_nor_modtype s =
+  quote (str s) ++ str " is not a module or module type."
+
+let explain_incorrect_with_in_module () =
+  str "The syntax \"with\" is not allowed for modules."
+
+let explain_incorrect_module_application () =
+  str "Illegal application to a module type."
+
+open Modintern
+
+let explain_module_internalization_error = function
+  | NotAModuleNorModtype s -> explain_not_module_nor_modtype s
+  | IncorrectWithInModule -> explain_incorrect_with_in_module ()
+  | IncorrectModuleApplication -> explain_incorrect_module_application ()
 
 (* Typeclass errors *)
 
@@ -525,6 +697,7 @@ let explain_no_instance env (_,id) l =
     prlist_with_sep pr_spc (pr_lconstr_env env) l
 
 let pr_constraints printenv env evm =
+  let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evm) in
   let l = Evd.to_list evm in
   let (ev, evi) = List.hd l in
     if List.for_all (fun (ev', evi') ->
@@ -534,12 +707,14 @@ let pr_constraints printenv env evm =
 	(reset_with_named_context evi.evar_hyps env) in
 	(if printenv then pe ++ fnl () else mt ()) ++
 	  prlist_with_sep (fun () -> fnl ())
-	  (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l
+	  (fun (ev, evi) -> str(string_of_existential ev) ++ 
+	     str " : " ++ pr_lconstr evi.evar_concl) l ++ fnl() ++
+	  pr_evar_map_constraints evm
     else
-      pr_evar_map evm
+      pr_evar_map None evm
 
 let explain_unsatisfiable_constraints env evd constr =
-  let evm = Evarutil.nf_evars evd in
+  let evm = Evarutil.nf_evar_map evd in
   let undef = Evd.undefined_evars evm in
   match constr with
   | None ->
@@ -684,7 +859,7 @@ let error_not_allowed_case_analysis isrec kind i =
 let error_not_mutual_in_scheme ind ind' =
   if ind = ind' then
     str "The inductive type " ++ pr_inductive (Global.env()) ind ++
-    str "occurs twice."
+    str " occurs twice."
   else
     str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++
     str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++
@@ -805,7 +980,7 @@ let explain_reduction_tactic_error = function
   | Tacred.InvalidAbstraction (env,c,(env',e)) ->
       str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++
       spc () ++ str "is not well typed." ++ fnl () ++
-      explain_type_error env' e
+      explain_type_error env' Evd.empty e
 
 let explain_ltac_call_trace (nrep,last,trace,loc) =
   let calls =
@@ -831,7 +1006,7 @@ let explain_ltac_call_trace (nrep,last,trace,loc) =
 	   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) ++
+	   quote (pr_glob_constr_env (Global.env()) c) ++
 	     (if unboundvars <> [] or vars <> [] then
 		strbrk " (with " ++
 		  prlist_with_sep pr_comma
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
index e12e445c..a763472b 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: himsg.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Names
 open Indtypes
@@ -19,13 +16,12 @@ open Typeclasses_errors
 open Indrec
 open Cases
 open Logic
-(*i*)
 
-(* This module provides functions to explain the type errors. *)
+(** This module provides functions to explain the type errors. *)
 
-val explain_type_error : env -> type_error -> std_ppcmds
+val explain_type_error : env -> Evd.evar_map -> type_error -> std_ppcmds
 
-val explain_pretype_error : env -> pretype_error -> std_ppcmds
+val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds
 
 val explain_inductive_error : inductive_error -> std_ppcmds
 
@@ -44,3 +40,8 @@ val explain_reduction_tactic_error :
 val explain_ltac_call_trace :
   int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc ->
   std_ppcmds
+
+val explain_module_error : Modops.module_typing_error -> std_ppcmds
+
+val explain_module_internalization_error :
+  Modintern.module_internalization_error -> std_ppcmds
diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml
new file mode 100644
index 00000000..fc8ffa25
--- /dev/null
+++ b/toplevel/ide_intf.ml
@@ -0,0 +1,434 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Interface of calls to Coq by CoqIde *)
+
+open Xml_parser
+open Interface
+
+type xml = Xml_parser.xml
+
+(** We use phantom types and GADT to protect ourselves against wild casts *)
+
+type 'a call =
+  | Interp of raw * verbose * string
+  | Rewind of int
+  | Goal
+  | Evars
+  | Hints
+  | Status
+  | GetOptions
+  | SetOptions of (option_name * option_value) list
+  | InLoadPath of string
+  | MkCases of string
+
+(** The actual calls *)
+
+let interp (r,b,s) : string call = Interp (r,b,s)
+let rewind i : int call = Rewind i
+let goals : goals option call = Goal
+let evars : evar list option call = Evars
+let hints : (hint list * hint) option call = Hints
+let status : status call = Status
+let get_options : (option_name * option_state) list call = GetOptions
+let set_options l : unit call = SetOptions l
+let inloadpath s : bool call = InLoadPath s
+let mkcases s : string list list call = MkCases s
+
+(** * Coq answers to CoqIde *)
+
+let abstract_eval_call handler c =
+  try
+    let res = match c with
+      | Interp (r,b,s) -> Obj.magic (handler.interp (r,b,s) : string)
+      | Rewind i -> Obj.magic (handler.rewind i : int)
+      | Goal -> Obj.magic (handler.goals () : goals option)
+      | Evars -> Obj.magic (handler.evars () : evar list option)
+      | Hints -> Obj.magic (handler.hints () : (hint list * hint) option)
+      | Status -> Obj.magic (handler.status () : status)
+      | GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list)
+      | SetOptions opts -> Obj.magic (handler.set_options opts : unit)
+      | InLoadPath s -> Obj.magic (handler.inloadpath s : bool)
+      | MkCases s -> Obj.magic (handler.mkcases s : string list list)
+    in Good res
+  with e ->
+    let (l, str) = handler.handle_exn e in
+    Fail (l,str)
+
+(** * XML data marshalling *)
+
+exception Marshal_error
+
+(** Utility functions *)
+
+let massoc x l =
+  try List.assoc x l
+  with Not_found -> raise Marshal_error
+
+let constructor t c args = Element (t, ["val", c], args)
+
+let do_match constr t mf = match constr with
+| Element (s, attrs, args) ->
+  if s = t then
+    let c = massoc "val" attrs in
+    mf c args
+  else raise Marshal_error
+| _ -> raise Marshal_error
+
+let pcdata = function
+| PCData s -> s
+| _ -> raise Marshal_error
+
+let singleton = function
+| [x] -> x
+| _ -> raise Marshal_error
+
+let raw_string = function
+| [] -> ""
+| [PCData s] -> s
+| _ -> raise Marshal_error
+
+let bool_arg tag b = if b then [tag, ""] else []
+
+(** Base types *)
+
+let of_bool b =
+  if b then constructor "bool" "true" []
+  else constructor "bool" "false" []
+
+let to_bool xml = do_match xml "bool"
+  (fun s _ -> match s with
+  | "true" -> true
+  | "false" -> false
+  | _ -> raise Marshal_error)
+
+let of_list f l =
+  Element ("list", [], List.map f l)
+
+let to_list f = function
+| Element ("list", [], l) ->
+  List.map f l
+| _ -> raise Marshal_error
+
+let of_option f = function
+| None -> Element ("option", ["val", "none"], [])
+| Some x -> Element ("option", ["val", "some"], [f x])
+
+let to_option f = function
+| Element ("option", ["val", "none"], []) -> None
+| Element ("option", ["val", "some"], [x]) -> Some (f x)
+| _ -> raise Marshal_error
+
+let of_string s = Element ("string", [], [PCData s])
+
+let to_string = function
+| Element ("string", [], l) -> raw_string l
+| _ -> raise Marshal_error
+
+let of_int i = Element ("int", [], [PCData (string_of_int i)])
+
+let to_int = function
+| Element ("int", [], [PCData s]) -> int_of_string s
+| _ -> raise Marshal_error
+
+let of_pair f g (x, y) = Element ("pair", [], [f x; g y])
+
+let to_pair f g = function
+| Element ("pair", [], [x; y]) -> (f x, g y)
+| _ -> raise Marshal_error
+
+(** More elaborate types *)
+
+let of_option_value = function
+| IntValue i ->
+  constructor "option_value" "intvalue" [of_option of_int i]
+| BoolValue b ->
+  constructor "option_value" "boolvalue" [of_bool b]
+| StringValue s ->
+  constructor "option_value" "stringvalue" [of_string s]
+
+let to_option_value xml = do_match xml "option_value"
+  (fun s args -> match s with
+  | "intvalue" -> IntValue (to_option to_int (singleton args))
+  | "boolvalue" -> BoolValue (to_bool (singleton args))
+  | "stringvalue" -> StringValue (to_string (singleton args))
+  | _ -> raise Marshal_error
+  )
+
+let of_option_state s =
+  Element ("option_state", [], [
+    of_bool s.opt_sync;
+    of_bool s.opt_depr;
+    of_string s.opt_name;
+    of_option_value s.opt_value]
+  )
+
+let to_option_state = function
+| Element ("option_state", [], [sync; depr; name; value]) ->
+  {
+    opt_sync = to_bool sync;
+    opt_depr = to_bool depr;
+    opt_name = to_string name;
+    opt_value = to_option_value value;
+  }
+| _ -> raise Marshal_error
+
+let of_value f = function
+| Good x -> Element ("value", ["val", "good"], [f x])
+| Fail (loc, msg) ->
+  let loc = match loc with
+  | None -> []
+  | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)]
+  in
+  Element ("value", ["val", "fail"] @ loc, [PCData msg])
+
+let to_value f = function
+| Element ("value", attrs, l) ->
+  let ans = massoc "val" attrs in
+  if ans = "good" then Good (f (singleton l))
+  else if ans = "fail" then
+    let loc =
+      try
+        let loc_s = int_of_string (List.assoc "loc_s" attrs) in
+        let loc_e = int_of_string (List.assoc "loc_e" attrs) in
+        Some (loc_s, loc_e)
+      with _ -> None
+    in
+    let msg = raw_string l in
+    Fail (loc, msg)
+  else raise Marshal_error
+| _ -> raise Marshal_error
+
+let of_call = function
+| Interp (raw, vrb, cmd) ->
+  let flags = (bool_arg "raw" raw) @ (bool_arg "verbose" vrb) in
+  Element ("call", ("val", "interp") :: flags, [PCData cmd])
+| Rewind n ->
+  Element ("call", ("val", "rewind") :: ["steps", string_of_int n], [])
+| Goal ->
+  Element ("call", ["val", "goal"], [])
+| Evars ->
+  Element ("call", ["val", "evars"], [])
+| Hints ->
+  Element ("call", ["val", "hints"], [])
+| Status ->
+  Element ("call", ["val", "status"], [])
+| GetOptions ->
+  Element ("call", ["val", "getoptions"], [])
+| SetOptions opts ->
+  let args = List.map (of_pair (of_list of_string) of_option_value) opts in
+  Element ("call", ["val", "setoptions"], args)
+| InLoadPath file ->
+  Element ("call", ["val", "inloadpath"], [PCData file])
+| MkCases ind ->
+  Element ("call", ["val", "mkcases"], [PCData ind])
+
+let to_call = function
+| Element ("call", attrs, l) ->
+  let ans = massoc "val" attrs in
+  begin match ans with
+  | "interp" ->
+    let raw = List.mem_assoc "raw" attrs in
+    let vrb = List.mem_assoc "verbose" attrs in
+    Interp (raw, vrb, raw_string l)
+  | "rewind" ->
+    let steps = int_of_string (massoc "steps" attrs) in
+    Rewind steps
+  | "goal" -> Goal
+  | "evars" -> Evars
+  | "status" -> Status
+  | "getoptions" -> GetOptions
+  | "setoptions" ->
+    let args = List.map (to_pair (to_list to_string) to_option_value) l in
+    SetOptions args
+  | "inloadpath" -> InLoadPath (raw_string l)
+  | "mkcases" -> MkCases (raw_string l)
+  | "hints" -> Hints
+  | _ -> raise Marshal_error
+  end
+| _ -> raise Marshal_error
+
+let of_status s =
+  let of_so = of_option of_string in
+  Element ("status", [], [of_so s.status_path; of_so s.status_proofname])
+
+let to_status = function
+| Element ("status", [], [path; name]) ->
+  {
+    status_path = to_option to_string path;
+    status_proofname = to_option to_string name;
+  }
+| _ -> raise Marshal_error
+
+let of_evar s =
+  Element ("evar", [], [PCData s.evar_info])
+
+let to_evar = function
+| Element ("evar", [], data) -> { evar_info = raw_string data; }
+| _ -> raise Marshal_error
+
+let of_goal g =
+  let hyp = of_list of_string g.goal_hyp in
+  let ccl = of_string g.goal_ccl in
+  Element ("goal", [], [hyp; ccl])
+
+let to_goal = function
+| Element ("goal", [], [hyp; ccl]) ->
+  let hyp = to_list to_string hyp in
+  let ccl = to_string ccl in
+  { goal_hyp = hyp; goal_ccl = ccl }
+| _ -> raise Marshal_error
+
+let of_goals g =
+  let fg = of_list of_goal g.fg_goals in
+  let bg = of_list of_goal g.bg_goals in
+  Element ("goals", [], [fg; bg])
+
+let to_goals = function
+| Element ("goals", [], [fg; bg]) ->
+  let fg = to_list to_goal fg in
+  let bg = to_list to_goal bg in
+  { fg_goals = fg; bg_goals = bg; }
+| _ -> raise Marshal_error
+
+let of_hints =
+  let of_hint = of_list (of_pair of_string of_string) in
+  of_option (of_pair (of_list of_hint) of_hint)
+
+let of_answer (q : 'a call) (r : 'a value) =
+  let convert = match q with
+  | Interp _ -> Obj.magic (of_string : string -> xml)
+  | Rewind _ -> Obj.magic (of_int : int -> xml)
+  | Goal -> Obj.magic (of_option of_goals : goals option -> xml)
+  | Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml)
+  | Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml)
+  | Status -> Obj.magic (of_status : status -> xml)
+  | GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml)
+  | SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], []))
+  | InLoadPath _ -> Obj.magic (of_bool : bool -> xml)
+  | MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml)
+  in
+  of_value convert r
+
+let to_answer xml =
+  let rec convert elt = match elt with
+  | Element (tpe, attrs, l) ->
+    begin match tpe with
+    | "unit" -> Obj.magic ()
+    | "string" -> Obj.magic (to_string elt : string)
+    | "int" -> Obj.magic (to_int elt : int)
+    | "status" -> Obj.magic (to_status elt : status)
+    | "bool" -> Obj.magic (to_bool elt : bool)
+    | "list" -> Obj.magic (to_list convert elt : 'a list)
+    | "option" -> Obj.magic (to_option convert elt : 'a option)
+    | "pair" -> Obj.magic (to_pair convert convert elt : ('a * 'b))
+    | "goals" -> Obj.magic (to_goals elt : goals)
+    | "evar" -> Obj.magic (to_evar elt : evar)
+    | "option_value" -> Obj.magic (to_option_value elt : option_value)
+    | "option_state" -> Obj.magic (to_option_state elt : option_state)
+    | _ -> raise Marshal_error
+    end
+  | _ -> raise Marshal_error
+  in
+  to_value convert xml
+
+(** * Debug printing *)
+
+let pr_option_value = function
+| IntValue None -> "none"
+| IntValue (Some i) -> string_of_int i
+| StringValue s -> s
+| BoolValue b -> if b then "true" else "false"
+
+let rec pr_setoptions opts =
+  let map (key, v) =
+    let key = String.concat " " key in
+    key ^ " := " ^ (pr_option_value v)
+  in
+  String.concat "; " (List.map map opts)
+
+let pr_getoptions opts =
+  let map (key, s) =
+    let key = String.concat " " key in
+    Printf.sprintf "%s: sync := %b; depr := %b; name := %s; value := %s\n"
+      key s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value)
+  in
+  "\n" ^ String.concat "" (List.map map opts)
+
+let pr_call = function
+  | Interp (r,b,s) ->
+    let raw = if r then "RAW" else "" in
+    let verb = if b then "" else "SILENT" in
+    "INTERP"^raw^verb^" ["^s^"]"
+  | Rewind i -> "REWIND "^(string_of_int i)
+  | Goal -> "GOALS"
+  | Evars -> "EVARS"
+  | Hints -> "HINTS"
+  | Status -> "STATUS"
+  | GetOptions -> "GETOPTIONS"
+  | SetOptions l -> "SETOPTIONS" ^ " [" ^ pr_setoptions l ^ "]"
+  | InLoadPath s -> "INLOADPATH "^s
+  | MkCases s -> "MKCASES "^s
+
+let pr_value_gen pr = function
+  | Good v -> "GOOD " ^ pr v
+  | Fail (_,str) -> "FAIL ["^str^"]"
+
+let pr_value v = pr_value_gen (fun _ -> "") v
+
+let pr_string s = "["^s^"]"
+let pr_bool b = if b then "true" else "false"
+
+let pr_status s =
+  let path = match s.status_path with
+  | None -> "no path; "
+  | Some p -> "path = " ^ p ^ "; "
+  in
+  let name = match s.status_proofname with
+  | None -> "no proof;"
+  | Some n -> "proof = " ^ n ^ ";"
+  in
+  "Status: " ^ path ^ name
+
+let pr_mkcases l =
+  let l = List.map (String.concat " ") l in
+  "[" ^ String.concat " | " l ^ "]"
+
+let pr_goals_aux g =
+  if g.fg_goals = [] then
+    if g.bg_goals = [] then "Proof completed."
+    else Printf.sprintf "Still %i unfocused goals." (List.length g.bg_goals)
+  else
+    let pr_menu s = s in
+    let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
+      "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ pr_menu goal ^ "]"
+    in
+    String.concat " " (List.map pr_goal g.fg_goals)
+
+let pr_goals = function
+| None -> "No proof in progress."
+| Some g -> pr_goals_aux g
+
+let pr_evar ev = "[" ^ ev.evar_info ^ "]"
+
+let pr_evars = function
+| None -> "No proof in progress."
+| Some evars -> String.concat " " (List.map pr_evar evars)
+
+let pr_full_value call value =
+  match call with
+    | Interp _ -> pr_value_gen pr_string (Obj.magic value : string value)
+    | Rewind i -> pr_value_gen string_of_int (Obj.magic value : int value)
+    | Goal -> pr_value_gen pr_goals (Obj.magic value : goals option value)
+    | Evars -> pr_value_gen pr_evars (Obj.magic value : evar list option value)
+    | Hints -> pr_value value
+    | Status -> pr_value_gen pr_status (Obj.magic value : status value)
+    | GetOptions -> pr_value_gen pr_getoptions (Obj.magic value : (option_name * option_state) list value)
+    | SetOptions _ -> pr_value value
+    | InLoadPath s -> pr_value_gen pr_bool (Obj.magic value : bool value)
+    | MkCases s -> pr_value_gen pr_mkcases (Obj.magic value : string list list value)
diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli
new file mode 100644
index 00000000..69204da1
--- /dev/null
+++ b/toplevel/ide_intf.mli
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Applicative part of the interface of CoqIde calls to Coq *)
+
+open Interface
+
+type xml = Xml_parser.xml
+
+type 'a call
+
+(** Running a command (given as a string).
+    - The 1st flag indicates whether to use "raw" mode
+      (less sanity checks, no impact on the undo stack).
+      Suitable e.g. for queries, or for the Set/Unset
+      of display options that coqide performs all the time.
+    - The 2nd flag controls the verbosity.
+    - The returned string contains the messages produced
+      by this command, but not the updated goals (they are
+      to be fetch by a separated [current_goals]). *)
+val interp : raw * verbose * string -> string call
+
+(** Backtracking by at least a certain number of phrases.
+    No finished proofs will be re-opened. Instead,
+    we continue backtracking until before these proofs,
+    and answer the amount of extra backtracking performed.
+    Backtracking by more than the number of phrases already
+    interpreted successfully (and not yet undone) will fail. *)
+val rewind : int -> int call
+
+(** Fetching the list of current goals. Return [None] if no proof is in 
+    progress, [Some gl] otherwise. *)
+val goals : goals option call
+
+(** Retrieving the tactics applicable to the current goal. [None] if there is 
+    no proof in progress. *)
+val hints : (hint list * hint) option call
+
+(** The status, for instance "Ready in SomeSection, proving Foo" *)
+val status : status call
+
+(** Is a directory part of Coq's loadpath ? *)
+val inloadpath : string -> bool call
+
+(** Create a "match" template for a given inductive type.
+    For each branch of the match, we list the constructor name
+    followed by enough pattern variables. *)
+val mkcases : string -> string list list call
+
+(** Retrieve the list of unintantiated evars in the current proof. [None] if no
+    proof is in progress. *)
+val evars : evar list option call
+
+(** Retrieve the list of options of the current toplevel, together with their 
+    state. *)
+val get_options : (option_name * option_state) list call
+
+(** Set the options to the given value. Warning: this is not atomic, so whenever
+    the call fails, the option state can be messed up... This is the caller duty
+    to check that everything is correct. *)
+val set_options : (option_name * option_value) list -> unit call
+
+val abstract_eval_call : handler -> 'a call -> 'a value
+
+(** * XML data marshalling *)
+
+exception Marshal_error
+
+val of_value : ('a -> xml) -> 'a value -> xml
+val to_value : (xml -> 'a) -> xml -> 'a value
+
+val of_call : 'a call -> xml
+val to_call : xml -> 'a call
+
+val of_answer : 'a call -> 'a value -> xml
+val to_answer : xml -> 'a value
+
+(** * Debug printing *)
+
+val pr_call : 'a call -> string
+val pr_value : 'a value -> string
+val pr_full_value : 'a call -> 'a value -> string
diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml
new file mode 100644
index 00000000..42ecb75b
--- /dev/null
+++ b/toplevel/ide_slave.ml
@@ -0,0 +1,579 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Vernacexpr
+open Names
+open Compat
+open Util
+open Pp
+open Printer
+open Namegen
+
+(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
+    function and a rewind function. This specialized loop is triggered
+    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+    the only one using this mode, but we try here to be as generic as
+    possible, so this may change in the future... *)
+
+
+(** Comment the next line for displaying some more debug messages *)
+
+let prerr_endline _ = ()
+
+
+(** Signal handling: we postpone ^C during input and output phases,
+    but make it directly raise a Sys.Break during evaluation of the request. *)
+
+let catch_break = ref false
+
+let init_signal_handler () =
+  let f _ = if !catch_break then raise Sys.Break else Util.interrupt := true in
+  Sys.set_signal Sys.sigint (Sys.Signal_handle f)
+
+
+(** Redirection of standard output to a printable buffer *)
+
+let orig_stdout = ref stdout
+
+let init_stdout,read_stdout =
+  let out_buff = Buffer.create 100 in
+  let out_ft = Format.formatter_of_buffer out_buff in
+  let deep_out_ft = Format.formatter_of_buffer out_buff in
+  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
+  (fun () ->
+     flush_all ();
+     orig_stdout := Unix.out_channel_of_descr (Unix.dup Unix.stdout);
+     Unix.dup2 Unix.stderr Unix.stdout;
+     Pp_control.std_ft := out_ft;
+     Pp_control.err_ft := out_ft;
+     Pp_control.deep_ft := deep_out_ft;
+     set_binary_mode_out !orig_stdout true;
+     set_binary_mode_in stdin true;
+  ),
+  (fun () -> Format.pp_print_flush out_ft ();
+             let r = Buffer.contents out_buff in
+             Buffer.clear out_buff; r)
+
+
+(** Categories of commands *)
+
+let coqide_known_option table = List.mem table [
+  ["Printing";"Implicit"];
+  ["Printing";"Coercions"];
+  ["Printing";"Matching"];
+  ["Printing";"Synth"];
+  ["Printing";"Notations"];
+  ["Printing";"All"];
+  ["Printing";"Records"];
+  ["Printing";"Existential";"Instances"];
+  ["Printing";"Universes"]]
+
+type command_attribute =
+    NavigationCommand | QueryCommand | DebugCommand | KnownOptionCommand
+    | OtherStatePreservingCommand | GoalStartingCommand | SolveCommand
+    | ProofEndingCommand
+
+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 _ -> []
+
+  (* Syntax *)
+  | VernacTacticNotation _ -> []
+  | VernacSyntaxExtension _ -> []
+  | VernacDelimiters _ -> []
+  | VernacBindScope _ -> []
+  | VernacOpenCloseScope _ -> []
+  | VernacArgumentsScope _ -> []
+  | VernacInfix _ -> []
+  | VernacNotation _ -> []
+
+  (* Gallina *)
+  | VernacDefinition (_,_,DefineBody _,_) -> []
+  | VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand]
+  | VernacStartTheoremProof _ -> [GoalStartingCommand]
+  | VernacEndProof _ -> [ProofEndingCommand]
+  | VernacExactProof _ -> [ProofEndingCommand]
+
+  | VernacAssumption _ -> []
+  | VernacInductive _ -> []
+  | VernacFixpoint _ -> []
+  | VernacCoFixpoint _ -> []
+  | VernacScheme _ -> []
+  | VernacCombinedScheme _ -> []
+
+  (* Modules *)
+  | VernacDeclareModule _ -> []
+  | VernacDefineModule _  -> []
+  | VernacDeclareModuleType _ -> []
+  | VernacInclude _ -> []
+
+  (* Gallina extensions *)
+  | VernacBeginSection _ -> []
+  | VernacEndSegment _ -> []
+  | VernacRequire _ -> []
+  | VernacImport _ -> []
+  | VernacCanonical _ -> []
+  | VernacCoercion _ -> []
+  | VernacIdentityCoercion _ -> []
+
+  (* Type classes *)
+  | VernacInstance _ -> []
+  | VernacContext _ -> []
+  | VernacDeclareInstances _ -> []
+  | VernacDeclareClass _ -> []
+
+  (* Solving *)
+  | VernacSolve _ -> [SolveCommand]
+  | VernacSolveExistential _ -> [SolveCommand]
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom _ -> []
+  | VernacAddLoadPath _ -> []
+  | VernacRemoveLoadPath _ -> []
+  | VernacAddMLPath _ -> []
+  | VernacDeclareMLModule _ -> []
+  | VernacChdir o ->
+    (* TODO: [Chdir d] is currently not undo-able (not stored in coq state).
+       But if we register [Chdir] in the state, loading [initial.coq] will
+       wrongly cd to the compile-time directory at each coqtop launch. *)
+    if o = None then [QueryCommand] else []
+
+  (* State management *)
+  | VernacWriteState _ -> []
+  | VernacRestoreState _ -> []
+
+  (* Resetting *)
+  | VernacRemoveName _ -> [NavigationCommand]
+  | VernacResetName _ -> [NavigationCommand]
+  | VernacResetInitial -> [NavigationCommand]
+  | VernacBack _ -> [NavigationCommand]
+  | VernacBackTo _ -> [NavigationCommand]
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition _ -> []
+  | VernacCreateHintDb _ -> []
+  | VernacRemoveHints _ -> []
+  | VernacHints _ -> []
+  | VernacSyntacticDefinition _ -> []
+  | VernacDeclareImplicits _ -> []
+  | VernacArguments _ -> [] 
+  | VernacDeclareReduction _ -> []
+  | VernacReserve _ -> []
+  | VernacGeneralizable _ -> []
+  | VernacSetOpacity _ -> []
+  | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand]
+  | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) ->
+      if coqide_known_option o then [KnownOptionCommand] else []
+  | VernacSetOption _ -> []
+  | VernacRemoveOption _ -> []
+  | VernacAddOption _ -> []
+  | VernacMemOption _ -> [QueryCommand]
+
+  | VernacPrintOption _ -> [QueryCommand]
+  | VernacCheckMayEval _ -> [QueryCommand]
+  | VernacGlobalCheck _ -> [QueryCommand]
+  | VernacPrint _ -> [QueryCommand]
+  | VernacSearch _ -> [QueryCommand]
+  | VernacLocate _ -> [QueryCommand]
+
+  | VernacComments _ -> [OtherStatePreservingCommand]
+  | VernacNop -> [OtherStatePreservingCommand]
+
+  (* Proof management *)
+  | VernacGoal _ -> [GoalStartingCommand]
+
+  | VernacAbort _ -> []
+  | VernacAbortAll -> [NavigationCommand]
+  | VernacRestart -> [NavigationCommand]
+  | VernacSuspend -> [NavigationCommand]
+  | VernacResume _ -> [NavigationCommand]
+  | VernacUndo _ -> [NavigationCommand]
+  | VernacUndoTo _ -> [NavigationCommand]
+  | VernacBacktrack _ -> [NavigationCommand]
+
+  | VernacFocus _ -> [SolveCommand]
+  | VernacUnfocus -> [SolveCommand]
+  | VernacShow _ -> [OtherStatePreservingCommand]
+  | VernacCheckGuard -> [OtherStatePreservingCommand]
+  | VernacProof (None, None) -> [OtherStatePreservingCommand]
+  | VernacProof _ -> []
+
+  | VernacProofMode _ -> []
+  | VernacBullet _ -> [SolveCommand]
+  | VernacSubproof _ -> [SolveCommand]
+  | VernacEndSubproof -> [SolveCommand]
+
+  (* Toplevel control *)
+  | VernacToplevelControl _ -> []
+
+  (* Extensions *)
+  | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand]
+  | VernacExtend _ -> []
+
+let is_vernac_navigation_command com =
+  List.mem NavigationCommand (attribute_of_vernac_command com)
+
+let is_vernac_query_command com =
+  List.mem QueryCommand (attribute_of_vernac_command com)
+
+let is_vernac_known_option_command com =
+  List.mem KnownOptionCommand (attribute_of_vernac_command com)
+
+let is_vernac_debug_command com =
+  List.mem DebugCommand (attribute_of_vernac_command com)
+
+let is_vernac_goal_printing_command com =
+  let attribute = attribute_of_vernac_command com in
+  List.mem GoalStartingCommand attribute or
+    List.mem SolveCommand attribute
+
+let is_vernac_state_preserving_command com =
+  let attribute = attribute_of_vernac_command com in
+  List.mem OtherStatePreservingCommand attribute or
+    List.mem QueryCommand attribute
+
+let is_vernac_tactic_command com =
+  List.mem SolveCommand (attribute_of_vernac_command com)
+
+let is_vernac_proof_ending_command com =
+  List.mem ProofEndingCommand (attribute_of_vernac_command com)
+
+
+(** Command history stack
+
+    We maintain a stack of the past states of the system. Each
+    successfully interpreted command adds a [reset_info] element
+    to this stack, storing what were the (label / open proofs /
+    current proof depth) just _before_ the interpretation of this
+    command. A label is just an integer (cf. BackTo and Bactrack
+    vernac commands).
+*)
+
+type reset_info = { label : int; proofs : identifier list; depth : int }
+
+let com_stk = Stack.create ()
+
+let compute_reset_info () =
+  { label = Lib.current_command_label ();
+    proofs = Pfedit.get_all_proof_names ();
+    depth = max 0 (Pfedit.current_proof_depth ()) }
+
+
+(** Interpretation (cf. [Ide_intf.interp]) *)
+
+(** Check whether a command is forbidden by CoqIDE *)
+
+let coqide_cmd_checks (loc,ast) =
+  let user_error s =
+    raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s)))
+  in
+  if is_vernac_debug_command ast then
+    user_error "Debug mode not available within CoqIDE";
+  if is_vernac_navigation_command ast then
+    user_error "Use CoqIDE navigation instead";
+  if is_vernac_known_option_command ast then
+    user_error "Use CoqIDE display menu instead";
+  if is_vernac_query_command ast then
+    msgerrnl (str "Warning: query commands should not be inserted in scripts")
+
+let raw_eval_expr = Vernac.eval_expr
+
+let eval_expr loc_ast =
+  let rewind_info = compute_reset_info () in
+  raw_eval_expr loc_ast;
+  Stack.push rewind_info com_stk
+
+let interp (raw,verbosely,s) =
+  if not raw then (prerr_endline "Starting interp..."; prerr_endline s);
+  let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+  let loc_ast = Vernac.parse_sentence (pa,None) in
+  if not raw then coqide_cmd_checks loc_ast;
+  (* We run tactics silently, since we will query the goal state later.
+     Otherwise, we honor the IDE verbosity flag. *)
+  Flags.make_silent
+    (is_vernac_goal_printing_command (snd loc_ast) || not verbosely);
+  if raw then raw_eval_expr loc_ast else eval_expr loc_ast;
+  Flags.make_silent true;
+  if not raw then prerr_endline ("...Done with interp of : "^s);
+  read_stdout ()
+
+
+(** Backtracking (cf. [Ide_intf.rewind]).
+    We now rely on the [Backtrack] command just as ProofGeneral. *)
+
+let rewind count =
+  if count = 0 then 0
+  else
+    let current_proofs = Pfedit.get_all_proof_names ()
+    in
+    (* 1) First, let's pop the history stack exactly [count] times.
+       NB: Normally, the IDE will not rewind by more than the numbers
+       of already interpreted commands, hence no risk of [Stack.Empty].
+    *)
+    let initial_target =
+      for i = 1 to count - 1 do ignore (Stack.pop com_stk) done;
+      Stack.pop com_stk
+    in
+    (* 2) Backtrack by enough additional steps to avoid re-opening proofs.
+       Typically, when a Qed has been crossed, we backtrack to the proof start.
+       NB: We cannot reach the empty stack, since the oldest [reset_info]
+       in the history cannot have opened proofs.
+    *)
+    let already_opened p = List.mem p current_proofs in
+    let rec extra_back n target =
+      if List.for_all already_opened target.proofs then n,target
+      else extra_back (n+1) (Stack.pop com_stk)
+    in
+    let extra_count, target = extra_back 0 initial_target
+    in
+    (* 3) Now that [target.proofs] is a subset of the opened proofs before
+       the rewind, we simply abort the extra proofs (if any).
+       NB: It is critical here that proofs are nested in a regular way
+       (i.e. no Resume or Suspend, as enforced above). This way, we can simply
+       count the extra proofs to abort instead of taking care of their names.
+    *)
+    let naborts = List.length current_proofs - List.length target.proofs
+    in
+    (* 4) We are now ready to call [Backtrack] *)
+    prerr_endline ("Rewind to state "^string_of_int target.label^
+		   ", proof depth "^string_of_int target.depth^
+		   ", num of aborts "^string_of_int naborts);
+    Vernacentries.vernac_backtrack target.label target.depth naborts;
+    Lib.mark_end_of_command (); (* We've short-circuited Vernac.eval_expr *)
+    extra_count
+
+
+(** Goal display *)
+
+let hyp_next_tac sigma env (id,_,ast) =
+  let id_s = Names.string_of_id id in
+  let type_s = string_of_ppcmds (pr_ltype_env env ast) in
+  [
+    ("clear "^id_s),("clear "^id_s^".\n");
+    ("apply "^id_s),("apply "^id_s^".\n");
+    ("exact "^id_s),("exact "^id_s^".\n");
+    ("generalize "^id_s),("generalize "^id_s^".\n");
+    ("absurd <"^id_s^">"),("absurd "^type_s^".\n")
+  ] @ (if Hipattern.is_equality_type ast then [
+    ("discriminate "^id_s),("discriminate "^id_s^".\n");
+    ("injection "^id_s),("injection "^id_s^".\n")
+  ] else []) @ (if Hipattern.is_equality_type (snd (Reductionops.splay_prod env sigma ast)) then [
+    ("rewrite "^id_s),("rewrite "^id_s^".\n");
+    ("rewrite <- "^id_s),("rewrite <- "^id_s^".\n")
+  ] else []) @ [
+    ("elim "^id_s), ("elim "^id_s^".\n");
+    ("inversion "^id_s), ("inversion "^id_s^".\n");
+    ("inversion clear "^id_s), ("inversion_clear "^id_s^".\n")
+  ]
+
+let concl_next_tac sigma concl =
+  let expand s = (s,s^".\n") in
+  List.map expand ([
+    "intro";
+    "intros";
+    "intuition"
+  ] @ (if Hipattern.is_equality_type (Goal.V82.concl sigma concl) then [
+    "reflexivity";
+    "discriminate";
+    "symmetry"
+  ] else []) @ [
+    "assumption";
+    "omega";
+    "ring";
+    "auto";
+    "eauto";
+    "tauto";
+    "trivial";
+    "decide equality";
+    "simpl";
+    "subst";
+    "red";
+    "split";
+    "left";
+    "right"
+  ])
+
+let process_goal sigma g =
+  let env = Goal.V82.env sigma g in
+  let ccl =
+    let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
+    string_of_ppcmds (pr_ltype_env_at_top env norm_constr) in
+  let process_hyp h_env d acc =
+    let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in
+    (string_of_ppcmds (pr_var_decl h_env d)) :: acc in
+(*           (string_of_ppcmds (pr_var_decl h_env d), hyp_next_tac sigma h_env d)::acc in *)
+  let hyps =
+    List.rev (Environ.fold_named_context process_hyp env ~init: []) in
+  { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl }
+(*         hyps,(ccl,concl_next_tac sigma g)) *)
+
+let goals () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    let fg = List.map (process_goal sigma) all_goals in
+    let { Evd.it = bgoals ; sigma = sigma } = Proof.V82.background_subgoals pfts in
+    let bg = List.map (process_goal sigma) bgoals in
+    Some { Interface.fg_goals = fg; Interface.bg_goals = bg; }
+  with Proof_global.NoCurrentProof -> None
+
+let evars () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    let exl = Evarutil.non_instantiated sigma in
+    let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in
+    let el = List.map map_evar exl in
+    Some el
+  with Proof_global.NoCurrentProof -> None
+
+let hints () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    match all_goals with
+    | [] -> None
+    | g :: _ ->
+      let env = Goal.V82.env sigma g in
+      let hint_goal = concl_next_tac sigma g in
+      let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
+      let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
+      Some (hint_hyps, hint_goal)
+  with Proof_global.NoCurrentProof -> None
+
+(** Other API calls *)
+
+let inloadpath dir =
+  Library.is_in_load_paths (System.physical_path_of_string dir)
+
+let status () =
+  (** We remove the initial part of the current [dir_path]
+      (usually Top in an interactive session, cf "coqtop -top"),
+      and display the other parts (opened sections and modules) *)
+  let path =
+    let l = Names.repr_dirpath (Lib.cwd ()) in
+    let l = snd (Util.list_sep_last l) in
+    if l = [] then None
+    else Some (Names.string_of_dirpath (Names.make_dirpath l))
+  in
+  let proof =
+    try
+      Some (Names.string_of_id (Pfedit.get_current_proof_name ()))
+    with _ -> None
+  in
+  { Interface.status_path = path; Interface.status_proofname = proof }
+
+let get_options () =
+  let table = Goptions.get_tables () in
+  let fold key state accu = (key, state) :: accu in
+  Goptions.OptionMap.fold fold table []
+
+let set_options options =
+  let iter (name, value) = match value with
+  | BoolValue b -> Goptions.set_bool_option_value name b
+  | IntValue i -> Goptions.set_int_option_value name i
+  | StringValue s -> Goptions.set_string_option_value name s
+  in
+  List.iter iter options
+
+(** Grouping all call handlers together + error handling *)
+
+let eval_call c =
+  let rec handle_exn e =
+    catch_break := false;
+    let pr_exn e = string_of_ppcmds (Errors.print e) in
+    match e with
+      | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!"
+      | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!"
+      | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner
+      | Error_in_file (_,_,inner) -> None, pr_exn inner
+      | Loc.Exc_located (loc, inner) when loc = dummy_loc -> None, pr_exn inner
+      | Loc.Exc_located (loc, inner) -> Some (Util.unloc loc), pr_exn inner
+      | e -> None, pr_exn e
+  in
+  let interruptible f x =
+    catch_break := true;
+    Util.check_for_interrupt ();
+    let r = f x in
+    catch_break := false;
+    r
+  in
+  let handler = {
+    Interface.interp = interruptible interp;
+    Interface.rewind = interruptible rewind;
+    Interface.goals = interruptible goals;
+    Interface.evars = interruptible evars;
+    Interface.hints = interruptible hints;
+    Interface.status = interruptible status;
+    Interface.inloadpath = interruptible inloadpath;
+    Interface.get_options = interruptible get_options;
+    Interface.set_options = interruptible set_options;
+    Interface.mkcases = interruptible Vernacentries.make_cases;
+    Interface.handle_exn = handle_exn; }
+  in
+  (* If the messages of last command are still there, we remove them *)
+  ignore (read_stdout ());
+  Ide_intf.abstract_eval_call handler c
+
+
+(** The main loop *)
+
+(** Exceptions during eval_call should be converted into [Interface.Fail]
+    messages by [handle_exn] above. Otherwise, we die badly, after having
+    tried to send a last message to the ide: trying to recover from errors
+    with the current protocol would most probably bring desynchronisation
+    between coqtop and ide. With marshalling, reading an answer to
+    a different request could hang the ide... *)
+
+let pr_debug s =
+  if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+
+let fail err =
+  Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err))
+
+let loop () =
+  let p = Xml_parser.make () in
+  let () = Xml_parser.check_eof p false in
+  init_signal_handler ();
+  catch_break := false;
+  (* ensure we have a command separator object (DOT) so that the first
+     command can be reseted. *)
+  Lib.mark_end_of_command();
+  try
+    while true do
+      let xml_answer =
+        try
+          let xml_query = Xml_parser.parse p (Xml_parser.SChannel stdin) in
+          let q = Ide_intf.to_call xml_query in
+          let () = pr_debug ("<-- " ^ Ide_intf.pr_call q) in
+          let r = eval_call q in
+          let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in
+          Ide_intf.of_answer q r
+        with
+        | Xml_parser.Error (err, loc) ->
+          let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in
+          fail msg
+        | Ide_intf.Marshal_error ->
+          fail "Incorrect query."
+      in
+      Xml_utils.print_xml !orig_stdout xml_answer;
+      flush !orig_stdout
+    done
+  with e ->
+    let msg = Printexc.to_string e in
+    let r = "Fatal exception in coqtop:\n" ^ msg in
+    pr_debug ("==> " ^ r);
+    (try
+      Xml_utils.print_xml !orig_stdout (fail r);
+      flush !orig_stdout
+    with _ -> ());
+    exit 1
diff --git a/toplevel/ide_slave.mli b/toplevel/ide_slave.mli
new file mode 100644
index 00000000..13dff280
--- /dev/null
+++ b/toplevel/ide_slave.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** [Ide_slave] : an implementation of [Ide_intf], i.e. mainly an interp
+    function and a rewind function. This specialized loop is triggered
+    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+    the only one using this mode, but we try here to be as generic as
+    possible, so this may change in the future... *)
+
+val init_stdout : unit -> unit
+
+val loop : unit -> unit
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
index 53c3bcea..de3b62f8 100644
--- a/toplevel/ind_tables.ml
+++ b/toplevel/ind_tables.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ind_tables.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* File created by Vincent Siles, Oct 2007, extended into a generic
    support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *)
 
@@ -53,7 +51,7 @@ let discharge_scheme (_,(kind,l)) =
   Some (kind,Array.map (fun (ind,const) ->
     (Lib.discharge_inductive ind,Lib.discharge_con const)) l)
 
-let (inScheme,_) =
+let inScheme : string * (inductive * constant) array -> obj =
   declare_object {(default_object "SCHEME") with
                     cache_function = cache_scheme;
                     load_function = (fun _ -> cache_scheme);
@@ -111,21 +109,28 @@ let declare_individual_scheme_object s ?(aux="") f =
 let declare_scheme kind indcl =
   Lib.add_anonymous_leaf (inScheme (kind,indcl))
 
+let is_visible_name id =
+  try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true
+  with Not_found -> false
+
+let compute_name internal id =
+  match internal with
+  | KernelVerbose | UserVerbose -> id
+  | KernelSilent ->
+      Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name
+
 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 fd = declare_constant ~internal in
+  let id = compute_name internal id in
   let kn = fd id
     (DefinitionEntry
       { const_entry_body = c;
+        const_entry_secctx = None;
         const_entry_type = None;
-        const_entry_opaque = false;
-	const_entry_boxed = Flags.boxed_definitions() },
+        const_entry_opaque = false },
       Decl_kinds.IsDefinition Scheme) in
   (match internal with
-  | KernelSilent -> () 
+  | KernelSilent -> ()
   | _-> definition_message id);
   kn
 
diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli
index e6f5e77a..96096d47 100644
--- a/toplevel/ind_tables.mli
+++ b/toplevel/ind_tables.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,10 +13,10 @@ open Mod_subst
 open Sign
 open Declarations
 
-(* This module provides support for registering inductive scheme builders,
+(** This module provides support for registering inductive scheme builders,
    declaring schemes and generating schemes on demand *)
 
-(* A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *)
+(** A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *)
 
 type mutual
 type individual
@@ -25,7 +25,7 @@ type 'a scheme_kind
 type mutual_scheme_object_function = mutual_inductive -> constr array
 type individual_scheme_object_function = inductive -> constr
 
-(* Main functions to register a scheme builder *)
+(** Main functions to register a scheme builder *)
 
 val declare_mutual_scheme_object : string -> ?aux:string ->
   mutual_scheme_object_function -> mutual scheme_kind
@@ -37,16 +37,16 @@ val declare_individual_scheme_object : string -> ?aux:string ->
 val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit
 *)
 
-(* Force generation of a (mutually) scheme with possibly user-level names *)
+(** Force generation of a (mutually) scheme with possibly user-level names *)
 
 val define_individual_scheme : individual scheme_kind -> 
-  Declare.internal_flag (* internal *) ->
+  Declare.internal_flag (** internal *) ->
   identifier option -> inductive -> constant
 
-val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (* internal *) ->
+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 *)
+(** 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
index 3596085f..51eddbae 100644
--- a/toplevel/indschemes.ml
+++ b/toplevel/indschemes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indschemes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* 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
@@ -49,6 +47,7 @@ let elim_flag = ref true
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic declaration of induction schemes";
       optkey   = ["Elimination";"Schemes"];
       optread  = (fun () -> !elim_flag) ;
@@ -58,6 +57,7 @@ let case_flag = ref false
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic declaration of case analysis schemes";
       optkey   = ["Case";"Analysis";"Schemes"];
       optread  = (fun () -> !case_flag) ;
@@ -67,6 +67,7 @@ let eq_flag = ref false
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic declaration of boolean equality";
       optkey   = ["Boolean";"Equality";"Schemes"];
       optread  = (fun () -> !eq_flag) ;
@@ -74,6 +75,7 @@ let _ =
 let _ = (* compatibility *)
   declare_bool_option
     { optsync  = true;
+      optdepr  = true;
       optname  = "automatic declaration of boolean equality";
       optkey   = ["Equality";"Scheme"];
       optread  = (fun () -> !eq_flag) ;
@@ -81,10 +83,11 @@ let _ = (* compatibility *)
 
 let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2
 
-let eq_dec_flag = ref false
+let eq_dec_flag = ref false 
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic declaration of decidable equality";
       optkey   = ["Decidable";"Equality";"Schemes"];
       optread  = (fun () -> !eq_dec_flag) ;
@@ -94,6 +97,7 @@ let rewriting_flag = ref false
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  ="automatic declaration of rewriting schemes for equality types";
       optkey   = ["Rewriting";"Schemes"];
       optread  = (fun () -> !rewriting_flag) ;
@@ -102,16 +106,13 @@ let _ =
 (* 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 f = declare_constant ~internal in
   let kn = f id
     (DefinitionEntry
       { const_entry_body = c;
+        const_entry_secctx = None;
         const_entry_type = t;
-        const_entry_opaque = false;
-	const_entry_boxed = Flags.boxed_definitions() },
+        const_entry_opaque = false },
       Decl_kinds.IsDefinition Scheme) in
   definition_message id;
   kn
@@ -127,7 +128,7 @@ let alarm what internal msg =
   | KernelVerbose 
   | KernelSilent ->
     (if debug then
-      Flags.if_verbose Pp.msg_warning
+      Flags.if_warn Pp.msg_warning
 	(hov 0 msg ++ fnl () ++ what ++ str " not defined."))
   | _ -> errorlabstrm "" msg
 
@@ -158,7 +159,7 @@ let try_declare_scheme what f internal names kn =
 	  (strbrk "Required constant " ++ str s ++ str " undefined.")
     | AlreadyDeclared msg ->
         alarm what internal (msg ++ str ".")
-    | _ ->
+    | _ -> 
 	alarm what internal
 	  (str "Unknown exception during scheme creation.")
 
@@ -173,7 +174,7 @@ let declare_beq_scheme_with l kn =
   try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn
 
 let try_declare_beq_scheme kn =
-  (* TODO: handle Fix, see e.g. TheoryList.In_spec, eventually handle
+  (* TODO: handle Fix, 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 KernelVerbose [] kn
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
index 707b9e00..87aedc7b 100644
--- a/toplevel/indschemes.mli
+++ b/toplevel/indschemes.mli
@@ -1,56 +1,52 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indschemes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Environ
 open Libnames
-open Rawterm
+open Glob_term
 open Genarg
 open Vernacexpr
 open Ind_tables
-(*i*)
 
-(* See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
+(** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
 
-(* Build and register the boolean equalities associated to an inductive type *)
+(** 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 *)
+(** 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 *)
+(** Build and register rewriting schemes for an equality-like inductive type *)
 
 val declare_rewriting_schemes : inductive -> unit
 
-(* Mutual Minimality/Induction scheme *)
+(** Mutual Minimality/Induction scheme *)
 
 val do_mutual_induction_scheme :
-  (identifier located * bool * inductive * rawsort) list -> unit
+  (identifier located * bool * inductive * glob_sort) list -> unit
 
-(* Main calls to interpret the Scheme command *)
+(** 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 *)
+(** 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 *)
+(** Hook called at each inductive type definition *)
 
 val declare_default_schemes : mutual_inductive -> unit
diff --git a/toplevel/interface.mli b/toplevel/interface.mli
new file mode 100644
index 00000000..e1410f5b
--- /dev/null
+++ b/toplevel/interface.mli
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Declarative part of the interface of CoqIde calls to Coq *)
+
+(** * Generic structures *)
+
+type raw = bool
+type verbose = bool
+
+(** The type of coqtop goals *)
+type goal = {
+  goal_hyp : string list;
+  (** List of hypotheses *)
+  goal_ccl : string;
+  (** Goal conclusion *)
+}
+
+type evar = {
+  evar_info : string;
+  (** A string describing an evar: type, number, environment *)
+}
+
+type status = {
+  status_path : string option;
+  (** Module path of the current proof *)
+  status_proofname : string option;
+  (** Current proof name. [None] if no proof is in progress *)
+}
+
+type goals = {
+  fg_goals : goal list;
+  (** List of the focussed goals *)
+  bg_goals : goal list;
+  (** List of the background goals *)
+}
+
+type hint = (string * string) list
+(** A list of tactics applicable and their appearance *)
+
+type option_name = Goptionstyp.option_name
+
+type option_value = Goptionstyp.option_value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
+
+(** Summary of an option status *)
+type option_state = Goptionstyp.option_state = {
+  opt_sync  : bool;
+  (** Whether an option is synchronous *)
+  opt_depr  : bool;
+  (** Wheter an option is deprecated *)
+  opt_name  : string;
+  (** A short string that is displayed when using [Test] *)
+  opt_value : option_value;
+  (** The current value of the option *)
+}
+
+(** * Coq answers to CoqIde *)
+
+type location = (int * int) option (* start and end of the error *)
+
+type 'a value =
+  | Good of 'a
+  | Fail of (location * string)
+
+(** * The structure that coqtop should implement *)
+
+type handler = {
+  interp : raw * verbose * string -> string;
+  rewind : int -> int;
+  goals : unit -> goals option;
+  evars : unit -> evar list option;
+  hints : unit -> (hint list * hint) option;
+  status : unit -> status;
+  get_options : unit -> (option_name * option_state) list;
+  set_options : (option_name * option_value) list -> unit;
+  inloadpath : string -> bool;
+  mkcases : string -> string list list;
+  handle_exn : exn -> location * string;
+}
diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml
index 8ef82105..7704449f 100644
--- a/toplevel/lemmas.ml
+++ b/toplevel/lemmas.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: lemmas.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Created by Hugo Herbelin from contents related to lemma proofs in
    file command.ml, Aug 2009 *)
 
@@ -41,8 +39,8 @@ 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)
+      let cb = Global.lookup_constant cst in
+      (Option.map Declarations.force (body_of_constant cb), is_opaque cb)
   | _ -> assert false
 
 let adjust_guardness_conditions const = function
@@ -126,13 +124,13 @@ let find_mutually_recursive_statements thms =
 	  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.";
+	    if_verbose msgnl (str "Assuming mutual coinductive statements.");
 	  flush_all ();
           indccl, true, []
       | [], _::_ ->
 	  if same_indccl <> [] &&
 	     list_distinct (List.map pi1 (List.hd same_indccl)) then
-	    if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all ();
+	    if_verbose msgnl (strbrk "Coinductive statements do not follow the order of definition, assuming the proof to be by induction."); flush_all ();
           let possible_guards = List.map (List.map pi3) inds_hyps in
 	  (* assume the largest indices as possible *)
 	  list_last common_same_indhyp, false, possible_guards
@@ -176,14 +174,6 @@ let save id const do_guard (locality,kind) hook =
   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
@@ -209,7 +199,7 @@ let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) =
           (Local,VarRef id,imps)
       | Global ->
           let k = IsAssumption Conjectural in
-          let kn = declare_constant id (ParameterEntry (t_i,false), k) in
+          let kn = declare_constant id (ParameterEntry (None,t_i,None), k) in
           (Global,ConstRef kn,imps))
   | Some body ->
       let k = logical_kind_of_goal_kind kind in
@@ -225,27 +215,34 @@ let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) =
       | Global ->
           let const =
             { const_entry_body = body_i;
+              const_entry_secctx = None;
               const_entry_type = Some t_i;
-              const_entry_opaque = opaq;
-              const_entry_boxed = false (* copy of what cook_proof does *)} in
+              const_entry_opaque = opaq } in
           let kn = declare_constant id (DefinitionEntry const, k) in
           (Global,ConstRef kn,imps)
 
-(* 4.2| General support for goals *)
+let save_hook = ref ignore
+let set_save_hook f = save_hook := f
+
+let get_proof opacity =
+  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
+  id,{const with const_entry_opaque = opacity},do_guard,persistence,hook
+
+let save_named opacity =
+  let id,const,do_guard,persistence,hook = get_proof opacity in
+  save id const do_guard persistence hook
 
 let check_anonymity id save_ident =
-  if atompart_of_id id <> "Unnamed_thm" then
+  if atompart_of_id id <> string_of_id (default_thm_id) then
     error "This command can only be used for unnamed theorem."
 
 let save_anonymous opacity save_ident =
-  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
-  let const = { const with const_entry_opaque = opacity } in
+  let id,const,do_guard,persistence,hook = get_proof 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
+  let id,const,do_guard,_,hook = get_proof opacity in
   check_anonymity id save_ident;
   (* we consider that non opaque behaves as local for discharge *)
   save save_ident const do_guard (Global, Proof kind) hook
@@ -256,8 +253,7 @@ 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
+  let sign = initialize_named_context_for_proof () in
   !start_hook c;
   Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook
 
@@ -314,11 +310,11 @@ let start_proof_with_initialization kind recguard thms snl hook =
       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 evdref = ref 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
+    let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in
+    let t', imps' = interp_type_evars_impls ~impls ~evdref env t in
     Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx;
     let ids = List.map pi1 ctx in
       (compute_proof_name (fst kind) sopt,
@@ -333,8 +329,9 @@ let start_proof_com kind thms hook =
 
 let admit () =
   let (id,k,typ,hook) = Pfedit.current_proof_statement () in
+  let e = Pfedit.get_used_variables(), typ, None in
   let kn =
-    declare_constant id (ParameterEntry (typ,false),IsAssumption Conjectural) in
+    declare_constant id (ParameterEntry e,IsAssumption Conjectural) in
   Pfedit.delete_current_proof ();
   assumption_message id;
   hook Global (ConstRef kn)
diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli
index 0e8eaac2..8b496f82 100644
--- a/toplevel/lemmas.mli
+++ b/toplevel/lemmas.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lemmas.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Decl_kinds
@@ -17,9 +14,8 @@ open Tacexpr
 open Vernacexpr
 open Proof_type
 open Pfedit
-(*i*)
 
-(* A hook start_proof calls on the type of the definition being started *)
+(** 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 ->
@@ -35,31 +31,32 @@ val start_proof_with_initialization :
   (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
+(** A hook the next three functions pass to cook_proof *)
+val set_save_hook : (Proof.proof -> unit) -> unit
 
-(*s [save_named b] saves the current completed proof under the name it
+(** {6 ... } *)
+(** [save_named b] saves the current completed proof under the name it
 was started; boolean [b] tells if the theorem is declared opaque; it
 fails if the proof is not completed *)
 
 val save_named : bool -> unit
 
-(* [save_anonymous b name] behaves as [save_named] but declares the theorem
+(** [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
+(** [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 *)
+(** [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
+(** [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 *)
 
diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml
index 27e19bd8..2f98962c 100644
--- a/toplevel/libtypes.ml
+++ b/toplevel/libtypes.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -71,7 +71,7 @@ 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) =
+let input : TypeDnet.t -> obj =
   declare_object
     { (default_object "LIBTYPES") with
 	load_function = (fun _ -> load);
diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli
index 03329592..a6a95ccf 100644
--- a/toplevel/libtypes.mli
+++ b/toplevel/libtypes.mli
@@ -1,31 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id:$ *)
-
-(*i*)
 open Term
-(*i*)
 
-(*
- * Persistent library of all declared object,
- * indexed by their types (uses Dnets)
- *)
+(** Persistent library of all declared object, indexed by their types 
+    (uses Dnets) *)
 
-(* results are the reference of the object, together with a context
+(** 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 *)
+(** 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 *)
+(** 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
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 0adae08a..6a4d7251 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -1,15 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: metasyntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Flags
+open Compat
 open Util
 open Names
 open Topconstr
@@ -20,8 +19,9 @@ open Summary
 open Constrintern
 open Vernacexpr
 open Pcoq
-open Rawterm
+open Glob_term
 open Libnames
+open Tok
 open Lexer
 open Egrammar
 open Notation
@@ -30,9 +30,9 @@ open Nameops
 (**********************************************************************)
 (* Tokens                                                             *)
 
-let cache_token (_,s) = add_token ("", s)
+let cache_token (_,s) = add_keyword s
 
-let (inToken, outToken) =
+let inToken : string -> obj =
   declare_object {(default_object "TOKEN") with
        open_function = (fun i o -> if i=1 then cache_token o);
        cache_function = cache_token;
@@ -70,7 +70,12 @@ let subst_tactic_parule subst (key,n,p,(d,tac)) =
 let subst_tactic_notation (subst,(pa,pp)) =
   (subst_tactic_parule subst pa,pp)
 
-let (inTacticGrammar, outTacticGrammar) =
+type tactic_grammar_obj =
+    (string * int * grammar_prod_item list *
+       (dir_path * Tacexpr.glob_tactic_expr))
+    * (string * Genarg.argument_type list * (int * Pptactic.grammar_terminals))
+
+let inTacticGrammar : tactic_grammar_obj -> obj =
   declare_object {(default_object "TacticGrammar") with
        open_function = (fun i o -> if i=1 then cache_tactic_notation o);
        cache_function = cache_tactic_notation;
@@ -106,33 +111,33 @@ let add_tactic_notation (n,prods,e) =
 let print_grammar = function
   | "constr" | "operconstr" | "binder_constr" ->
       msgnl (str "Entry constr is");
-      entry_print Pcoq.Constr.constr;
+      Gram.entry_print Pcoq.Constr.constr;
       msgnl (str "and lconstr is");
-      entry_print Pcoq.Constr.lconstr;
+      Gram.entry_print Pcoq.Constr.lconstr;
       msgnl (str "where binder_constr is");
-      entry_print Pcoq.Constr.binder_constr;
+      Gram.entry_print Pcoq.Constr.binder_constr;
       msgnl (str "and operconstr is");
-      entry_print Pcoq.Constr.operconstr;
+      Gram.entry_print Pcoq.Constr.operconstr;
   | "pattern" ->
-      entry_print Pcoq.Constr.pattern
+      Gram.entry_print Pcoq.Constr.pattern
   | "tactic" ->
       msgnl (str "Entry tactic_expr is");
-      entry_print Pcoq.Tactic.tactic_expr;
+      Gram.entry_print Pcoq.Tactic.tactic_expr;
       msgnl (str "Entry binder_tactic is");
-      entry_print Pcoq.Tactic.binder_tactic;
+      Gram.entry_print Pcoq.Tactic.binder_tactic;
       msgnl (str "Entry simple_tactic is");
-      entry_print Pcoq.Tactic.simple_tactic;
+      Gram.entry_print Pcoq.Tactic.simple_tactic;
   | "vernac" ->
       msgnl (str "Entry vernac is");
-      entry_print Pcoq.Vernac_.vernac;
+      Gram.entry_print Pcoq.Vernac_.vernac;
       msgnl (str "Entry command is");
-      entry_print Pcoq.Vernac_.command;
+      Gram.entry_print Pcoq.Vernac_.command;
       msgnl (str "Entry syntax is");
-      entry_print Pcoq.Vernac_.syntax;
+      Gram.entry_print Pcoq.Vernac_.syntax;
       msgnl (str "Entry gallina is");
-      entry_print Pcoq.Vernac_.gallina;
+      Gram.entry_print Pcoq.Vernac_.gallina;
       msgnl (str "Entry gallina_ext is");
-      entry_print Pcoq.Vernac_.gallina_ext;
+      Gram.entry_print Pcoq.Vernac_.gallina_ext;
   | _ -> error "Unknown or unprintable grammar entry."
 
 (**********************************************************************)
@@ -233,7 +238,7 @@ let parse_format (loc,str) =
     else
       error "Empty format."
   with e ->
-    Stdpp.raise_with_loc loc e
+    Loc.raise loc e
 
 (***********************)
 (* Analyzing notations *)
@@ -279,9 +284,9 @@ let rec find_pattern nt xl = function
       find_pattern nt (x::xl) (l,l')
   | [], NonTerminal x' :: l' ->
       (out_nt nt,x',List.rev xl),l'
-  | [], Terminal s :: _ | Terminal s :: _, _ ->
+  | _, Terminal s :: _ | Terminal s :: _, _ ->
       error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.")
-  | [], Break s :: _ | Break s :: _, _ ->
+  | _, Break s :: _ | Break s :: _, _ ->
       error ("A break occurs on one side of \"..\" but not on the other side.")
   | _, [] ->
       error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".")
@@ -311,13 +316,10 @@ let rec interp_list_parser hd = function
 
 (* Find non-terminal tokens of notation *)
 
-let is_normal_token str =
-  try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false
-
 (* To protect alphabetic tokens and quotes from being seen as variables *)
 let quote_notation_token x =
   let n = String.length x in
-  let norm = is_normal_token x in
+  let norm = is_ident x in
   if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'"
   else x
 
@@ -325,11 +327,9 @@ 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;
+  | String x :: sl when is_ident x ->
       NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl
   | String s :: sl ->
-      Lexer.check_keyword s;
       Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl
   | WhiteSpace n :: sl ->
       Break n :: raw_analyze_notation_tokens sl
@@ -363,11 +363,6 @@ let error_not_same_scope x y =
   error ("Variables "^string_of_id x^" and "^string_of_id y^
     " must be in the same scope.")
 
-let error_both_bound_and_binding x y =
-  errorlabstrm "" (strbrk "The recursive variables " ++ pr_id x ++
-  strbrk " and " ++ pr_id y ++ strbrk " cannot be used as placeholder
-  for both terms and binders.")
-
 (**********************************************************************)
 (* Build pretty-printing rules                                        *)
 
@@ -375,9 +370,9 @@ type printing_precedence = int * parenRelation
 type parsing_precedence = int option
 
 let prec_assoc = function
-  | Gramext.RightA -> (L,E)
-  | Gramext.LeftA -> (E,L)
-  | Gramext.NonA -> (L,L)
+  | RightA -> (L,E)
+  | LeftA -> (E,L)
+  | NonA -> (L,L)
 
 let precedence_of_entry_type from = function
   | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
@@ -403,12 +398,6 @@ let is_right_bracket s =
   let l = String.length s in l <> 0 &
   (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')')
 
-let is_left_bracket_on_left s =
-  let l = String.length s in l <> 0 & s.[l-1] = '>'
-
-let is_right_bracket_on_right s =
-  let l = String.length s in l <> 0 & s.[0] = '<'
-
 let is_comma s =
   let l = String.length s in l <> 0 &
   (s.[0] = ',' or s.[0] = ';')
@@ -598,20 +587,20 @@ let is_not_small_constr = function
   | _ -> false
 
 let rec define_keywords_aux = function
-  | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal("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 :: GramConstrTerminal("",k) :: define_keywords_aux l
+      message ("Identifier '"^k^"' now a keyword");
+      Lexer.add_keyword k;
+      n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | n :: l -> n :: define_keywords_aux l
   | [] -> []
 
   (* Ensure that IDENT articulation terminal symbols are keywords *)
 let define_keywords = function
-  | GramConstrTerminal("IDENT",k)::l ->
-      message ("Defining '"^k^"' as keyword");
-      Lexer.add_token("",k);
-      GramConstrTerminal("",k) :: define_keywords_aux l
+  | GramConstrTerminal(IDENT k)::l ->
+      message ("Identifier '"^k^"' now a keyword");
+      Lexer.add_keyword k;
+      GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | l -> define_keywords_aux l
 
 let distribute a ll = List.map (fun l -> a @ l) ll
@@ -673,9 +662,9 @@ let border = function
 
 let recompute_assoc typs =
   match border typs, border (List.rev typs) with
-    | Some Gramext.LeftA, Some Gramext.RightA -> assert false
-    | Some Gramext.LeftA, _ -> Some Gramext.LeftA
-    | _, Some Gramext.RightA -> Some Gramext.RightA
+    | Some LeftA, Some RightA -> assert false
+    | Some LeftA, _ -> Some LeftA
+    | _, Some RightA -> Some RightA
     | _ -> None
 
 (**************************************************************************)
@@ -726,7 +715,13 @@ let subst_syntax_extension (subst,(local,sy)) =
 let classify_syntax_definition (local,_ as o) =
   if local then Dispose else Substitute o
 
-let (inSyntaxExtension, outSyntaxExtension) =
+type syntax_extension_obj =
+    bool *
+      (notation_var_internalization_type list * Notation.level *
+         notation * notation_grammar * unparsing list)
+      list
+
+let inSyntaxExtension : syntax_extension_obj -> obj =
   declare_object {(default_object "SYNTAX-EXTENSION") with
        open_function = (fun i o -> if i=1 then cache_syntax_extension o);
        cache_function = cache_syntax_extension;
@@ -891,15 +886,17 @@ 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 rec next = function
-    | Break _ :: l -> next l
-    | l -> l in
+  let rec skip_break acc = function
+    | Break _ as br :: l -> skip_break (br::acc) l
+    | l -> List.rev acc, l in
   let rec aux deb = function
   | [] -> []
   | Terminal "{" as t1 :: l ->
-      (match next l with
+      let br,next = skip_break [] l in
+      (match next with
         | NonTerminal _ as x :: l' as l0 ->
-            (match next l' with
+            let br',next' = skip_break [] l' in
+            (match next' with
               | Terminal "}" as t2 :: l'' as l1 ->
                   if l <> l0 or l' <> l1 then
                     warning "Skipping spaces inside curly brackets";
@@ -907,15 +904,14 @@ let remove_curly_brackets l =
                     check_curly_brackets_notation_exists ();
                     x :: aux false l''
                   end
-              | l1 -> t1 :: x :: aux false l1)
+              | l1 -> t1 :: br @ x :: br' @ aux false l1)
         | l0 -> t1 :: aux false l0)
   | x :: l -> x :: aux false l
   in aux true l
 
 let compute_syntax_data (df,modifiers) =
   let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in
-  (* Notation defaults to NONA *)
-  let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
+  let assoc = match assoc with None -> (* default *) Some NonA | a -> a in
   let toks = split_notation_string df in
   let (recvars,mainvars,symbols) = analyze_notation_tokens toks in
   let ntn_for_interp = make_notation_key symbols in
@@ -977,7 +973,11 @@ let subst_notation (subst,(lc,scope,pat,b,ndf)) =
 let classify_notation (local,_,_,_,_ as o) =
   if local then Dispose else Substitute o
 
-let (inNotation, outNotation) =
+type notation_obj =
+    bool * scope_name option * interpretation * bool *
+      (notation * notation_location)
+
+let inNotation : notation_obj -> obj =
   declare_object {(default_object "NOTATION") with
        open_function = open_notation;
        cache_function = cache_notation;
@@ -1153,7 +1153,7 @@ let subst_scope_command (subst,(scope,o as x)) = match o with
       scope, ScopeClasses cl'
   | _ -> x
 
-let (inScopeCommand,outScopeCommand) =
+let inScopeCommand : scope_name * scope_command -> obj =
   declare_object {(default_object "DELIMITERS") with
       cache_function = cache_scope_command;
       open_function = open_scope_command;
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index 2c4e29bb..4ee1310a 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: metasyntax.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Libnames
@@ -18,16 +15,15 @@ open Tacexpr
 open Vernacexpr
 open Notation
 open Topconstr
-(*i*)
 
 val add_token_obj : string -> unit
 
-(* Adding a tactic notation in the environment *)
+(** Adding a tactic notation in the environment *)
 
 val add_tactic_notation :
   int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit
 
-(* Adding a (constr) notation in the environment*)
+(** Adding a (constr) notation in the environment*)
 
 val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
   constr_expr -> scope_name option -> unit
@@ -35,32 +31,32 @@ val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
 val add_notation : locality_flag -> constr_expr ->
   (lstring * syntax_modifier list) -> scope_name option -> unit
 
-(* Declaring delimiter keys and default scopes *)
+(** Declaring delimiter keys and default scopes *)
 
 val add_delimiters : scope_name -> string -> unit
 val add_class_scope : scope_name -> Classops.cl_typ -> unit
 
-(* Add only the interpretation of a notation that already has pa/pp rules *)
+(** Add only the interpretation of a notation that already has pa/pp rules *)
 
 val add_notation_interpretation :
   (lstring * constr_expr * scope_name option) -> unit
 
-(* Add a notation interpretation for supporting the "where" clause *)
+(** Add a notation interpretation for supporting the "where" clause *)
 
 val set_notation_for_interpretation : Constrintern.internalization_env ->
   (lstring * constr_expr * scope_name option) -> unit
 
-(* Add only the parsing/printing rule of a notation *)
+(** Add only the parsing/printing rule of a notation *)
 
 val add_syntax_extension :
   locality_flag -> (lstring * syntax_modifier list) -> unit
 
-(* Add a syntactic definition (as in "Notation f := ...") *)
+(** Add a syntactic definition (as in "Notation f := ...") *)
 
 val add_syntactic_definition : identifier -> identifier list * constr_expr ->
   bool -> bool -> unit
 
-(* Print the Camlp4 state of a grammar *)
+(** Print the Camlp4 state of a grammar *)
 
 val print_grammar : string -> unit
 
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
index 59bc01d0..ff3ce8a0 100644
--- a/toplevel/mltop.ml4
+++ b/toplevel/mltop.ml4
@@ -1,18 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4use: "pa_macro.cmo" i*)
-(* WARNING
- * camlp4deps will not work for this file unless Makefile system enhanced.
- *)
-
-(* $Id: mltop.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Pp
 open Flags
@@ -133,8 +126,8 @@ let add_ml_dir s =
     | _ -> ()
 
 (* For Rec Add ML Path *)
-let add_rec_ml_dir dir =
-  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir)
+let add_rec_ml_dir unix_path =
+  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
 
 (* Adding files to Coq and ML loadpath *)
 
@@ -150,24 +143,24 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
 let convert_string d =
   try Names.id_of_string d
   with _ ->
-    if_verbose warning
-      ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
+    if_warn msg_warning
+      (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)"));
     flush_all ();
     failwith "caught"
 
-let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
-  if exists_dir dir then
-    let dirs = all_subdirs dir in
-    let prefix = Names.repr_dirpath coq_dirpath in
+let add_rec_path ~unix_path ~coq_root =
+  if exists_dir unix_path then
+    let dirs = all_subdirs ~unix_path in
+    let prefix = Names.repr_dirpath coq_root in
     let convert_dirs (lp,cp) =
       (lp,Names.make_dirpath (List.map convert_string (List.rev cp)@prefix)) in
     let dirs = map_succeed convert_dirs dirs in
     List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs;
-    add_ml_dir dir;
+    add_ml_dir unix_path;
     List.iter (Library.add_load_path false) dirs;
-    Library.add_load_path true (dir,coq_dirpath)
+    Library.add_load_path true (unix_path, coq_root)
   else
-    msg_warning (str ("Cannot open " ^ dir))
+    msg_warning (str ("Cannot open " ^ unix_path))
 
 (* convertit un nom quelconque en nom de fichier ou de module *)
 let mod_of_name name =
@@ -224,8 +217,6 @@ let file_of_name name =
     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
  * module twice. It is NOT the list of ML modules Coq knows. *)
@@ -244,7 +235,7 @@ let add_known_module mname =
 let module_is_known mname =
   Stringset.mem (String.capitalize mname) !known_loaded_modules
 
-let load_object mname fname=
+let load_ml_object mname fname=
   dir_ml_load fname;
   add_known_module mname
 
@@ -266,7 +257,7 @@ let unfreeze_ml_modules x =
        if not (module_is_known mname) then
          if has_dynlink then
            let fname = file_of_name mname in
-           load_object mname fname
+           load_ml_object mname fname
          else
 	   errorlabstrm "Mltop.unfreeze_ml_modules"
              (str"Loading of ML object file forbidden in a native Coq.");
@@ -291,7 +282,7 @@ let cache_ml_module_object (_,{mnames=mnames}) =
 	   try
 	     if_verbose
 	       msg (str"[Loading ML file " ++ str fname ++ str" ...");
-             load_object mname fname;
+             load_ml_object mname fname;
              if_verbose msgnl (str" done]");
              add_loaded_module mname
            with e ->
@@ -305,7 +296,7 @@ let cache_ml_module_object (_,{mnames=mnames}) =
 let classify_ml_module_object ({mlocal=mlocal} as o) =
   if mlocal then Dispose else Substitute o
 
-let (inMLModule,outMLModule) =
+let inMLModule : ml_module_object -> obj =
   declare_object {(default_object "ML-MODULE") with
                     load_function = (fun _ -> cache_ml_module_object);
                     cache_function = cache_ml_module_object;
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index ae562bd2..1e9c3b03 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mltop.mli 14641 2011-11-06 11:59:10Z herbelin $ 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 = {
   load_obj : string -> unit;
@@ -16,44 +14,44 @@ type toplevel = {
   add_dir  : string -> unit;
   ml_loop  : unit -> unit }
 
-(* Sets and initializes a toplevel (if any) *)
+(** Sets and initializes a toplevel (if any) *)
 val set_top : toplevel -> unit
 
-(* Are we in a native version of Coq? *)
+(** Are we in a native version of Coq? *)
 val is_native : bool
 
-(* Removes the toplevel (if any) *)
+(** Removes the toplevel (if any) *)
 val remove : unit -> unit
 
-(* Tests if an Ocaml toplevel runs under Coq *)
+(** Tests if an Ocaml toplevel runs under Coq *)
 val is_ocaml_top : unit -> bool
 
-(* Tests if we can load ML files *)
+(** Tests if we can load ML files *)
 val has_dynlink : bool
 
-(* Starts the Ocaml toplevel loop *)
+(** Starts the Ocaml toplevel loop *)
 val ocaml_toploop : unit -> unit
 
-(* Dynamic loading of .cmo *)
+(** Dynamic loading of .cmo *)
 val dir_ml_load : string -> unit
 
-(* Dynamic interpretation of .ml *)
+(** Dynamic interpretation of .ml *)
 val dir_ml_use : string -> unit
 
-(* Adds a path to the ML paths *)
+(** Adds a path to the ML paths *)
 val add_ml_dir : string -> unit
 val add_rec_ml_dir : string -> unit
 
-(* Adds a path to the Coq and ML paths *)
+(** Adds a path to the Coq and ML paths *)
 val add_path : unix_path:string -> coq_root:Names.dir_path -> unit
 val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit
 
-(* List of modules linked to the toplevel *)
+(** List of modules linked to the toplevel *)
 val add_known_module : string -> unit
 val module_is_known : string -> bool
-val load_object : string -> string -> unit
+val load_ml_object : string -> string -> unit
 
-(* Summary of Declared ML Modules *)
+(** Summary of Declared ML Modules *)
 val get_loaded_modules : unit -> string list
 val add_loaded_module : string -> unit
 val init_ml_modules : unit -> unit
@@ -63,8 +61,6 @@ 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 : Vernacexpr.locality_flag -> string list -> unit
 
diff --git a/toplevel/record.ml b/toplevel/record.ml
index ee9b8d66..86849cbb 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -1,20 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: record.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Libnames
 open Nameops
 open Term
-open Termops
 open Environ
 open Declarations
 open Entries
@@ -33,10 +30,10 @@ open Topconstr
 
 let interp_evars evdref env impls k typ =
   let typ' = intern_gen true ~impls !evdref env typ in
-  let imps = Implicit_quantifiers.implicits_of_rawterm typ' in
+  let imps = Implicit_quantifiers.implicits_of_glob_constr typ' in
     imps, Pretyping.Default.understand_tcc_evars evdref env k typ'
 
-let interp_fields_evars evars env nots l =
+let interp_fields_evars evars env impls_env nots l =
   List.fold_left2
     (fun (env, uimpls, params, impls) no ((loc, i), b, t) ->
       let impl, t' = interp_evars evars env impls Pretyping.IsType t in
@@ -44,12 +41,12 @@ let interp_fields_evars evars env nots l =
       let impls =
 	match i with
 	| Anonymous -> impls
-	| Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls
+	| Name id -> Idmap.add id (compute_internalization_data env Constrintern.Method t' impl) impls
       in
       let d = (i,b',t') in
       List.iter (Metasyntax.set_notation_for_interpretation impls) no;
       (push_rel d env, impl :: uimpls, d::params, impls))
-    (env, [], [], []) nots l
+    (env, [], [], impls_env) nots l
 
 let binder_of_decl = function
   | Vernacexpr.AssumExpr(n,t) -> (n,None,t)
@@ -60,11 +57,23 @@ 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.empty in
-  let (env1,newps), imps = interp_context_evars evars env0 ps in
-  let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in
+  let _ = 
+    let error bk (loc, name) = 
+      match bk with
+      | Default _ ->
+	  if name = Anonymous then 
+	    user_err_loc (loc, "record", str "Record parameters must be named")
+      | _ -> ()
+    in
+      List.iter 
+	(function LocalRawDef (b, _) -> error default_binder_kind b
+	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps
+  in 
+  let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in
+  let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in
   let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in
   let env2,impls,newfs,data =
-    interp_fields_evars evars env_ar nots (binders_of_decls fs)
+    interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs)
   in
   let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in
   let evars = Typeclasses.resolve_typeclasses env_ar evars in
@@ -153,7 +162,7 @@ let subst_projection fid l c =
 
 let instantiate_possibly_recursive_type indsp paramdecls fields =
   let subst = list_map_i (fun i _ -> mkRel i) 1 paramdecls in
-  substl_rel_context (subst@[mkInd indsp]) fields
+  Termops.substl_rel_context (subst@[mkInd indsp]) fields
 
 (* We build projections *)
 let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields =
@@ -161,11 +170,11 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls
   let (mib,mip) = Global.lookup_inductive indsp in
   let paramdecls = mib.mind_params_ctxt in
   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 rp = applist (r, Termops.extended_rel_list 0 paramdecls) in
+  let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*)
   let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in
   let fields = instantiate_possibly_recursive_type indsp paramdecls fields in
-  let lifted_fields = lift_rel_context 1 fields in
+  let lifted_fields = Termops.lift_rel_context 1 fields in
   let (_,kinds,sp_projs,_) =
     list_fold_left3
       (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls ->
@@ -194,11 +203,11 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls
 	        try
 		  let cie = {
 		    const_entry_body = proj;
+                    const_entry_secctx = None;
                     const_entry_type = Some projtyp;
-                    const_entry_opaque = false;
-		    const_entry_boxed = Flags.boxed_definitions() } in
+                    const_entry_opaque = false } in
 		  let k = (DefinitionEntry cie,IsDefinition kind) in
-		  let kn = declare_internal_constant fid k in
+		  let kn = declare_constant ~internal:KernelSilent fid k in
 		  Flags.if_verbose message (string_of_id fid ^" is defined");
 		  kn
                 with Type_errors.TypeError (ctx,te) ->
@@ -208,7 +217,7 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls
 	      Impargs.maybe_declare_manual_implicits false refi impls;
 	      if coe then begin
 	        let cl = Class.class_of_global (IndRef indsp) in
-	        Class.try_add_new_coercion_with_source refi Global cl
+	        Class.try_add_new_coercion_with_source refi Global ~source:cl
 	      end;
 	      let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
 	      let constr_fip = applist (constr_fi,proj_args) in
@@ -239,7 +248,7 @@ 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 args = Termops.extended_rel_list nfields params in
   let ind = applist (mkRel (1+nparams+nfields), args) in
   let type_constructor = it_mkProd_or_LetIn ind fields in
   let mie_ind =
@@ -253,7 +262,7 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls
   (* there is probably a way to push this to "declare_mutual" *)
   begin match  finite with
   | BiFinite ->
-      if dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
+      if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
 	error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record."
   | _ -> ()
   end;
@@ -282,18 +291,15 @@ let implicits_of_context ctx =
     in ExplByPos (i, explname), (true, true, true))
     1 (List.rev (Anonymous :: (List.map pi1 ctx)))
 
-let qualid_of_con c = 
-  Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c))
-
-let declare_instance_cst glob con =
+let declare_instance_cst glob con pri =
   let instance = Typeops.type_of_constant (Global.env ()) con in
   let _, r = decompose_prod_assum instance in
     match class_of_constr r with
-      | Some tc -> add_instance (new_instance tc None glob (ConstRef con))
+      | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob (ConstRef con))
       | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.")
 
 let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields
-    ?(kind=StructureComponent) ?name is_coe coers sign =
+    ?(kind=StructureComponent) ?name is_coe coers priorities sign =
   let fieldimpls =
     (* Make the class and all params implicits in the projections *)
     let ctx_impls = implicits_of_context params in
@@ -307,21 +313,21 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls
 	let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in
 	let class_entry =
 	  { const_entry_body = class_body;
+            const_entry_secctx = None;
 	    const_entry_type = class_type;
-	    const_entry_opaque = false;
-	    const_entry_boxed = false }
+	    const_entry_opaque = false }
 	in
 	let cst = Declare.declare_constant (snd id)
 	  (DefinitionEntry class_entry, IsDefinition Definition)
 	in
-	let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in
+	let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in
 	let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in
 	let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in
 	let proj_entry =
 	  { const_entry_body = proj_body;
+            const_entry_secctx = None;
 	    const_entry_type = Some proj_type;
-	    const_entry_opaque = false;
-	    const_entry_boxed = false }
+	    const_entry_opaque = false }
 	in
 	let proj_cst = Declare.declare_constant proj_name
 	  (DefinitionEntry proj_entry, IsDefinition Definition)
@@ -329,22 +335,27 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls
 	let cref = ConstRef cst in
 	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;
+	Classes.set_typeclass_transparency (EvalConstRef cst) false false;
 	if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign ();
-	cref, [proj_name, Some proj_cst]
+	let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in
+	  cref, [Name proj_name, sub, Some proj_cst]
     | _ ->
-	let idarg = Namegen.next_ident_away (snd id) (ids_of_context (Global.env())) in
+	let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in
 	let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls
-	  params (Option.cata (fun x -> x) (new_Type ()) arity) fieldimpls fields
+	  params (Option.default (Termops.new_Type ()) arity) fieldimpls fields
 	  ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign
 	in
-	  IndRef ind, (List.map2 (fun (id, _, _) y -> (Nameops.out_name id, y))
-			     (List.rev fields) (Recordops.lookup_projections ind))
+	let coers = List.map2 (fun coe pri -> 
+			       Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) 
+	  coers priorities 
+	in
+	  IndRef ind, (list_map3 (fun (id, _, _) b y -> (id, b, y))
+			 (List.rev fields) coers (Recordops.lookup_projections ind))
   in
   let ctx_context =
     List.map (fun (na, b, t) ->
       match Typeclasses.class_of_constr t with
-      | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*)
+      | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*)
       | None -> None)
       params, params
   in
@@ -354,9 +365,9 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls
       cl_props = fields;
       cl_projs = projs }
   in
-    List.iter2 (fun p sub ->
-      if sub then match snd p with Some p -> declare_instance_cst true p | None -> ())
-      k.cl_projs coers;
+(*     list_iter3 (fun p sub pri -> *)
+(*       if sub then match p with (_, _, Some p) -> declare_instance_cst true p pri | _ -> ()) *)
+(*       k.cl_projs coers priorities; *)
   add_class k; impl
 
 let interp_and_check_sort sort =
@@ -369,10 +380,12 @@ let interp_and_check_sort sort =
 open Vernacexpr
 open Autoinstance
 
-(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean
-   list telling if the corresponding fields must me declared as coercion *)
+(* [fs] corresponds to fields and [ps] to parameters; [coers] is a
+   list telling if the corresponding fields must me declared as coercions 
+   or subinstances *)
 let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
   let cfs,notations = List.split cfs in
+  let cfs,priorities = List.split cfs in
   let coers,fs = List.split cfs in
   let extract_name acc = function
       Vernacexpr.AssumExpr((_,Name id),_) -> id::acc
@@ -380,6 +393,8 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil
     | _ -> acc in
   let allnames =  idstruc::(List.fold_left extract_name [] fs) in
   if not (list_distinct allnames) then error "Two objects have the same name";
+  if not (kind = Class false) && List.exists ((<>) None) priorities then
+    error "Priorities only allowed for type class substructures";
   (* Now, younger decl in params and fields is on top *)
   let sc = interp_and_check_sort s in
   let implpars, params, implfs, fields =
@@ -389,13 +404,14 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil
     match kind with
     | Class def ->
 	let gr = declare_class finite def infer (loc,idstruc) idbuild
-	  implpars params sc implfs fields is_coe coers sign in
+	  implpars params sc implfs fields is_coe coers priorities sign in
 	if infer then search_record declare_class_instance gr sign;
 	gr
     | _ ->
-	let arity = Option.default (new_Type ()) sc in
+	let arity = Option.default (Termops.new_Type ()) sc in
 	let implfs = List.map
 	  (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in
-	let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs fields is_coe coers sign in
+	let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs 
+	  fields is_coe (List.map (fun coe -> coe <> None) coers) sign in
 	if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign;
 	IndRef ind
diff --git a/toplevel/record.mli b/toplevel/record.mli
index 44b34550..45670f1f 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: record.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Sign
@@ -16,28 +13,27 @@ open Vernacexpr
 open Topconstr
 open Impargs
 open Libnames
-(*i*)
 
-(* [declare_projections ref name coers params fields] declare projections of
+(** [declare_projections ref name coers params fields] declare projections of
    record [ref] (if allowed) using the given [name] as argument, and put them
    as coercions accordingly to [coers]; it returns the absolute names of projections *)
 
 val declare_projections :
   inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
-  bool list -> manual_explicitation list list -> rel_context ->
+  coercion_flag list -> manual_explicitation list list -> rel_context ->
   (name * bool) list * constant option list
 
 val declare_structure : Decl_kinds.recursivity_kind ->
-  bool (*infer?*) -> identifier -> identifier ->
-  manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *)
-  Impargs.manual_explicitation list list -> rel_context -> (* fields *)
+  bool (**infer?*) -> identifier -> identifier ->
+  manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *)
+  Impargs.manual_explicitation list list -> rel_context -> (** fields *)
   ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
-  bool -> (* coercion? *)
-  bool list -> (* field coercions *)
+  bool -> (** coercion? *)
+  bool list -> (** field coercions *)
   Evd.evar_map ->
   inductive
 
 val definition_structure :
-  inductive_kind * Decl_kinds.recursivity_kind * bool(*infer?*)* lident with_coercion * local_binder list *
-  (local_decl_expr with_coercion with_notation) list *
+  inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list *
+  (local_decl_expr with_instance with_priority with_notation) list *
   identifier * constr_expr option -> global_reference
diff --git a/toplevel/search.ml b/toplevel/search.ml
index fd3024a4..33e8e51d 100644
--- a/toplevel/search.ml
+++ b/toplevel/search.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: search.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
 open Nameops
 open Term
-open Rawterm
+open Glob_term
 open Declarations
 open Libobject
 open Declare
@@ -24,6 +22,16 @@ open Printer
 open Libnames
 open Nametab
 
+module SearchBlacklist =
+  Goptions.MakeStringTable
+    (struct
+      let key = ["Search";"Blacklist"]
+      let title = "Current search blacklist : "
+      let member_message s b =
+	str ("Search blacklist does "^(if b then "" else "not ")^"include "^s)
+      let synchronous = true
+     end)
+
 (* The functions print_constructors and crible implement the behavior needed
    for the Coq searching commands.
    These functions take as first argument the procedure
@@ -57,14 +65,14 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
 	     fn (VarRef id) env typ
 	 with Not_found -> (* we are in a section *) ())
     | "CONSTANT" ->
-	let cst = Global.constant_of_delta(constant_of_kn kn) in
+	let cst = Global.constant_of_delta_kn kn in
 	let typ = Typeops.type_of_constant env cst in
         if refopt = None
 	  || head_const typ = constr_of_global (Option.get refopt)
 	then
 	  fn (ConstRef cst) env typ
     | "INDUCTIVE" ->
-	let mind = Global.mind_of_delta(mind_of_kn kn) in
+	let mind = Global.mind_of_delta_kn kn in
         let mib = Global.lookup_mind mind in
         (match refopt with
 	  | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' ->
@@ -95,10 +103,6 @@ let rec head c =
   | LetIn (_,_,_,c) -> head c
   | _              -> c
 
-let constr_to_full_path c = match kind_of_term c with
-  | Const sp -> sp
-  | _ -> raise No_full_path
-
 let xor a b = (a or b) & (not (a & b))
 
 let plain_display ref a c =
@@ -170,6 +174,10 @@ let raw_search_by_head extra_filter display_function pattern =
 
 let name_of_reference ref = string_of_id (basename_of_global ref)
 
+let full_name_of_reference ref =
+  let (dir,id) = repr_path (path_of_global ref) in
+  string_of_dirpath dir ^ "." ^ string_of_id id
+
 (*
  * functions to use the new Libtypes facility
  *)
@@ -196,20 +204,21 @@ let filter_by_module_from_list = function
   | [], _ -> (fun _ _ _ -> true)
   | l, outside -> filter_by_module l (not outside)
 
-let filter_subproof gr _ _ =
-  not (string_string_contains (name_of_reference gr) "_subproof") &&
-  not (string_string_contains (name_of_reference gr) "_admitted")
+let filter_blacklist gr _ _ =
+  let name = full_name_of_reference gr in
+  let l = SearchBlacklist.elements () in
+  List.for_all (fun str -> not (string_string_contains ~where:name ~what:str)) l
 
 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
+  text_search_by_head (filter_by_module_from_list inout &&&&& filter_blacklist) pat
 
 let search_rewrite pat inout =
-  text_search_rewrite (filter_by_module_from_list inout &&&&& filter_subproof) pat
+  text_search_rewrite (filter_by_module_from_list inout &&&&& filter_blacklist) pat
 
 let search_pattern pat inout =
-  text_pattern_search (filter_by_module_from_list inout &&&&& filter_subproof) pat
+  text_pattern_search (filter_by_module_from_list inout &&&&& filter_blacklist) pat
 
 let gen_filtered_search filter_function display_function =
   gen_crible None
@@ -223,13 +232,13 @@ type glob_search_about_item =
 
 let search_about_item (itemref,typ) = function
   | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ
-  | GlobSearchString s -> string_string_contains (name_of_reference itemref) s
+  | GlobSearchString s -> string_string_contains ~where:(name_of_reference itemref) ~what:s
 
 let raw_search_about filter_modules display_function l =
   let filter ref' env typ =
     filter_modules ref' env typ &&
     List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l &&
-      filter_subproof ref' () ()
+      filter_blacklist ref' () ()
   in
   gen_filtered_search filter display_function
 
diff --git a/toplevel/search.mli b/toplevel/search.mli
index 6a85a12f..d2d5c538 100644
--- a/toplevel/search.mli
+++ b/toplevel/search.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: search.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Pp
 open Names
 open Term
@@ -16,7 +14,7 @@ open Pattern
 open Libnames
 open Nametab
 
-(*s Search facilities. *)
+(** {6 Search facilities. } *)
 
 type glob_search_about_item =
   | GlobSearchSubPattern of constr_pattern
@@ -28,14 +26,14 @@ 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.
+(** The filtering function that is by standard search facilities.
    It can be passed as argument to the raw search functions.
    It is used in pcoq. *)
 
 val filter_by_module_from_list :
   dir_path list * bool -> global_reference -> env -> 'a -> bool
 
-(* raw search functions can be used for various extensions.
+(** raw search functions can be used for various extensions.
    They are also used for pcoq. *)
 val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
       (global_reference -> env -> constr -> unit) -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index 9954ff56..699fd12f 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/toplevel.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: toplevel.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Flags
@@ -15,6 +13,7 @@ open Cerrors
 open Vernac
 open Vernacexpr
 open Pcoq
+open Compat
 
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
@@ -48,13 +47,12 @@ let resynch_buffer ibuf =
     | _ -> ()
 
 
-(* emacs special character for prompt end (fast) detection. Prefer
-   (Char.chr 6) since it does not interfere with utf8. For
-    compatibility we let (Char.chr 249) as default for a while. *)
+(* emacs special prompt tag for easy detection. No special character,
+   to avoid interfering with utf8. Compatibility code removed. *)
 
-let emacs_prompt_startstring() = Printer.emacs_str "" "<prompt>"
+let emacs_prompt_startstring() = Printer.emacs_str "<prompt>"
 
-let emacs_prompt_endstring() = Printer.emacs_str (String.make 1 (Char.chr 249)) "</prompt>"
+let emacs_prompt_endstring() = Printer.emacs_str "</prompt>"
 
 (* Read a char in an input channel, displaying a prompt at every
    beginning of line. *)
@@ -165,26 +163,26 @@ let print_location_in_file s inlibrary fname loc =
       hov 0 (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++ spc() ++
              str"characters " ++ Cerrors.print_loc loc) ++ fnl ()
     else
-    let (bp,ep) = unloc loc in
-    let ic = open_in fname in
-    let rec line_of_pos lin bol cnt =
-      if cnt < bp then
-        if input_char ic == '\n'
-        then line_of_pos (lin + 1) (cnt +1) (cnt+1)
-        else line_of_pos lin bol (cnt+1)
-      else (lin, bol)
-    in
-    try
-      let (line, bol) = line_of_pos 1 0 0 in
-      close_in ic;
-      hov 0 (* No line break so as to follow emacs error message format *)
-        (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++
-         str", line " ++ int line ++ str", characters " ++
-         Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++
-      fnl ()
-    with e ->
-      (close_in ic;
-       hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ())
+      let (bp,ep) = unloc loc in
+      let ic = open_in fname in
+      let rec line_of_pos lin bol cnt =
+        if cnt < bp then
+          if input_char ic == '\n'
+          then line_of_pos (lin + 1) (cnt +1) (cnt+1)
+          else line_of_pos lin bol (cnt+1)
+        else (lin, bol)
+      in
+      try
+        let (line, bol) = line_of_pos 1 0 0 in
+        close_in ic;
+        hov 0 (* No line break so as to follow emacs error message format *)
+          (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++
+           str", line " ++ int line ++ str", characters " ++
+           Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++
+        fnl ()
+      with e ->
+        (close_in ic;
+         hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ())
 
 let print_command_location ib dloc =
   match dloc with
@@ -274,7 +272,7 @@ let set_prompt prompt =
 let rec is_pervasive_exn = function
   | Out_of_memory | Stack_overflow | Sys.Break -> true
   | Error_in_file (_,_,e) -> is_pervasive_exn e
-  | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
+  | Loc.Exc_located (_,e) -> is_pervasive_exn e
   | DuringCommandInterp (_,e) -> is_pervasive_exn e
   | _ -> false
 
@@ -290,7 +288,7 @@ let print_toplevel_error exc =
   in
   let (locstrm,exc) =
     match exc with
-      | Stdpp.Exc_located (loc, ie) ->
+      | Loc.Exc_located (loc, ie) ->
           if valid_buffer_loc top_buffer dloc loc then
             (print_highlight_location top_buffer loc, ie)
           else
@@ -310,13 +308,13 @@ let print_toplevel_error exc =
 	raise Vernacexpr.Quit
     | _ ->
 	(if is_pervasive_exn exc then (mt ()) else locstrm) ++
-        Cerrors.explain_exn exc
+        Errors.print exc
 
 (* Read the input stream until a dot is encountered *)
 let parse_to_dot =
-  let rec dot st = match Stream.next st with
-    | ("", ".") -> ()
-    | ("EOI", "") -> raise End_of_input
+  let rec dot st = match get_tok (Stream.next st) with
+    | Tok.KEYWORD "." -> ()
+    | Tok.EOI -> raise End_of_input
     | _ -> dot st
   in
   Gram.Entry.of_parser "Coqtoplevel.dot" dot
@@ -324,8 +322,8 @@ let parse_to_dot =
 (* We assume that when a lexer error occurs, at least one char was eaten *)
 let rec discard_to_dot () =
   try
-    Gram.Entry.parse parse_to_dot top_buffer.tokens
-  with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) ->
+    Gram.entry_parse parse_to_dot top_buffer.tokens
+  with Loc.Exc_located(_,(Token.Error _|Lexer.Error.E _)) ->
     discard_to_dot()
 
 
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
index 022a6541..757aab1a 100644
--- a/toplevel/toplevel.mli
+++ b/toplevel/toplevel.mli
@@ -1,46 +1,42 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: toplevel.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Pcoq
-(*i*)
 
-(* The Coq toplevel loop. *)
+(** The Coq toplevel loop. *)
 
-(* A buffer for the character read from a channel. We store the command
+(** 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 = {
   mutable prompt : unit -> string;
-  mutable str : string; (* buffer of already read characters *)
-  mutable len : int;    (* number of chars in the buffer *)
-  mutable bols : int list; (* offsets in str of begining of lines *)
-  mutable tokens : Pcoq.Gram.parsable; (* stream of tokens *)
-  mutable start : int } (* stream count of the first char of the buffer *)
+  mutable str : string; (** buffer of already read characters *)
+  mutable len : int;    (** number of chars in the buffer *)
+  mutable bols : int list; (** offsets in str of begining of lines *)
+  mutable tokens : Pcoq.Gram.parsable; (** stream of tokens *)
+  mutable start : int } (** stream count of the first char of the buffer *)
 
-(* The input buffer of stdin. *)
+(** The input buffer of stdin. *)
 
 val top_buffer : input_buffer
 val set_prompt : (unit -> string) -> unit
 
-(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
+(** Toplevel error explanation, dealing with locations, Drop, Ctrl-D
   May raise only the following exceptions: [Drop] and [End_of_input],
   meaning we get out of the Coq loop. *)
 
 val print_toplevel_error : exn -> std_ppcmds
 
-(* Parse and execute a vernac command. *)
+(** Parse and execute a vernac command. *)
 
 val do_vernac : unit -> unit
 
-(* Main entry point of Coq: read and execute vernac commands. *)
+(** Main entry point of Coq: read and execute vernac commands. *)
 
 val loop : unit -> unit
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index 4c229d16..8b03e938 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -18,6 +18,8 @@ Mltop
 Vernacentries
 Whelp
 Vernac
+Ide_intf
+Ide_slave
 Toplevel
 Usage
 Coqinit
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 0282f30a..8c9b1078 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: usage.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-let version () =
+let version ret =
   Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
     Coq_config.version Coq_config.date;
   Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version;
-  exit 0
+  exit ret
 
 (* print the usage of coqtop (or coqc) on channel co *)
 
@@ -20,57 +18,59 @@ let print_usage_channel co command =
   output_string co command;
   output_string co "Coq options are:\n";
   output_string co
-"  -I dir -as coqdir      map physical dir to logical coqdir
-  -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 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
-  -exclude-dir f         exclude subdirectories named f for option -R
-
-  -inputstate f          read state from file f.coq
-  -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-vernac-source f  load Coq file f.v (Load f.)
-  -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
-  -require f             load Coq object file f.vo and import it (Require f.)
-  -compile f             compile Coq file f.v (implies -batch)
-  -compile-verbose f     verbosely compile Coq file f.v (implies -batch)
-
-  -opt                   run the native-code version of Coq
-  -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
-  -init-file f           set the rcfile to f
-  -user u                use the rcfile of user u
-  -batch                 batch mode (exits just after arguments parsing)
-  -boot                  boot mode (implies -q and -batch)
-  -emacs                 tells Coq it is executed under Emacs
-  -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
-  -dont-load-proofs      don't load opaque proofs in memory
-  -xml                   export XML files either to the hierarchy rooted in
-                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to
-                         stdout (if unset)
-  -quality               improve the legibility of the proof terms produced by
-                         some tactics
-  -h, --help             print this list of options
-"
+"  -I dir -as coqdir      map physical dir to logical coqdir\
+\n  -I dir                 map directory dir to the empty logical path\
+\n  -include dir           (idem)\
+\n  -R dir -as coqdir      recursively map physical dir to logical coqdir\
+\n  -R dir coqdir          (idem)\
+\n  -top coqdir            set the toplevel name to be coqdir instead of Top\
+\n  -notop                 set the toplevel name to be the empty logical path\
+\n  -exclude-dir f         exclude subdirectories named f for option -R\
+\n\
+\n  -inputstate f          read state from file f.coq\
+\n  -is f                  (idem)\
+\n  -nois                  start with an empty state\
+\n  -outputstate f         write state in file f.coq\
+\n  -compat X.Y            provides compatibility support for Coq version X.Y\
+\n\
+\n  -load-ml-object f      load ML object file f\
+\n  -load-ml-source f      load ML file f\
+\n  -load-vernac-source f  load Coq file f.v (Load f.)\
+\n  -l f                   (idem)\
+\n  -load-vernac-source-verbose f  load Coq file f.v (Load Verbose f.)\
+\n  -lv f	                 (idem)\
+\n  -load-vernac-object f  load Coq object file f.vo\
+\n  -require f             load Coq object file f.vo and import it (Require f.)\
+\n  -compile f             compile Coq file f.v (implies -batch)\
+\n  -compile-verbose f     verbosely compile Coq file f.v (implies -batch)\
+\n\
+\n  -opt                   run the native-code version of Coq\
+\n  -byte                  run the bytecode version of Coq\
+\n\
+\n  -where                 print Coq's standard library location and exit\
+\n  -config                print Coq's configuration information and exit\
+\n  -v                     print Coq version and exit\
+\n\
+\n  -q                     skip loading of rcfile\
+\n  -init-file f           set the rcfile to f\
+\n  -batch                 batch mode (exits just after arguments parsing)\
+\n  -boot                  boot mode (implies -q and -batch)\
+\n  -emacs                 tells Coq it is executed under Emacs\
+\n  -noglob                do not dump globalizations\
+\n  -dump-glob f           dump globalizations in file f (to be used by coqdoc)\
+\n  -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\
+\n  -impredicative-set     set sort Set impredicative\
+\n  -force-load-proofs     load opaque proofs in memory initially\
+
+\n  -lazy-load-proofs      load opaque proofs in memory by necessity (default)\
+\n  -dont-load-proofs      see opaque proofs as axioms instead of loading them\
+\n  -xml                   export XML files either to the hierarchy rooted in\
+\n                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to\
+\n                         stdout (if unset)\
+\n  -quality               improve the legibility of the proof terms produced by\
+\n                         some tactics\
+\n  -h, --help             print this list of options\
+\n"
 
 (* print the usage on standard error *)
 
@@ -80,22 +80,25 @@ let print_usage_coqtop () =
   print_usage "Usage: coqtop <options>\n\n"
 
 let print_usage_coqc () =
-  print_usage "Usage: coqc <options> <Coq options> file...\n
-options are:
-  -verbose  compile verbosely
-  -image f  specify an alternative executable for Coq
-  -t        keep temporary files\n\n"
+  print_usage "Usage: coqc <options> <Coq options> file...\n\
+\noptions are:\
+\n  -verbose  compile verbosely\
+\n  -image f  specify an alternative executable for Coq\
+\n  -t        keep temporary files\n\n"
 
 (* Print the configuration information *)
 
 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;
-  Printf.printf "CAMLBIN=%s/\n" Coq_config.camlbin;
-  Printf.printf "CAMLLIB=%s/\n" Coq_config.camllib;
+  Printf.printf "COQLIB=%s/\n" (Envars.coqlib ());
+  Printf.printf "DOCDIR=%s/\n" (Envars.docdir ());
+  Printf.printf "OCAMLDEP=%s\n" Coq_config.ocamldep;
+  Printf.printf "OCAMLC=%s\n" Coq_config.ocamlc;
+  Printf.printf "OCAMLOPT=%s\n" Coq_config.ocamlopt;
+  Printf.printf "OCAMLDOC=%s\n" Coq_config.ocamldoc;
+  Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ());
+  Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ());
   Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
-  Printf.printf "CAMLP4BIN=%s\n" Coq_config.camlp4bin;
-  Printf.printf "CAMLP4LIB=%s\n" Coq_config.camlp4lib
-
-
+  Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
+  Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ());
+  Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false")
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index 721edccb..0b98f061 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -1,23 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: usage.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** {6 Prints the version number on the standard output and exits (with 0). } *)
 
-(*s Prints the version number on the standard output and exits (with 0). *)
+val version : int -> 'a
 
-val version : unit -> 'a
-
-(*s Prints the usage on the error output, preceeded by a user-provided message. *)
+(** {6 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. *)
+(** {6 Prints the usage on the error output. } *)
 val print_usage_coqtop : unit -> unit
 val print_usage_coqc : unit -> unit
 
-(*s Prints the configuration information *)
+(** {6 Prints the configuration information } *)
 val print_config : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index a7aef93f..84e20f5e 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Parsing of vernacular. *)
 
 open Pp
@@ -18,6 +16,7 @@ open System
 open Vernacexpr
 open Vernacinterp
 open Ppvernac
+open Compat
 
 (* The functions in this module may raise (unexplainable!) exceptions.
    Use the module Coqtoplevel, which catches these exceptions
@@ -41,14 +40,14 @@ let raise_with_file file exc =
     match re with
       | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc ->
           ((b, f, loc), e)
-      | Stdpp.Exc_located (loc, e) when loc <> dummy_loc ->
+      | Loc.Exc_located (loc, e) when loc <> dummy_loc ->
           ((false,file, loc), e)
-      | Stdpp.Exc_located (_, e) | e -> ((false,file,cmdloc), e)
+      | Loc.Exc_located (_, e) | e -> ((false,file,cmdloc), e)
   in
   raise (Error_in_file (file, inner, disable_drop inex))
 
 let real_error = function
-  | Stdpp.Exc_located (_, e) -> e
+  | Loc.Exc_located (_, e) -> e
   | Error_in_file (_, _, e) -> e
   | e -> e
 
@@ -62,6 +61,7 @@ let default_timeout = ref None
 let _ =
   Goptions.declare_int_option
     { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
       Goptions.optname  = "the default timeout";
       Goptions.optkey   = ["Default";"Timeout"];
       Goptions.optread  = (fun () -> !default_timeout);
@@ -133,8 +133,8 @@ let verbose_phrase verbch loc =
 
 exception End_of_input
 
-let parse_phrase (po, verbch) =
-  match Pcoq.Gram.Entry.parse Pcoq.main_entry po with
+let parse_sentence (po, verbch) =
+  match Pcoq.Gram.entry_parse Pcoq.main_entry po with
     | Some (loc,_ as com) -> verbose_phrase verbch loc; com
     | None -> raise End_of_input
 
@@ -211,10 +211,11 @@ let rec vernac_com interpfun (loc,com) =
 	  | 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
-	      if_verbose msgnl (str "The command has indeed failed with message:" ++
-		     fnl () ++ str "=> " ++ hov 0 msg)
+	      (* Anomalies are re-raised by the next line *)
+	      let msg = Errors.print_no_anomaly e in
+	      if_verbose msgnl
+		(str "The command has indeed failed with message:" ++
+		 fnl () ++ str "=> " ++ hov 0 msg)
 	end
 
     | VernacTime v ->
@@ -249,22 +250,21 @@ let rec vernac_com interpfun (loc,com) =
       Format.set_formatter_out_channel stdout;
       raise (DuringCommandInterp (loc, e))
 
-and vernac interpfun input =
-  vernac_com interpfun (parse_phrase input)
-
 and read_vernac_file verbosely s =
   Flags.make_warn verbosely;
   let interpfun =
-    if verbosely then
-      Vernacentries.interp
-    else
-      Flags.silently Vernacentries.interp
+    if verbosely then Vernacentries.interp
+    else Flags.silently Vernacentries.interp
   in
-  let (in_chan, fname, input) = open_file_twice_if verbosely s in
+  let (in_chan, fname, input) =
+    open_file_twice_if verbosely s in
   try
     (* we go out of the following infinite loop when a End_of_input is
      * raised, which means that we raised the end of the file being loaded *)
-    while true do vernac interpfun input; pp_flush () done
+    while true do
+      vernac_com interpfun (parse_sentence input);
+      pp_flush ()
+    done
   with e ->   (* whatever the exception *)
     Format.set_formatter_out_channel stdout;
     close_input in_chan input;    (* we must close the file first *)
@@ -273,17 +273,20 @@ and read_vernac_file verbosely s =
           if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None
       | _ -> raise_with_file fname e
 
-(* raw_do_vernac : char Stream.t -> unit
- * parses and executes one command of the vernacular char stream.
- * Marks the end of the command in the lib_stk with a new label to
- * make vernac undoing easier. Also freeze state to speed up
- * backtracking. *)
 
-let raw_do_vernac po =
-  vernac Vernacentries.interp (po,None);
+(* eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit
+ * execute one vernacular command. Marks the end of the command in the lib_stk
+ * with a new label to make vernac undoing easier. Also freeze state to speed up
+ * backtracking. *)
+let eval_expr last =
+  vernac_com Vernacentries.interp last;
   Lib.add_frozen_state();
   Lib.mark_end_of_command()
 
+(* raw_do_vernac : Pcoq.Gram.parsable -> unit
+ * vernac_step . parse_sentence *)
+let raw_do_vernac po = eval_expr (parse_sentence (po,None))
+
 (* XML output hooks *)
 let xml_start_library = ref (fun _ -> ())
 let xml_end_library = ref (fun _ -> ())
@@ -305,15 +308,14 @@ let load_vernac verb file =
 (* 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
-      Dumpglob.open_glob_file (f ^ ".glob");
-    Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
-    if !Flags.xml_export then !xml_start_library ();
-    let _ = load_vernac verbosely long_f_dot_v in
-     if Pfedit.get_all_proof_names () <> [] then
-	(message "Error: There are pending proofs"; exit 1);
-      if !Flags.xml_export then !xml_end_library ();
-      if Dumpglob.multi_dump () then Dumpglob.close_glob_file ();
-      Library.save_library_to ldir (long_f_dot_v ^ "o")
+  Dumpglob.start_dump_glob long_f_dot_v;
+  Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
+  if !Flags.xml_export then !xml_start_library ();
+  let _ = load_vernac verbosely long_f_dot_v in
+  if Pfedit.get_all_proof_names () <> [] then
+    (message "Error: There are pending proofs"; exit 1);
+  if !Flags.xml_export then !xml_end_library ();
+  Dumpglob.end_dump_glob ();
+  Library.save_library_to ldir (long_f_dot_v ^ "o")
 
 
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 54ce9244..d89e90d0 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -1,46 +1,39 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Parsing of vernacular. *)
 
-(* Parsing of vernacular. *)
-
-(* Read a vernac command on the specified input (parse only).
+(** Read a vernac command on the specified input (parse only).
    Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
 
-val parse_phrase : Pcoq.Gram.parsable * in_channel option ->
-  Util.loc * Vernacexpr.vernac_expr
+val parse_sentence : Pcoq.Gram.parsable * in_channel option ->
+ Util.loc * Vernacexpr.vernac_expr
 
-(* Reads and executes vernac commands from a stream.
+(** Reads and executes vernac commands from a stream.
    The boolean [just_parsing] disables interpretation of commands. *)
 
 exception DuringCommandInterp of Util.loc * exn
 exception End_of_input
 
 val just_parsing : bool ref
+val eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit
 val raw_do_vernac : Pcoq.Gram.parsable -> unit
 
-(* Set XML hooks *)
+(** Set XML hooks *)
 val set_xml_start_library : (unit -> unit) -> unit
 val set_xml_end_library   : (unit -> unit) -> unit
 
-(* Load a vernac file, verbosely or not. Errors are annotated with file
+(** Load a vernac file, verbosely or not. Errors are annotated with file
    and location *)
 
 val load_vernac : bool -> string -> unit
 
 
-(* Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
+(** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
 
 val compile : bool -> string -> unit
-
-(* Interpret a vernac AST *)
-
-val vernac_com :
-  (Vernacexpr.vernac_expr -> unit) ->
-  Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 3be3c6db..5787feb0 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
 
 open Pp
@@ -19,12 +17,9 @@ open Nameops
 open Term
 open Pfedit
 open Tacmach
-open Proof_trees
-open Decl_mode
 open Constrintern
 open Prettyp
 open Printer
-open Tactic_printer
 open Tacinterp
 open Command
 open Goptions
@@ -37,6 +32,7 @@ open Pretyping
 open Redexpr
 open Syntax_def
 open Lemmas
+open Declaremods
 
 (* Pcoq hooks *)
 
@@ -49,7 +45,7 @@ type pcoq_hook = {
   print_check : Environ.env -> Environ.unsafe_judgment -> unit;
   print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
     Environ.unsafe_judgment -> unit;
-  show_goal : int option -> unit
+  show_goal : goal_reference -> unit
 }
 
 let pcoq = ref None
@@ -66,52 +62,34 @@ let cl_of_qualid = function
 (* "Show" commands *)
 
 let show_proof () =
-  let pts = get_pftreestate () in
-  let cursor = cursor_of_pftreestate pts in
-  let evc = evc_of_pftreestate pts in
-  let (pfterm,meta_types) = extract_open_pftreestate pts in
-  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" -> " ++
-      pr_ltype ty ++ fnl ())
-      meta_types
-    ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm))
+  (* spiwack: this would probably be cooler with a bit of polishing. *)
+  let p = Proof_global.give_me_the_proof () in
+  let pprf = Proof.partial_proof p in
+  msgnl (Util.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
 
 let show_node () =
-  let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts
-  and cursor = cursor_of_pftreestate pts in
-  msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
-         pr_goal (goal_of_proof pf) ++ fnl () ++
-         (match pf.Proof_type.ref with
-            | None -> (str"BY <rule>")
-            | Some(r,spfl) ->
-		(str"BY " ++ pr_rule r ++ fnl () ++
-		 str"  " ++
-		   hov 0 (prlist_with_sep pr_fnl pr_goal
-			    (List.map goal_of_proof spfl)))))
+  (* spiwack: I'm have little clue what this function used to do. I deactivated it, 
+      could, possibly, be cleaned away. (Feb. 2010) *)
+  ()
 
 let show_script () =
-  let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts
-  and evc = evc_of_pftreestate pts in
-  msgnl_with !Pp_control.deep_ft (print_treescript evc pf)
+  (* spiwack: show_script is currently not working *)
+  ()
 
 let show_thesis () =
      msgnl (anomaly "TODO" )
 
 let show_top_evars () =
+  (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
   let pfts = get_pftreestate () in
-  let gls = top_goal_of_pftreestate pfts in
-  let sigma = project gls in
+  let gls = Proof.V82.subgoals pfts in
+  let sigma = gls.Evd.sigma in
   msg (pr_evars_int 1 (Evarutil.non_instantiated sigma))
+  
 
 let show_prooftree () =
-  let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts
-  and evc = evc_of_pftreestate pts in
-  msg (print_proof evc (Global.named_context()) pf)
+  (* Spiwack: proof tree is currently not working *)
+  ()
 
 let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
 
@@ -119,7 +97,8 @@ 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 {Evd.it=gls ; sigma=sigma} = Proof.V82.subgoals pf in
+  let gl = {Evd.it=List.hd gls ; sigma = sigma} in
   let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
   if all
   then
@@ -131,13 +110,12 @@ let show_intro all =
       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"
-  | Names.Name x -> x
-
+(** Prepare a "match" template for a given inductive type.
+    For each branch of the match, we list the constructor name
+    followed by enough pattern variables.
+    [Not_found] is raised if the given string isn't the qualid of
+    a known inductive type. *)
 
-(* Building of match expression *)
-(* From ide/coq.ml *)
 let make_cases s =
   let qualified_name = Libnames.qualid_of_string s in
   let glob_ref = Nametab.locate qualified_name in
@@ -147,36 +125,31 @@ let make_cases s =
 	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr }
 	      = Global.lookup_inductive i in
 	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
+	  (fun consname typ l ->
+	     let al = List.rev (fst (Term.decompose_prod typ)) in
+	     let al = Util.list_skipn np al in
 	     let rec rename avoid = function
 	       | [] -> []
 	       | (n,_)::l ->
-		   let n' = Namegen.next_ident_away_in_goal (id_of_name n) avoid in
+		   let n' = Namegen.next_name_away_in_cases_pattern 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)
+	     let al' = rename [] al in
+	     (string_of_id consname :: al') :: l)
 	  carr tarr []
     | _ -> raise Not_found
 
+(** Textual display of a generic "match" template *)
 
 let show_match id =
-  try
-    let s = string_of_id (snd id) in
-    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
-		^ " => \n" ^ acc)
-	"end" patterns in
-    msg (str ("match # with\n" ^ cases))
-  with Not_found -> error "Unknown inductive type."
+  let patterns =
+    try make_cases (string_of_id (snd id))
+    with Not_found -> error "Unknown inductive type."
+  in
+  let pr_branch l =
+    str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>"
+  in
+  msg (v 1 (str "match # with" ++ fnl () ++
+	    prlist_with_sep fnl pr_branch patterns ++ fnl ()))
 
 (* "Print" commands *)
 
@@ -220,18 +193,55 @@ let print_modtype r =
   let (loc,qid) = qualid_of_reference r in
   try
     let kn = Nametab.locate_modtype qid in
-      msgnl (Printmod.print_modtype kn)
-  with
-      Not_found -> msgnl (str"Unknown Module Type " ++ pr_qualid qid)
+    msgnl (Printmod.print_modtype kn)
+  with Not_found ->
+    (* Is there a module of this name ? If yes we display its type *)
+    try
+      let mp = Nametab.locate_module qid in
+      msgnl (Printmod.print_module false mp)
+    with Not_found ->
+      msgnl (str"Unknown Module Type or Module " ++ pr_qualid qid)
 
-let dump_universes s =
+let dump_universes_gen g s =
   let output = open_out s in
+  let output_constraint, close =
+    if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin
+      (* the lazy unit is to handle errors while printing the first line *)
+      let init = lazy (Printf.fprintf output "digraph universes {\n") in
+      begin fun kind left right ->
+        let () = Lazy.force init in
+        match kind with
+          | Univ.Lt ->
+            Printf.fprintf output "  \"%s\" -> \"%s\" [style=bold];\n" right left
+          | Univ.Le ->
+            Printf.fprintf output "  \"%s\" -> \"%s\" [style=solid];\n" right left
+          | Univ.Eq ->
+            Printf.fprintf output "  \"%s\" -> \"%s\" [style=dashed];\n" left right
+      end, begin fun () ->
+        if Lazy.lazy_is_val init then Printf.fprintf output "}\n";
+        close_out output
+      end
+    end else begin
+      begin fun kind left right ->
+        let kind = match kind with
+          | Univ.Lt -> "<"
+          | Univ.Le -> "<="
+          | Univ.Eq -> "="
+        in Printf.fprintf output "%s %s %s ;\n" left kind right
+      end, (fun () -> close_out output)
+    end
+  in
   try
-    Univ.dump_universes output (Global.universes ());
-    close_out output;
+    Univ.dump_universes output_constraint g;
+    close ();
     msgnl (str ("Universes written to file \""^s^"\"."))
   with
-      e -> close_out output; raise e
+      e -> close (); raise e
+
+let dump_universes sorted s =
+  let g = Global.universes () in
+  let g = if sorted then Univ.sort_universes g else g in
+  dump_universes_gen g s
 
 (*********************)
 (* "Locate" commands *)
@@ -318,7 +328,7 @@ let start_proof_and_print k l hook =
   print_subgoals ();
   if !pcoq <> None then (Option.get !pcoq).start_proof ()
 
-let vernac_definition (local,boxed,k) (loc,id as lid) def hook =
+let vernac_definition (local,k) (loc,id as lid) def hook =
   if local = Local then Dumpglob.dump_definition lid true "var"
   else Dumpglob.dump_definition lid false "def";
   (match def with
@@ -332,7 +342,7 @@ let vernac_definition (local,boxed,k) (loc,id as lid) def hook =
           | Some r ->
 	      let (evc,env)= get_current_context () in
  		Some (interp_redexp env evc r) in
-	let ce,imps = interp_definition boxed bl red_option c typ_opt in
+	let ce,imps = interp_definition bl red_option c typ_opt in
 	declare_definition id (local,k) ce imps hook)
 
 let vernac_start_proof kind l lettop hook =
@@ -360,14 +370,10 @@ let vernac_end_proof = function
      the theories [??] *)
 
 let vernac_exact_proof c =
-  let pfs = top_of_tree (get_pftreestate()) in
-  let pf = proof_of_pftreestate pfs in
-    if (is_leaf_proof pf) then begin
-      by (Tactics.exact_proof c);
-      save_named true end
-    else
-      errorlabstrm "Vernacentries.ExactProof"
-	(strbrk "Command 'Proof ...' can only be used at the beginning of the proof.")
+  (* spiwack: for simplicity I do not enforce that "Proof proof_term" is
+     called only at the begining of a proof. *)
+    by (Tactics.exact_proof c);
+      save_named true
 
 let vernac_assumption kind l nl=
   let global = fst kind = Global in
@@ -386,7 +392,7 @@ let vernac_record k finite infer struc binders sort nameopt cfs =
 	Dumpglob.dump_definition lid false "constr"; id in
     if Dumpglob.dump () then (
       Dumpglob.dump_definition (snd struc) false "rec";
-      List.iter (fun ((_, x), _) ->
+      List.iter (fun (((_, x), _), _) ->
 	match x with
 	| Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj"
 	| _ -> ()) cfs);
@@ -409,7 +415,8 @@ let vernac_inductive finite infer indl =
   | [ ( id , bl , c , Class true, Constructors [l]), _ ] ->
       let f =
 	let (coe, ((loc, id), ce)) = l in
-	  ((coe, AssumExpr ((loc, Name id), ce)), [])
+	let coe' = if coe then Some true else None in
+	  (((coe', AssumExpr ((loc, Name id), ce)), None), [])
       in vernac_record (Class true) finite infer id bl c None [f]
   | [ ( id , bl , c , Class true, _), _ ] ->
       Util.error "Definitional classes must have a single method"
@@ -424,15 +431,15 @@ let vernac_inductive finite infer indl =
     let indl = List.map unpack indl in
     do_mutual_inductive indl (recursivity_flag_of_kind finite)
 
-let vernac_fixpoint l b =
+let vernac_fixpoint l =
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_fixpoint l b
+  do_fixpoint l
 
-let vernac_cofixpoint l b =
+let vernac_cofixpoint l =
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_cofixpoint l b
+  do_cofixpoint l
 
 let vernac_scheme = Indschemes.do_scheme
 
@@ -585,10 +592,10 @@ let vernac_end_section (loc,_) =
 let vernac_end_segment (_,id as lid) =
   check_no_pending_proofs ();
   match Lib.find_opening_node id with
-  | Lib.OpenedModule (export,_,_) -> vernac_end_module export lid
-  | Lib.OpenedModtype _ -> vernac_end_modtype lid
+  | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid
+  | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid
   | Lib.OpenedSection _ -> vernac_end_section lid
-  | _ -> anomaly "No more opened things"
+  | _ -> assert false
 
 (* Libraries *)
 
@@ -608,13 +615,13 @@ let vernac_coercion stre ref qids qidt =
   let target = cl_of_qualid qidt in
   let source = cl_of_qualid qids in
   let ref' = smart_global ref in
-  Class.try_add_new_coercion_with_target ref' stre source target;
+  Class.try_add_new_coercion_with_target ref' stre ~source ~target;
   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
   let source = cl_of_qualid qids in
-  Class.try_add_new_identity_coercion id stre source target
+  Class.try_add_new_identity_coercion id stre ~source ~target
 
 (* Type classes *)
 
@@ -625,32 +632,32 @@ let vernac_instance abst glob sup inst props pri =
 let vernac_context l =
   Classes.context l
 
-let vernac_declare_instance glob id =
-  Classes.declare_instance glob id
+let vernac_declare_instances glob ids =
+  List.iter (fun (id) -> Classes.existing_instance glob id) ids
 
 let vernac_declare_class id =
   Classes.declare_class id
 
 (***********)
 (* Solving *)
+
+let command_focus = Proof.new_focus_kind ()
+let focus_command_cond = Proof.no_cond command_focus
+
+
 let vernac_solve n tcom b =
   if not (refining ()) then
     error "Unknown command of the non proof-editing mode.";
-  Decl_mode.check_not_proof_mode "Unknown proof instruction";
-  begin
-    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 *)
-  if subtree_solved () then begin
-    Flags.if_verbose msgnl (str "Subgoal proved");
-    make_focus 0;
-    reset_top_of_script ()
-  end;
-  print_subgoals();
-  if !pcoq <> None then (Option.get !pcoq).solve n
+  let p = Proof_global.give_me_the_proof () in
+  Proof.transaction p begin fun () ->
+    solve_nth n (Tacinterp.hide_interp tcom None) ~with_end_tac:b;
+    (* in case a strict subtree was completed,
+       go back to the top of the prooftree *)
+    Proof_global.maximal_unfocus command_focus p;
+    print_subgoals();
+    if !pcoq <> None then (Option.get !pcoq).solve n
+  end
+ 
 
   (* A command which should be a tactic. It has been
      added by Christine to patch an error in the design of the proof
@@ -666,32 +673,15 @@ let vernac_set_end_tac tac =
   if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else ()
     (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
 
-(***********************)
-(* Proof Language Mode *)
-
-let vernac_decl_proof () =
-  check_not_proof_mode "Already in Proof Mode";
-  if tree_solved () then
-    error "Nothing left to prove here."
-  else
-    begin
-      Decl_proof_instr.go_to_proof_mode ();
-      print_subgoals ()
-    end
-
-let vernac_return () =
-  match get_current_mode () with
-      Mode_tactic ->
-	Decl_proof_instr.return_from_tactic_mode ();
-	print_subgoals ()
-    | Mode_proof ->
-	error "\"return\" is only used after \"escape\"."
-    | Mode_none ->
-	error "There is no proof to end."
-
-let vernac_proof_instr instr =
-  Decl_proof_instr.proof_instr instr;
-  print_subgoals ()
+let vernac_set_used_variables l =
+  let l = List.map snd l in
+  if not (list_distinct l) then error "Used variables list contains duplicates";
+  let vars = Environ.named_context (Global.env ()) in
+  List.iter (fun id -> 
+    if not (List.exists (fun (id',_,_) -> id = id') vars) then
+      error ("Unknown variable: " ^ string_of_id id))
+    l;
+  set_used_variables l
 
 (*****************************)
 (* Auxiliary file management *)
@@ -706,7 +696,7 @@ let vernac_add_loadpath isrec pdir ldiropt =
   let alias = match ldiropt with
     | None -> Nameops.default_root_prefix
     | Some ldir -> ldir in
-  (if isrec then Mltop.add_rec_path else Mltop.add_path) pdir alias
+  (if isrec then Mltop.add_rec_path else Mltop.add_path) ~unix_path:pdir ~coq_root:alias
 
 let vernac_remove_loadpath path =
   Library.remove_load_path (System.expand_path_macros path)
@@ -764,6 +754,9 @@ let vernac_declare_tactic_definition (local,x,def) =
 let vernac_create_hintdb local id b =
   Auto.create_hint_db local id full_transparent_state b
 
+let vernac_remove_hints local dbs ids =
+  Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids)
+
 let vernac_hints local lb h =
   Auto.add_hints local lb (Auto.interp_hints h)
 
@@ -778,11 +771,89 @@ let vernac_declare_implicits local r = function
       Impargs.declare_manual_implicits local (smart_global r) ~enriching:false
 	(List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps)
 
+let vernac_declare_arguments local r l nargs flags =
+  let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
+  let names, rest = List.hd names, List.tl names in
+  if List.exists ((<>) names) rest then
+    error "All arguments lists must declare the same names.";
+  if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then
+    error "Arguments names must be distinct.";
+  let sr = smart_global r in
+  let inf_names =
+    Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in
+  let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in
+  let rec check li ld = match li, ld with
+    | [], [] -> ()
+    | [], x::_ -> error ("Extra argument " ^ string_of_name x ^ ".")
+    | l, [] -> error ("The following arguments are not declared: " ^
+       (String.concat ", " (List.map string_of_name l)) ^ ".")
+    | _::li, _::ld -> check li ld in
+  if l <> [[]] then
+    List.iter (fun l -> check inf_names l) (names :: rest);
+  (* we interpret _ as the inferred names *)
+  let l = if l = [[]] then l else
+    let name_anons = function
+      | (Anonymous, a,b,c,d), Name id -> Name id, a,b,c,d
+      | x, _ -> x in
+    List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in
+  let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
+  let some_renaming_specified =
+    try Arguments_renaming.arguments_names sr <> names_decl
+    with Not_found -> false in
+  let some_renaming_specified, implicits =
+    if l = [[]] then false, [[]] else
+    Util.list_fold_map (fun sr il ->
+      let sr', impl = Util.list_fold_map (fun b -> function
+        | (Anonymous, _,_, true, max), Name id -> assert false
+        | (Name x, _,_, true, _), Anonymous ->
+            error ("Argument "^string_of_id x^" cannot be declared implicit.")
+        | (Name iid, _,_, true, max), Name id ->
+           b || iid <> id, Some (ExplByName id, max, false)
+        | (Name iid, _,_, _, _), Name id -> b || iid <> id, None
+        | _ -> b, None)
+        sr (List.combine il inf_names) in
+      sr || sr', Util.list_map_filter (fun x -> x) impl)
+      some_renaming_specified l in
+  if some_renaming_specified then
+    if not (List.mem `Rename flags) then
+      error "To rename arguments the \"rename\" flag must be specified."
+    else Arguments_renaming.rename_arguments local sr names_decl;
+  (* All other infos are in the first item of l *)
+  let l = List.hd l in
+  let some_implicits_specified = implicits <> [[]] in
+  let scopes = List.map (function
+    | (_,_, None,_,_) -> None
+    | (_,_, Some (o, k), _,_) -> 
+        try Some(ignore(Notation.find_scope k); k)
+        with _ -> Some (Notation.find_delimiters_scope o k)) l in
+  let some_scopes_specified = List.exists ((<>) None) scopes in
+  let rargs =
+    Util.list_map_filter (function (n, true) -> Some n | _ -> None)
+      (Util.list_map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in
+  if some_scopes_specified || List.mem `ClearScopes flags then
+    vernac_arguments_scope local r scopes;
+  if not some_implicits_specified && List.mem `DefaultImplicits flags then
+    vernac_declare_implicits local r []
+  else if some_implicits_specified || List.mem `ClearImplicits flags then
+    vernac_declare_implicits local r implicits;
+  if nargs >= 0 && nargs < List.fold_left max 0 rargs then
+    error "The \"/\" option must be placed after the last \"!\".";
+  let rec narrow = function
+    | #Tacred.simpl_flag as x :: tl -> x :: narrow tl
+    | [] -> [] | _ :: tl -> narrow tl in
+  let flags = narrow flags in
+  if rargs <> [] || nargs >= 0 || flags <> [] then
+    match sr with
+    | ConstRef _ as c ->
+       Tacred.set_simpl_behaviour local c (rargs, nargs, flags)
+    | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.")
+
 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)
+    let t = Detyping.detype false [] [] t in
+    let t = aconstr_of_glob_constr [] [] t in
+    Reserve.declare_reserved_type idl t)
   in List.iter sb_decl bl
 
 let vernac_generalizable = Implicit_quantifiers.declare_generalizable
@@ -795,6 +866,7 @@ let make_silent_if_not_pcoq b =
 let _ =
   declare_bool_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "silent";
       optkey   = ["Silent"];
       optread  = is_silent;
@@ -803,6 +875,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit arguments";
       optkey   = ["Implicit";"Arguments"];
       optread  = Impargs.is_implicit_args;
@@ -811,6 +884,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "strict implicit arguments";
       optkey   = ["Strict";"Implicit"];
       optread  = Impargs.is_strict_implicit_args;
@@ -819,6 +893,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "strong strict implicit arguments";
       optkey   = ["Strongly";"Strict";"Implicit"];
       optread  = Impargs.is_strongly_strict_implicit_args;
@@ -827,22 +902,16 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "contextual implicit arguments";
       optkey   = ["Contextual";"Implicit"];
       optread  = Impargs.is_contextual_implicit_args;
       optwrite = Impargs.make_contextual_implicit_args }
 
-(* let _ = *)
-(*   declare_bool_option  *)
-(*     { optsync  = true; *)
-(*       optname  = "forceable implicit arguments"; *)
-(*       optkey   = ["Forceable";"Implicit")); *)
-(*       optread  = Impargs.is_forceable_implicit_args; *)
-(*       optwrite = Impargs.make_forceable_implicit_args } *)
-
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit status of reversible patterns";
       optkey   = ["Reversible";"Pattern";"Implicit"];
       optread  = Impargs.is_reversible_pattern_implicit_args;
@@ -851,6 +920,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "maximal insertion of implicit";
       optkey   = ["Maximal";"Implicit";"Insertion"];
       optread  = Impargs.is_maximal_implicit_args;
@@ -859,6 +929,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic introduction of variables";
       optkey   = ["Automatic";"Introduction"];
       optread  = Flags.is_auto_intros;
@@ -867,6 +938,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "coercion printing";
       optkey   = ["Printing";"Coercions"];
       optread  = (fun () -> !Constrextern.print_coercions);
@@ -875,6 +947,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "printing of existential variable instances";
       optkey   = ["Printing";"Existential";"Instances"];
       optread  = (fun () -> !Constrextern.print_evar_arguments);
@@ -882,6 +955,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit arguments printing";
       optkey   = ["Printing";"Implicit"];
       optread  = (fun () -> !Constrextern.print_implicits);
@@ -890,6 +964,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit arguments defensive printing";
       optkey   = ["Printing";"Implicit";"Defensive"];
       optread  = (fun () -> !Constrextern.print_implicits_defensive);
@@ -898,6 +973,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "projection printing using dot notation";
       optkey   = ["Printing";"Projections"];
       optread  = (fun () -> !Constrextern.print_projections);
@@ -906,6 +982,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "notations printing";
       optkey   = ["Printing";"Notations"];
       optread  = (fun () -> not !Constrextern.print_no_symbol);
@@ -914,6 +991,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "raw printing";
       optkey   = ["Printing";"All"];
       optread  = (fun () -> !Flags.raw_print);
@@ -922,38 +1000,57 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
+      optname  = "record printing";
+      optkey   = ["Printing";"Records"];
+      optread  = (fun () -> !Flags.record_print);
+      optwrite = (fun b -> Flags.record_print := b) }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
       optname  = "use of virtual machine inside the kernel";
       optkey   = ["Virtual";"Machine"];
       optread  = (fun () -> Vconv.use_vm ());
       optwrite = (fun b -> Vconv.set_use_vm b) }
 
 let _ =
-  declare_bool_option
+  declare_int_option
     { optsync  = true;
-      optname  = "use of boxed definitions";
-      optkey   = ["Boxed";"Definitions"];
-      optread  = Flags.boxed_definitions;
-      optwrite = (fun b -> Flags.set_boxed_definitions b) }
+      optdepr  = false;
+      optname  = "the level of inling duging functor application";
+      optkey   = ["Inline";"Level"];
+      optread  = (fun () -> Some (Flags.get_inline_level ()));
+      optwrite = (fun o ->
+	           let lev = Option.default Flags.default_inline_level o in
+	           Flags.set_inline_level lev) }
 
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "use of boxed values";
       optkey   = ["Boxed";"Values"];
       optread  = (fun _ -> not (Vm.transp_values ()));
       optwrite = (fun b -> Vm.set_transp_values (not b)) }
 
+(* No more undo limit in the new proof engine.
+   The command still exists for compatibility (e.g. with ProofGeneral) *)
+
 let _ =
   declare_int_option
     { optsync  = false;
-      optname  = "the undo limit";
+      optdepr  = true;
+      optname  = "the undo limit (OBSOLETE)";
       optkey   = ["Undo"];
-      optread  = Pfedit.get_undo;
-      optwrite = Pfedit.set_undo }
+      optread  = (fun _ -> None);
+      optwrite = (fun _ -> ()) }
 
 let _ =
   declare_int_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "the hypotheses limit";
       optkey   = ["Hyps";"Limit"];
       optread  = Flags.print_hyps_limit;
@@ -962,6 +1059,7 @@ let _ =
 let _ =
   declare_int_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "the printing depth";
       optkey   = ["Printing";"Depth"];
       optread  = Pp_control.get_depth_boxes;
@@ -970,6 +1068,7 @@ let _ =
 let _ =
   declare_int_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "the printing width";
       optkey   = ["Printing";"Width"];
       optread  = Pp_control.get_margin;
@@ -978,6 +1077,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "printing of universes";
       optkey   = ["Printing";"Universes"];
       optread  = (fun () -> !Constrextern.print_universes);
@@ -989,6 +1089,7 @@ let vernac_debug b =
 let _ =
   declare_bool_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Ltac debug";
       optkey   = ["Ltac";"Debug"];
       optread  = (fun () -> get_debug () <> Tactic_debug.DebugOff);
@@ -1006,7 +1107,7 @@ let vernac_set_opacity local str =
 
 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)
+  | IntValue n -> set_int_option_value_gen locality key n
   | BoolValue b -> set_bool_option_value_gen locality key b
 
 let vernac_unset_option locality key =
@@ -1046,18 +1147,25 @@ let get_current_context_of_args = function
   | None -> get_current_context ()
 
 let vernac_check_may_eval redexp glopt rc =
-  let (evmap,env) = get_current_context_of_args glopt in
-  let c = interp_constr evmap env rc in
-  let j = Typeops.typing env c in
+  let module P = Pretype_errors in
+  let (sigma, env) = get_current_context_of_args glopt in
+  let sigma', c = interp_open_constr sigma env rc in
+  let j =
+    try
+      Evarutil.check_evars env sigma sigma' c;
+      Arguments_renaming.rename_typing env c
+    with P.PretypeError (_,_,P.UnsolvableImplicit _)
+      | Compat.Loc.Exc_located (_,P.PretypeError (_,_,P.UnsolvableImplicit _)) ->
+      Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) in
   match redexp with
     | None ->
 	if !pcoq <> None then (Option.get !pcoq).print_check env j
 	else msg (print_judgment env j)
     | Some r ->
-	let redfun = fst (reduction_of_red_expr (interp_redexp env evmap r)) in
+	let redfun = fst (reduction_of_red_expr (interp_redexp env sigma' r)) in
 	if !pcoq <> None
-	then (Option.get !pcoq).print_eval redfun env evmap rc j
-	else msg (print_eval redfun env evmap rc j)
+	then (Option.get !pcoq).print_eval redfun env sigma' rc j
+	else msg (print_eval redfun env sigma' rc j)
 
 let vernac_declare_reduction locality s r =
   declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r)
@@ -1095,19 +1203,22 @@ let vernac_print = function
   | PrintCoercionPaths (cls,clt) ->
       ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
   | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ())
-  | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ()))
-  | PrintUniverses (Some s) -> dump_universes s
+  | PrintUniverses (b, None) ->
+    let univ = Global.universes () in
+    let univ = if b then Univ.sort_universes univ else univ in
+    pp (Univ.pr_universes univ)
+  | PrintUniverses (b, Some s) -> dump_universes b s
   | PrintHint r -> Auto.print_hint_ref (smart_global r)
   | PrintHintGoal -> Auto.print_applicable_hint ()
   | PrintHintDbName s -> Auto.print_hint_db_by_name s
   | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s
   | PrintHintDb -> Auto.print_searchtable ()
   | PrintScopes ->
-      pp (Notation.pr_scopes (Constrextern.without_symbols pr_lrawconstr))
+      pp (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
   | PrintScope s ->
-      pp (Notation.pr_scope (Constrextern.without_symbols pr_lrawconstr) s)
+      pp (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s)
   | PrintVisibility s ->
-      pp (Notation.pr_visibility (Constrextern.without_symbols pr_lrawconstr) s)
+      pp (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
   | PrintAbout qid -> msg (print_about qid)
   | PrintImplicit qid -> msg (print_impargs qid)
   | PrintAssumptions (o,r) ->
@@ -1145,7 +1256,7 @@ let interp_search_about_item = function
 	    (fun _ -> true) s sc in
 	GlobSearchSubPattern (Pattern.PRef ref)
       with UserError _ ->
-	error ("Unable to interp \""^s^"\" either as a reference or
+	error ("Unable to interp \""^s^"\" either as a reference or \
           	as an identifier component")
 
 let vernac_search s r =
@@ -1169,7 +1280,7 @@ let vernac_locate = function
   | LocateTerm (Genarg.ByNotation (_,ntn,sc)) ->
       ppnl
         (Notation.locate_notation
-          (Constrextern.without_symbols pr_lrawconstr) ntn sc)
+          (Constrextern.without_symbols pr_lglob_constr) ntn sc)
   | LocateLibrary qid -> print_located_library qid
   | LocateModule qid -> print_located_module qid
   | LocateTactic qid -> print_located_tactic qid
@@ -1178,16 +1289,6 @@ let vernac_locate = function
 (********************)
 (* Proof management *)
 
-let vernac_goal = function
-  | None -> ()
-  | Some c ->
-      if not (refining()) then begin
-        let unnamed_kind = Lemma (* Arbitrary *) in
-        start_proof_com (Global, Proof unnamed_kind) [None,c] (fun _ _ ->());
-	print_subgoals ()
-      end else
-	error "repeated Goal not permitted in refining mode."
-
 let vernac_abort = function
   | None ->
       delete_current_proof ();
@@ -1229,48 +1330,58 @@ let vernac_backtrack snum pnum naborts =
   vernac_backto snum;
   Pp.flush_all();
   (* there may be no proof in progress, even if no abort *)
-  (try print_subgoals () with UserError _ -> ())
+  (try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ())
 
 
 let vernac_focus gln =
-  check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
+  let p = Proof_global.give_me_the_proof () in
   match gln with
-    | None -> traverse_nth_goal 1; print_subgoals ()
-    | Some n -> traverse_nth_goal n; print_subgoals ()
+    | None -> Proof.focus focus_command_cond () 1 p; print_subgoals ()
+    | Some n -> Proof.focus focus_command_cond () n p; print_subgoals ()
+
 
-  (* Reset the focus to the top of the tree *)
+  (* Unfocuses one step in the focus stack. *)
 let vernac_unfocus () =
-  check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
-  make_focus 0; reset_top_of_script (); print_subgoals ()
-
-let vernac_go = function
-  | GoTo n -> Pfedit.traverse n;show_node()
-  | GoTop -> Pfedit.reset_top_of_tree ();show_node()
-  | GoNext -> Pfedit.traverse_next_unproven ();show_node()
-  | GoPrev -> Pfedit.traverse_prev_unproven ();show_node()
-
-let apply_subproof f occ =
-  let pts = get_pftreestate() in
-  let evc = evc_of_pftreestate pts in
-  let rec aux pts = function
-    | [] -> pts
-    | (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
-
-let explain_proof occ =
-  msg (apply_subproof (fun evd _ -> print_treescript evd) occ)
-
-let explain_tree occ =
-  msg (apply_subproof print_proof occ)
+  let p = Proof_global.give_me_the_proof () in
+  Proof.unfocus command_focus p; print_subgoals ()
+
+(* BeginSubproof / EndSubproof. 
+    BeginSubproof (vernac_subproof) focuses on the first goal, or the goal
+    given as argument.
+    EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided
+    that the proof of the goal has been completed.
+*)
+let subproof_kind = Proof.new_focus_kind ()
+let subproof_cond = Proof.done_cond subproof_kind
+
+let vernac_subproof gln =
+  let p = Proof_global.give_me_the_proof () in
+  begin match gln with
+  | None -> Proof.focus subproof_cond () 1 p
+  | Some n -> Proof.focus subproof_cond () n p
+  end ;
+  print_subgoals ()
+
+let vernac_end_subproof () =
+  let p = Proof_global.give_me_the_proof () in
+  Proof.unfocus subproof_kind p ; print_subgoals ()
+
+
+let vernac_bullet (bullet:Proof_global.Bullet.t) =
+  let p = Proof_global.give_me_the_proof () in
+  Proof.transaction p 
+    (fun () -> Proof_global.Bullet.put p bullet);
+  (* Makes the focus visible in emacs by re-printing the goal. *)
+  if !Flags.print_emacs then print_subgoals ()
+
 
 let vernac_show = function
-  | ShowGoal nopt ->
-      if !pcoq <> None then (Option.get !pcoq).show_goal nopt
-      else msg (match nopt with
-	| None -> pr_open_subgoals ()
-	| Some n -> pr_nth_open_subgoal n)
+  | ShowGoal goalref ->
+      if !pcoq <> None then (Option.get !pcoq).show_goal goalref
+      else msg (match goalref with
+	| OpenSubgoals -> pr_open_subgoals ()
+	| NthGoal n -> pr_nth_open_subgoal n
+        | GoalId id -> pr_goal_by_id id)
   | ShowGoalImplicitly None ->
       Constrextern.with_implicits msg (pr_open_subgoals ())
   | ShowGoalImplicitly (Some n) ->
@@ -1285,17 +1396,15 @@ let vernac_show = function
   | ShowIntros all -> show_intro all
   | ShowMatch id -> show_match id
   | ShowThesis -> show_thesis ()
-  | ExplainProof occ -> explain_proof occ
-  | ExplainTree occ -> explain_tree occ
 
 
 let vernac_check_guard () =
   let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts in
-  let (pfterm,_) = extract_open_pftreestate pts in
+  let pfterm = List.hd (Proof.partial_proof pts) in
   let message =
     try
-      Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf))
+      let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in
+      Inductiveops.control_only_guard (Goal.V82.env sigma gl)
 	pfterm;
       (str "The condition holds up to here")
     with UserError(_,s) ->
@@ -1325,8 +1434,8 @@ let interp c = match c with
   | VernacExactProof c -> vernac_exact_proof c
   | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl
   | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l
-  | VernacFixpoint (l,b) -> vernac_fixpoint l b
-  | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b
+  | VernacFixpoint l -> vernac_fixpoint l
+  | VernacCoFixpoint l -> vernac_cofixpoint l
   | VernacScheme l -> vernac_scheme l
   | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l
 
@@ -1354,21 +1463,13 @@ let interp c = match c with
   | VernacInstance (abst, glob, sup, inst, props, pri) ->
       vernac_instance abst glob sup inst props pri
   | VernacContext sup -> vernac_context sup
-  | VernacDeclareInstance (glob, id) -> vernac_declare_instance glob id
+  | VernacDeclareInstances (glob, ids) -> vernac_declare_instances glob ids
   | VernacDeclareClass id -> vernac_declare_class id
 
   (* Solving *)
   | VernacSolve (n,tac,b) -> vernac_solve n tac b
   | VernacSolveExistential (n,c) -> vernac_solve_existential n c
 
-  (* MMode *)
-
-  | VernacDeclProof -> vernac_decl_proof ()
-  | VernacReturn -> vernac_return ()
-  | VernacProofInstr stp -> vernac_proof_instr stp
-
-  (* /MMode *)
-
   (* Auxiliary file and library management *)
   | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f
   | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
@@ -1391,9 +1492,11 @@ let interp c = match c with
   (* Commands *)
   | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def
   | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b
+  | VernacRemoveHints (local,dbnames,ids) -> vernac_remove_hints local dbnames ids
   | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints
   | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b
   | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l
+  | VernacArguments (local, qid, l, narg, flags) -> vernac_declare_arguments local qid l narg flags 
   | VernacReserve bl -> vernac_reserve bl
   | VernacGeneralizable (local,gen) -> vernac_generalizable local gen
   | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl
@@ -1424,10 +1527,17 @@ let interp c = match c with
   | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts
   | VernacFocus n -> vernac_focus n
   | VernacUnfocus -> vernac_unfocus ()
-  | VernacGo g -> vernac_go g
+  | VernacBullet b -> vernac_bullet b
+  | VernacSubproof n -> vernac_subproof n
+  | VernacEndSubproof -> vernac_end_subproof ()
   | VernacShow s -> vernac_show s
   | VernacCheckGuard -> vernac_check_guard ()
-  | VernacProof tac -> vernac_set_end_tac tac
+  | VernacProof (None, None) -> ()
+  | VernacProof (Some tac, None) -> vernac_set_end_tac tac
+  | VernacProof (None, Some l) -> vernac_set_used_variables l
+  | VernacProof (Some tac, Some l) -> 
+      vernac_set_end_tac tac; vernac_set_used_variables l
+  | VernacProofMode mn -> Proof_global.set_proof_mode mn
   (* Toplevel control *)
   | VernacToplevelControl e -> raise e
 
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 1cca3540..8fb6f466 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -1,34 +1,31 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Vernacinterp
 open Vernacexpr
 open Topconstr
-(*i*)
 
-(* Vernacular entries *)
+(** Vernacular entries *)
 
 val show_script : unit -> unit
 val show_prooftree : unit -> unit
 
 val show_node : unit -> unit
 
-(* This function can be used by any command that want to observe terms
+(** This function can be used by any command that want to observe terms
    in the context of the current goal, as for instance in pcoq *)
 val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
 
 (*i
-(* this function is used to analyse the extra arguments in search commands.
+
+(** this function is used to analyse the extra arguments in search commands.
    It is used in pcoq. *) (*i anciennement: inside_outside i*)
 val interp_search_restriction : search_restriction -> dir_path list * bool
 i*)
@@ -42,12 +39,12 @@ type pcoq_hook = {
   print_check : Environ.env -> Environ.unsafe_judgment -> unit;
   print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
     Environ.unsafe_judgment -> unit;
-  show_goal : int option -> unit
+  show_goal : goal_reference -> unit
 }
 
 val set_pcoq_hook : pcoq_hook -> unit
 
-(* This function makes sure that the function given in argument is preceded
+(** This function makes sure that the function given in argument is preceded
    by a command aborting all proofs if necessary.
    It is used in pcoq. *)
 val abort_refine : ('a -> unit) -> 'a -> unit;;
@@ -55,3 +52,17 @@ val abort_refine : ('a -> unit) -> 'a -> unit;;
 val interp : Vernacexpr.vernac_expr -> unit
 
 val vernac_reset_name : identifier Util.located -> unit
+
+val vernac_backtrack : int -> int -> int -> unit
+
+(* Print subgoals when the verbose flag is on. Meant to be used inside
+    vernac commands from plugins. *)
+val print_subgoals : unit -> unit
+
+(** Prepare a "match" template for a given inductive type.
+    For each branch of the match, we list the constructor name
+    followed by enough pattern variables.
+    [Not_found] is raised if the given string isn't the qualid of
+    a known inductive type. *)
+
+val make_cases : string -> string list list
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
index 31c46a54..850bc111 100644
--- a/toplevel/vernacexpr.ml
+++ b/toplevel/vernacexpr.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacexpr.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
+open Compat
 open Util
 open Names
 open Tacexpr
@@ -16,6 +15,7 @@ open Genarg
 open Topconstr
 open Decl_kinds
 open Ppextend
+open Declaremods
 
 (* Toplevel control exceptions *)
 exception Drop
@@ -31,6 +31,13 @@ type lreference = reference
 
 type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation
 
+type goal_identifier = string
+
+type goal_reference =
+  | OpenSubgoals
+  | NthGoal of int
+  | GoalId of goal_identifier
+
 type printable =
   | PrintTables
   | PrintFullContext
@@ -52,7 +59,7 @@ type printable =
   | PrintCoercions
   | PrintCoercionPaths of class_rawexpr * class_rawexpr
   | PrintCanonicalConversions
-  | PrintUniverses of string option
+  | PrintUniverses of bool * string option
   | PrintHint of reference or_by_notation
   | PrintHintGoal
   | PrintHintDbName of string
@@ -82,14 +89,8 @@ type locatable =
   | LocateTactic of reference
   | LocateFile of string
 
-type goable =
-  | GoTo of int
-  | GoTop
-  | GoNext
-  | GoPrev
-
 type showable =
-  | ShowGoal of int option
+  | ShowGoal of goal_reference
   | ShowGoalImplicitly of int option
   | ShowProof
   | ShowNode
@@ -100,8 +101,6 @@ type showable =
   | ShowIntros of bool
   | ShowMatch of lident
   | ShowThesis
-  | ExplainProof of int list
-  | ExplainTree of int list
 
 type comment =
   | CommentConstr of constr_expr
@@ -126,7 +125,8 @@ type rec_flag       = bool (* true = Rec;           false = NoRec          *)
 type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
 type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
 type locality_flag  = bool (* true = Local;         false = Global         *)
-type coercion_flag  = bool (* true = AddCoercion;   false = NoCoercion     *)
+type coercion_flag  = bool (* true = AddCoercion    false = NoCoercion     *)
+type instance_flag  = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *)
 type export_flag    = bool (* true = Export;        false = Import         *)
 type specif_flag    = bool (* true = Specification; false = Implementation *)
 type inductive_flag = Decl_kinds.recursivity_kind
@@ -134,16 +134,16 @@ 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
+type option_value = Goptionstyp.option_value =
   | BoolValue of bool
+  | IntValue of int option
+  | StringValue of string
 
 type option_ref_value =
   | StringRefValue of string
   | QualidRefValue of reference
 
-type sort_expr = Rawterm.rawsort
+type sort_expr = Glob_term.glob_sort
 
 type definition_expr =
   | ProveBody of local_binder list * constr_expr
@@ -165,11 +165,13 @@ type decl_notation = lstring * constr_expr * scope_name option
 type simple_binder = lident list  * constr_expr
 type class_binder = lident * constr_expr list
 type 'a with_coercion = coercion_flag * 'a
+type 'a with_instance = instance_flag * 'a
 type 'a with_notation = 'a * decl_notation list
+type 'a with_priority = 'a * int option
 type constructor_expr = (lident * constr_expr) with_coercion
 type constructor_list_or_record_decl_expr =
   | Constructors of constructor_expr list
-  | RecordDecl of lident option * local_decl_expr with_coercion with_notation list
+  | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list
 type inductive_expr =
   lident with_coercion * local_binder list * constr_expr option * inductive_kind *
     constructor_list_or_record_decl_expr
@@ -177,6 +179,7 @@ type inductive_expr =
 type one_inductive_expr =
   lident * local_binder list * constr_expr option * constructor_expr list
 
+type module_ast_inl = module_ast annotated
 type module_binder = bool option * lident list * module_ast_inl
 
 type grammar_tactic_prod_item_expr =
@@ -186,7 +189,7 @@ type grammar_tactic_prod_item_expr =
 type syntax_modifier =
   | SetItemLevel of string list * production_level
   | SetLevel of int
-  | SetAssoc of Gramext.g_assoc
+  | SetAssoc of gram_assoc
   | SetEntryType of string * simple_constr_prod_entry_key
   | SetOnlyParsing
   | SetFormat of string located
@@ -200,6 +203,13 @@ type scheme =
   | CaseScheme of bool * reference or_by_notation * sort_expr
   | EqualityScheme of reference or_by_notation
 
+type inline = int option (* inlining level, none for no inlining *)
+
+type bullet =
+    | Dash
+    | Star
+    | Plus
+
 type vernac_expr =
   (* Control *)
   | VernacList of located_vernac_expr list
@@ -214,8 +224,6 @@ type vernac_expr =
   | VernacOpenCloseScope of (locality_flag * bool * scope_name)
   | VernacDelimiters of scope_name * string
   | VernacBindScope of scope_name * class_rawexpr list
-  | VernacArgumentsScope of locality_flag * reference or_by_notation *
-      scope_name option list
   | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
       constr_expr * scope_name option
   | VernacNotation of
@@ -230,10 +238,10 @@ type vernac_expr =
         bool * declaration_hook
   | VernacEndProof of proof_end
   | VernacExactProof of constr_expr
-  | VernacAssumption of assumption_kind * bool * simple_binder with_coercion list
+  | VernacAssumption of assumption_kind * inline * simple_binder with_coercion list
   | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list
-  | VernacFixpoint of (fixpoint_expr * decl_notation list) list * bool
-  | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list * bool
+  | VernacFixpoint of (fixpoint_expr * decl_notation list) list
+  | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list
   | VernacScheme of (lident option * scheme) list
   | VernacCombinedScheme of lident * lident list
 
@@ -255,13 +263,13 @@ type vernac_expr =
       bool * (* global *)
       local_binder list * (* super *)
 	typeclass_constraint * (* instance name, class name, params *)
-	constr_expr * (* props *)
+	constr_expr option * (* props *)
 	int option (* Priority *)
 
   | VernacContext of local_binder list
 
-  | VernacDeclareInstance of
-      bool (* global *) * reference (* instance name *)
+  | VernacDeclareInstances of
+      bool (* global *) * reference list (* instance names *)
 
   | VernacDeclareClass of reference (* inductive or definition name *)
 
@@ -279,13 +287,6 @@ type vernac_expr =
   | VernacSolve of int * raw_tactic_expr * bool
   | VernacSolveExistential of int * constr_expr
 
-  (* Proof Mode *)
-
-  | VernacDeclProof
-  | VernacReturn
-  | VernacProofInstr of Decl_expr.raw_proof_instr
-
-
   (* Auxiliary file and library management *)
   | VernacRequireFrom of export_flag option * specif_flag option * string
   | VernacAddLoadPath of rec_flag * string * dir_path option
@@ -309,11 +310,18 @@ type vernac_expr =
   | VernacDeclareTacticDefinition of
       (locality_flag * rec_flag * (reference * bool * raw_tactic_expr) list)
   | VernacCreateHintDb of locality_flag * string * bool
+  | VernacRemoveHints of locality_flag * string list * reference list
   | VernacHints of locality_flag * string list * hints_expr
   | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) *
       locality_flag * onlyparsing_flag
   | VernacDeclareImplicits of locality_flag * reference or_by_notation *
       (explicitation * bool * bool) list list
+  | VernacArguments of locality_flag * reference or_by_notation * 
+      ((name * bool * (loc * string) option * bool * bool) list) list *
+      int * [ `SimplDontExposeCase | `SimplNeverUnfold | `Rename
+            | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list
+  | VernacArgumentsScope of locality_flag * reference or_by_notation *
+      scope_name option list
   | VernacReserve of simple_binder list
   | VernacGeneralizable of locality_flag * (lident list) option
   | VernacSetOpacity of
@@ -345,10 +353,13 @@ type vernac_expr =
   | VernacBacktrack of int*int*int
   | VernacFocus of int option
   | VernacUnfocus
-  | VernacGo of goable
+  | VernacBullet of bullet
+  | VernacSubproof of int option
+  | VernacEndSubproof
   | VernacShow of showable
   | VernacCheckGuard
-  | VernacProof of raw_tactic_expr
+  | VernacProof of raw_tactic_expr option * lident list option
+  | VernacProofMode of string
   (* Toplevel control *)
   | VernacToplevelControl of exn
 
@@ -369,9 +380,6 @@ 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 () =
   match !locality_flag with
   | Some (loc,true) -> 
@@ -395,7 +403,7 @@ let enforce_locality_full local =
 	error "Use only prefix \"Local\"."
     | None ->
 	if local then begin
-	  Flags.if_verbose
+	  Flags.if_warn
 	   Pp.msg_warning (Pp.str"Obsolete syntax: use \"Local\" as a prefix.");
 	  Some true
 	end else
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index e6fe9a4f..10c5a00f 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernacinterp.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -66,7 +64,3 @@ let call (opn,converted_args) =
         if !Flags.debug then
 	  msgnl (str"Vernac Interpreter " ++ str !loc);
         raise e
-
-let bad_vernac_args s =
-  anomalylabstrm s
-    (str"Vernac " ++ str s ++ str" called with bad arguments")
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index 780e4e28..5fdc2b2c 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -1,18 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacinterp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Tacexpr
-(*i*)
 
-(* Interpretation of extended vernac phrases. *)
+(** Interpretation of extended vernac phrases. *)
 
 val disable_drop : exn -> exn
 
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
index e380ae6f..aa38e9e9 100644
--- a/toplevel/whelp.ml4
+++ b/toplevel/whelp.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: whelp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Flags
 open Pp
 open Util
@@ -17,10 +15,9 @@ open System
 open Names
 open Term
 open Environ
-open Rawterm
+open Glob_term
 open Libnames
 open Nametab
-open Termops
 open Detyping
 open Constrintern
 open Dischargedhypsmap
@@ -41,6 +38,7 @@ open Goptions
 let _ =
   declare_string_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Whelp server";
       optkey   = ["Whelp";"Server"];
       optread  = (fun () -> !whelp_server_name);
@@ -49,6 +47,7 @@ let _ =
 let _ =
   declare_string_option
     { optsync  = false;
+      optdepr  = false;
       optname  = "Whelp getter";
       optkey   = ["Whelp";"Getter"];
       optread  = (fun () -> !getter_server_name);
@@ -94,10 +93,10 @@ let uri_of_repr_kn ref (mp,dir,l) =
 let url_paren f l = url_char '('; f l; url_char ')'
 let url_bracket f l = url_char '['; f l; url_char ']'
 
-let whelp_of_rawsort = function
-  | RProp Null -> "Prop"
-  | RProp Pos -> "Set"
-  | RType _ -> "Type"
+let whelp_of_glob_sort = function
+  | GProp Null -> "Prop"
+  | GProp Pos -> "Set"
+  | GType _ -> "Type"
 
 let uri_int n = Buffer.add_string b (string_of_int n)
 
@@ -130,9 +129,9 @@ let uri_params f = function
 let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp)
 
 let section_parameters = function
-  | RRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) ->
+  | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) ->
       get_discharged_hyp_names (path_of_global (IndRef(induri,0)))
-  | RRef (_,(ConstRef cst as ref)) ->
+  | GRef (_,(ConstRef cst as ref)) ->
       get_discharged_hyp_names (path_of_global ref)
   | _ -> []
 
@@ -144,33 +143,33 @@ let merge vl al =
 
 let rec uri_of_constr c =
   match c with
-  | RVar (_,id) -> url_id id
-  | RRef (_,ref) ->  uri_of_global ref
-  | RHole _ | REvar _ -> url_string "?"
-  | RSort (_,s) -> url_string (whelp_of_rawsort s)
+  | GVar (_,id) -> url_id id
+  | GRef (_,ref) ->  uri_of_global ref
+  | GHole _ | GEvar _ -> url_string "?"
+  | GSort (_,s) -> url_string (whelp_of_glob_sort s)
   | _ -> url_paren (fun () -> match c with
-  | RApp (_,f,args) ->
+  | GApp (_,f,args) ->
       let inst,rest = merge (section_parameters f) args in
       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) ->
+  | GLambda (_,na,k,ty,c) ->
       url_string "\\lambda "; url_of_name na; url_string ":";
       uri_of_constr ty; url_string "."; uri_of_constr c
-  | RProd (_,Anonymous,k,ty,c) ->
+  | GProd (_,Anonymous,k,ty,c) ->
       uri_of_constr ty; url_string "\\to "; uri_of_constr c
-  | RProd (_,Name id,k,ty,c) ->
+  | GProd (_,Name id,k,ty,c) ->
       url_string "\\forall "; url_id id; url_string ":";
       uri_of_constr ty; url_string "."; uri_of_constr c
-  | RLetIn (_,na,b,c) ->
+  | GLetIn (_,na,b,c) ->
       url_string "let "; url_of_name na; url_string "\\def ";
       uri_of_constr b; url_string " in "; uri_of_constr c
-  | RCast (_,c, CastConv (_,t)) ->
+  | GCast (_,c, CastConv (_,t)) ->
       uri_of_constr c; url_string ":"; uri_of_constr t
-  | RRec _ | RIf _ | RLetTuple _ | RCases _ ->
+  | GRec _ | GIf _ | GLetTuple _ | GCases _ ->
       error "Whelp does not support pattern-matching and (co-)fixpoint."
-  | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) ->
+  | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) ->
       anomaly "Written w/o parenthesis"
-  | RPatVar _ | RDynamic _ ->
+  | GPatVar _ ->
       anomaly "Found constructors not supported in constr") ()
 
 let make_string f x = Buffer.reset b; f x; Buffer.contents b
@@ -196,8 +195,9 @@ let whelp_elim ind =
   send_whelp "elim" (make_string uri_of_global (IndRef ind))
 
 let on_goal f =
-  let gls = nth_goal_of_pftreestate 1 (get_pftreestate ()) in
-  f (it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
+  let { Evd.it=goals ; sigma=sigma } = Proof.V82.subgoals (get_pftreestate ()) in
+  let gls = { Evd.it=List.hd goals ; sigma = sigma }  in
+  f (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
 
 type whelp_request =
   | Locate of string
diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli
index 75e9ad49..b0fb5491 100644
--- a/toplevel/whelp.mli
+++ b/toplevel/whelp.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: whelp.mli 14641 2011-11-06 11:59:10Z herbelin $ 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